From noreply at r-forge.r-project.org Mon Aug 3 14:56:46 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 3 Aug 2015 14:56:46 +0200 (CEST) Subject: [Vinecopula-commits] r107 - in pkg: . R inst Message-ID: <20150803125646.92A1F18799B@r-forge.r-project.org> Author: ben_graeler Date: 2015-08-03 14:56:46 +0200 (Mon, 03 Aug 2015) New Revision: 107 Modified: pkg/DESCRIPTION pkg/R/tawnCopula.R pkg/inst/ChangeLog Log: - Added methods for Pickand's dependence function "A" for tawnT1Copula, surTawnT1Copula, tawnT2Copula and surTawnT2Copula Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2015-07-30 13:09:51 UTC (rev 106) +++ pkg/DESCRIPTION 2015-08-03 12:56:46 UTC (rev 107) @@ -2,7 +2,7 @@ Type: Package Title: Statistical Inference of Vine Copulas Version: 1.7 -Date: 2015-07-30 +Date: 2015-08-03 Author: Ulf Schepsmeier, Jakob Stoeber, Eike Christian Brechmann, Benedikt Graeler, Thomas Nagler, Tobias Erhardt Maintainer: Tobias Erhardt Depends: R (>= 2.11.0) Modified: pkg/R/tawnCopula.R =================================================================== --- pkg/R/tawnCopula.R 2015-07-30 13:09:51 UTC (rev 106) +++ pkg/R/tawnCopula.R 2015-08-03 12:56:46 UTC (rev 107) @@ -68,6 +68,14 @@ setMethod("tau",signature("tawnT1Copula"),linkVineCop.tau) setMethod("tailIndex",signature("tawnT1Copula"),linkVineCop.tailIndex) +# Pickand's A +# c-code: Tawn2(double* t, int* n, double* par, double* par2, double* par3, double* out) +setMethod("A", signature("tawnT1Copula"), function(copula, w) { + .C("Tawn2",as.double(w), as.integer(length(w)), + as.double(copula at parameters[1]), as.double(copula at parameters[2]), + as.double(1), as.double(rep(0,length(w))), PACKAGE = "VineCopula")[[6]] +}) + ################################# ## Tawn type 1 survival copula ## ################################# @@ -123,6 +131,19 @@ setMethod("tau",signature("surTawnT1Copula"),linkVineCop.tau) setMethod("tailIndex",signature("surTawnT1Copula"),linkVineCop.tailIndex) +# Pickand's A +# c-code: Tawn2(double* t, int* n, double* par, double* par2, double* par3, double* out) +setMethod("A", signature("surTawnT1Copula"), function(copula, w) { + u <- -expm1(-1+w) + v <- -expm1(-w) + + surA <- .C("Tawn2",as.double(log(v)/log(u*v)), as.integer(length(w)), + as.double(copula at parameters[1]), as.double(copula at parameters[2]), + as.double(1), as.double(rep(0,length(w))), PACKAGE = "VineCopula")[[6]] + -log(1-u + 1-v - 1 + (u*v)^surA) + # -log(1-u + 1-v - 1 + VineCopula:::linkVineCop.CDFtawn(cbind(u,v), tawnT1Copula(copula at parameters))) +}) + ####################################### ## Tawn type 1 90 deg. rotate copula ## ####################################### @@ -290,8 +311,17 @@ setMethod("tau",signature("tawnT2Copula"),linkVineCop.tau) setMethod("tailIndex",signature("tawnT2Copula"),linkVineCop.tailIndex) +# Pickand's A +# c-code: Tawn2(double* t, int* n, double* par, double* par2, double* par3, double* out) +setMethod("A", signature("tawnT2Copula"), function(copula, w) { + .C("Tawn2",as.double(w), as.integer(length(w)), + as.double(copula at parameters[1]), as.double(1), + as.double(copula at parameters[2]), + as.double(rep(0,length(w))), PACKAGE = "VineCopula")[[6]] +}) + ################################# -## Tawn type 1 survival copula ## +## Tawn type 2 survival copula ## ################################# setClass("surTawnT2Copula", @@ -345,8 +375,21 @@ setMethod("tau",signature("surTawnT2Copula"),linkVineCop.tau) setMethod("tailIndex",signature("surTawnT2Copula"),linkVineCop.tailIndex) +# Pickand's A +# c-code: Tawn2(double* t, int* n, double* par, double* par2, double* par3, double* out) +setMethod("A", signature("surTawnT2Copula"), function(copula, w) { + u <- -expm1(-1+w) # 1-u + v <- -expm1(-w) # 1-v + + surA <- .C("Tawn2",as.double(log(v)/log(u*v)), as.integer(length(w)), + as.double(copula at parameters[1]), as.double(1), + as.double(copula at parameters[2]), + as.double(rep(0,length(w))), PACKAGE = "VineCopula")[[6]] + -log(1-u + 1-v - 1 + (u*v)^surA) +}) + ####################################### -## Tawn type 1 90 deg. rotate copula ## +## Tawn type 2 90 deg. rotate copula ## ####################################### setClass("r90TawnT2Copula", @@ -401,7 +444,7 @@ setMethod("tailIndex",signature("r90TawnT2Copula"),linkVineCop.tailIndex) ######################################## -## Tawn type 1 270 deg. rotate copula ## +## Tawn type 2 270 deg. rotate copula ## ######################################## setClass("r270TawnT2Copula", Modified: pkg/inst/ChangeLog =================================================================== --- pkg/inst/ChangeLog 2015-07-30 13:09:51 UTC (rev 106) +++ pkg/inst/ChangeLog 2015-08-03 12:56:46 UTC (rev 107) @@ -9,6 +9,7 @@ * The S4-class objets of the Tawn copulas pointed to Archimedean CDFs, now corrected to true CDFs based on c-code * TauMatrix: restriction for input data to be in [0,1] removed * RVineCopSelect: no printing of family-Matrix + * Added methods for Pickand's dependence function "A" for tawnT1Copula, surTawnT1Copula, tawnT2Copula and surTawnT2Copula Version 1.6 (July 16, 2015) From noreply at r-forge.r-project.org Tue Aug 4 14:42:29 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 4 Aug 2015 14:42:29 +0200 (CEST) Subject: [Vinecopula-commits] r108 - pkg/src Message-ID: <20150804124229.4FCF7185E88@r-forge.r-project.org> Author: tnagler Date: 2015-08-04 14:42:28 +0200 (Tue, 04 Aug 2015) New Revision: 108 Modified: pkg/src/hfunc.c Log: - correct Hinv2 for Tawn families (must change type before call to Hinv) Modified: pkg/src/hfunc.c =================================================================== --- pkg/src/hfunc.c 2015-08-03 12:56:46 UTC (rev 107) +++ pkg/src/hfunc.c 2015-08-04 12:42:28 UTC (rev 108) @@ -1,14 +1,14 @@ /* -** hfunc.c - C code of the package CDRVine -** -** with contributions from Carlos Almeida, Aleksey Min, -** Ulf Schepsmeier, Jakob Stoeber and Eike Brechmann -** -** A first version was based on code -** from Daniel Berg -** provided by personal communication. -** -*/ + ** hfunc.c - C code of the package CDRVine + ** + ** with contributions from Carlos Almeida, Aleksey Min, + ** Ulf Schepsmeier, Jakob Stoeber and Eike Brechmann + ** + ** A first version was based on code + ** from Daniel Berg + ** provided by personal communication. + ** + */ #include "include/vine.h" #include "include/hfunc.h" @@ -25,125 +25,125 @@ void pcondbb1(double* u, double* v, int* n, double* param, double* out) { - int i; - double th, de; - double t1, t2, t3, t16, t17, t4, t5, t6, t7, t9, t10, t12, t13, t20; - - th = param[0]; - de = param[1]; - for(i=0;i<*n;i++) - { - t1 = pow(u[i],-th); - t2 = t1-1.; - t3 = pow(t2,de); - t16 = 1./u[i]; - t17 = 1./t2; - t4 = pow(v[i],-th); - t5 = t4-1.; - t6 = pow(t5,de); - t7 = t3+t6; - t9 = pow(t7,1/de); - t10 = 1.0+t9; - t12 = pow(t10,-1/th); - t13 = t12*t9; - t20 = 1./t10; - out[i] = t13*t3*t1*t16*t17/t7*t20; - } - + int i; + double th, de; + double t1, t2, t3, t16, t17, t4, t5, t6, t7, t9, t10, t12, t13, t20; + + th = param[0]; + de = param[1]; + for(i=0;i<*n;i++) + { + t1 = pow(u[i],-th); + t2 = t1-1.; + t3 = pow(t2,de); + t16 = 1./u[i]; + t17 = 1./t2; + t4 = pow(v[i],-th); + t5 = t4-1.; + t6 = pow(t5,de); + t7 = t3+t6; + t9 = pow(t7,1/de); + t10 = 1.0+t9; + t12 = pow(t10,-1/th); + t13 = t12*t9; + t20 = 1./t10; + out[i] = t13*t3*t1*t16*t17/t7*t20; + } + } void pcondbb6(double* u, double* v, int* n, double* param, double* out) { - int i; - double th, de; - double t1, t2, t3, t4, t5, t12, t16, t6, t7, t8, t9, t10, t11, t13, t14, t15, t17; - - th = param[0]; - de = param[1]; - - for(i=0;i<*n;i++) - { - t1 = 1.0-u[i]; - t2 = pow(t1,th); - t3 = 1.0-t2; - t4 = log(t3); - t5 = pow(-t4,de); - t12 = 1/de; - t16 = 1/th; - t6 = 1.0-v[i]; - t7 = pow(t6,th); - t8 = 1.0-t7; - t9 = log(t8); - t10 = pow(-t9,de); - t11 = t5+t10; - t13 = pow(t11,t12); - t14 = exp(-t13); - t15 = 1.0-t14; - t17 = pow(t15,t16); - - out[i] = -t17*t13*t5*t2/t1/t3/t4/t11*t14/t15; - } - + int i; + double th, de; + double t1, t2, t3, t4, t5, t12, t16, t6, t7, t8, t9, t10, t11, t13, t14, t15, t17; + + th = param[0]; + de = param[1]; + + for(i=0;i<*n;i++) + { + t1 = 1.0-u[i]; + t2 = pow(t1,th); + t3 = 1.0-t2; + t4 = log(t3); + t5 = pow(-t4,de); + t12 = 1/de; + t16 = 1/th; + t6 = 1.0-v[i]; + t7 = pow(t6,th); + t8 = 1.0-t7; + t9 = log(t8); + t10 = pow(-t9,de); + t11 = t5+t10; + t13 = pow(t11,t12); + t14 = exp(-t13); + t15 = 1.0-t14; + t17 = pow(t15,t16); + + out[i] = -t17*t13*t5*t2/t1/t3/t4/t11*t14/t15; + } + } void pcondbb7(double* u, double* v, int* n, double* param, double* out) { - int i; - double th, de; - double t1, t2, t3, t4, t6, t8, t9, t11, t12, t14; - - th = param[0]; - de = param[1]; - - for(i=0;i<*n;i++) - { - t1 = 1.0-u[i]; - t2 = pow(t1,1.0*th); - t3 = 1.0-t2; - t4 = pow(t3,-1.0*de); - t6 = pow(1.0-v[i],1.0*th); - t8 = pow(1.0-t6,-1.0*de); - t9 = t4+t8-1.0; - t11 = pow(t9,-1.0/de); - t12 = 1.0-t11; - t14 = pow(t12,1.0/th); - - out[i] = t14*t11*t4*t2/t1/t3/t9/t12; - } - + int i; + double th, de; + double t1, t2, t3, t4, t6, t8, t9, t11, t12, t14; + + th = param[0]; + de = param[1]; + + for(i=0;i<*n;i++) + { + t1 = 1.0-u[i]; + t2 = pow(t1,1.0*th); + t3 = 1.0-t2; + t4 = pow(t3,-1.0*de); + t6 = pow(1.0-v[i],1.0*th); + t8 = pow(1.0-t6,-1.0*de); + t9 = t4+t8-1.0; + t11 = pow(t9,-1.0/de); + t12 = 1.0-t11; + t14 = pow(t12,1.0/th); + + out[i] = t14*t11*t4*t2/t1/t3/t9/t12; + } + } void pcondbb8(double* u, double* v, int* n, double* param, double* out) { - int i; - double th, de; - double t2, t3, t12, t16, t6, t7, t8, t10, t11, t13, t15, t17; - - th = param[0]; - de = param[1]; - - for(i=0;i<*n;i++) - { - t2 = 1.0-de*u[i]; - t3 = pow(t2,th); - t10 = 1.0-de; - t11 = pow(t10,th); - t12 = 1.0-t11; - t13 = 1/t12; - t16 = 1/th; - t6 = 1.0-de*v[i]; - t7 = pow(t6,th); - t8 = 1.0-t7; - t15 = 1.0-(1.0-t3)*t8*t13; - t17 = pow(t15,t16); - - out[i] = t17*t3/t2*t8*t13/t15; - } - + int i; + double th, de; + double t2, t3, t12, t16, t6, t7, t8, t10, t11, t13, t15, t17; + + th = param[0]; + de = param[1]; + + for(i=0;i<*n;i++) + { + t2 = 1.0-de*u[i]; + t3 = pow(t2,th); + t10 = 1.0-de; + t11 = pow(t10,th); + t12 = 1.0-t11; + t13 = 1/t12; + t16 = 1/th; + t6 = 1.0-de*v[i]; + t7 = pow(t6,th); + t8 = 1.0-t7; + t15 = 1.0-(1.0-t3)*t8*t13; + t17 = pow(t15,t16); + + out[i] = t17*t3/t2*t8*t13/t15; + } + } @@ -151,228 +151,228 @@ // i.e. Hfunc1 and Hfunc2 void Hfunc1(int* family,int* n,double* u,double* v,double* theta,double* nu,double* out) { - double *negv, *negu; - negv = (double *) malloc(*n* sizeof(double)); - negu = (double *) malloc(*n*sizeof(double)); - double ntheta, nnu; - int nfamily, j, T=1; - ntheta = -*theta; - nnu = -*nu; - - for(int i=0;i<*n;i++) - { - if(u[i]UMAX) u[i]=UMAX; - if(v[i]UMAX) v[i]=UMAX; - } - - if((*family)==43) - { - nfamily=3; - if(*theta > 0){ - ntheta=2*(*theta)/(1-*theta); - Hfunc(&nfamily, n, u, v, &ntheta, &nnu, out); - }else{ - ntheta=-2*(*theta)/(1+*theta); - for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} - Hfunc(&nfamily, n, u, negv, &ntheta, &nnu, out); - } - }else if((*family)==44) - { - nfamily=4; - if(*theta > 0){ - ntheta=1/(1-*theta); - Hfunc (&nfamily, n, u, v, &ntheta, &nnu, out); - }else{ - ntheta=1/(1+*theta); - for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} - Hfunc (&nfamily, n, u, negv, &ntheta, &nnu, out); - } - }else{ - - if(((*family==23) | (*family==24) | (*family==26) | (*family==27) | (*family==28) | (*family==29) | (*family==30) | (*family==61) )) + double *negv, *negu; + negv = (double *) malloc(*n* sizeof(double)); + negu = (double *) malloc(*n*sizeof(double)); + double ntheta, nnu; + int nfamily, j, T=1; + ntheta = -*theta; + nnu = -*nu; + + for(int i=0;i<*n;i++) { - nfamily=(*family)-20; - for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} - Hfunc (&nfamily, n, u, negv, &ntheta, &nnu, out); + if(u[i]UMAX) u[i]=UMAX; + if(v[i]UMAX) v[i]=UMAX; } - else if(((*family==33) | (*family==34) | (*family==36) | (*family==37) | (*family==38) | (*family==39) | (*family==40) | (*family==71) )) - { - nfamily=(*family)-30; - for (int i = 0; i < *n; ++i) {negu[i]=1 - u[i];} - Hfunc(&nfamily, n, negu, v, &ntheta, &nnu, out); - for (int i = 0; i < *n; i++) {out[i]=1-out[i];}; - } - // u and v enter in wrong order from BiCopHfunc and have to be treated accordingly - else if(*family==104) - { - double par3=1; - dC_du(v,u,n,theta,nu,&par3,out); - } - else if(*family==114) - { - double par3=1; - for(j=0;j<*n;j++) - { - negv[j]= 1-v[j]; - negu[j]= 1-u[j]; - dC_du(&negv[j],&negu[j],&T,theta,nu,&par3,&out[j]); - out[j]= 1-out[j]; - } - } - else if(*family==124) - { - double par3=1; - for(j=0;j<*n;j++) - { - negv[j]= 1-v[j]; - dC_du(&negv[j],&u[j],&T,&ntheta,nu,&par3,&out[j]); - } - } - else if(*family==134) - { - double par3=1; - for(j=0;j<*n;j++) - { - negu[j]= 1-u[j]; - dC_du(&v[j],&negu[j],&T,&ntheta,nu,&par3,&out[j]); - out[j]=1-out[j]; - - } - } - else if(*family==204) - { - double par3=*nu; - double par2=1; - dC_du(v,u,n,theta,&par2,&par3,out); - } - else if(*family==214) - { - double par3=*nu; - double par2=1; - for(j=0;j<*n;j++) - { - negv[j]= 1-v[j]; - negu[j]= 1-u[j]; - dC_du(&negv[j],&negu[j],&T,theta,&par2,&par3,&out[j]); - out[j]= 1-out[j]; - } - } - else if(*family==224) - { - double par3=*nu; - double par2=1; - for(j=0;j<*n;j++) - { - negv[j]= 1-v[j]; - dC_du(&negv[j],&u[j],&T,&ntheta,&par2,&par3,&out[j]); - } - } - else if(*family==234) - { - double par3=*nu; - double par2=1; - for(j=0;j<*n;j++) - { - negu[j]= 1-u[j]; - dC_du(&v[j],&negu[j],&T,&ntheta,&par2,&par3,&out[j]); - out[j]=1-out[j]; - } - } - else { - Hfunc (family, n, u, v, theta, nu, out); - } - } - // ensure that results are in [0,1] - for(int j=0; j <* n; ++j){out[j] = MIN(MAX(out[j], 0), 1);} - free(negv); - free(negu); + + if((*family)==43) + { + nfamily=3; + if(*theta > 0){ + ntheta=2*(*theta)/(1-*theta); + Hfunc(&nfamily, n, u, v, &ntheta, &nnu, out); + }else{ + ntheta=-2*(*theta)/(1+*theta); + for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} + Hfunc(&nfamily, n, u, negv, &ntheta, &nnu, out); + } + }else if((*family)==44) + { + nfamily=4; + if(*theta > 0){ + ntheta=1/(1-*theta); + Hfunc (&nfamily, n, u, v, &ntheta, &nnu, out); + }else{ + ntheta=1/(1+*theta); + for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} + Hfunc (&nfamily, n, u, negv, &ntheta, &nnu, out); + } + }else{ + + if(((*family==23) | (*family==24) | (*family==26) | (*family==27) | (*family==28) | (*family==29) | (*family==30) | (*family==61) )) + { + nfamily=(*family)-20; + for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} + Hfunc (&nfamily, n, u, negv, &ntheta, &nnu, out); + } + else if(((*family==33) | (*family==34) | (*family==36) | (*family==37) | (*family==38) | (*family==39) | (*family==40) | (*family==71) )) + { + nfamily=(*family)-30; + for (int i = 0; i < *n; ++i) {negu[i]=1 - u[i];} + Hfunc(&nfamily, n, negu, v, &ntheta, &nnu, out); + for (int i = 0; i < *n; i++) {out[i]=1-out[i];}; + } + // u and v enter in wrong order from BiCopHfunc and have to be treated accordingly + else if(*family==104) + { + double par3=1; + dC_du(v,u,n,theta,nu,&par3,out); + } + else if(*family==114) + { + double par3=1; + for(j=0;j<*n;j++) + { + negv[j]= 1-v[j]; + negu[j]= 1-u[j]; + dC_du(&negv[j],&negu[j],&T,theta,nu,&par3,&out[j]); + out[j]= 1-out[j]; + } + } + else if(*family==124) + { + double par3=1; + for(j=0;j<*n;j++) + { + negv[j]= 1-v[j]; + dC_du(&negv[j],&u[j],&T,&ntheta,nu,&par3,&out[j]); + } + } + else if(*family==134) + { + double par3=1; + for(j=0;j<*n;j++) + { + negu[j]= 1-u[j]; + dC_du(&v[j],&negu[j],&T,&ntheta,nu,&par3,&out[j]); + out[j]=1-out[j]; + + } + } + else if(*family==204) + { + double par3=*nu; + double par2=1; + dC_du(v,u,n,theta,&par2,&par3,out); + } + else if(*family==214) + { + double par3=*nu; + double par2=1; + for(j=0;j<*n;j++) + { + negv[j]= 1-v[j]; + negu[j]= 1-u[j]; + dC_du(&negv[j],&negu[j],&T,theta,&par2,&par3,&out[j]); + out[j]= 1-out[j]; + } + } + else if(*family==224) + { + double par3=*nu; + double par2=1; + for(j=0;j<*n;j++) + { + negv[j]= 1-v[j]; + dC_du(&negv[j],&u[j],&T,&ntheta,&par2,&par3,&out[j]); + } + } + else if(*family==234) + { + double par3=*nu; + double par2=1; + for(j=0;j<*n;j++) + { + negu[j]= 1-u[j]; + dC_du(&v[j],&negu[j],&T,&ntheta,&par2,&par3,&out[j]); + out[j]=1-out[j]; + } + } + else { + Hfunc (family, n, u, v, theta, nu, out); + } + } + // ensure that results are in [0,1] + for(int j=0; j <* n; ++j){out[j] = MIN(MAX(out[j], 0), 1);} + free(negv); + free(negu); } void Hfunc2(int* family,int* n,double* v,double* u,double* theta,double* nu,double* out) { - double *negv, *negu; - negv = (double *) malloc(*n * sizeof(double)); - negu = (double *) malloc(*n * sizeof(double)); - double ntheta, nnu; - int nfamily; - ntheta = -*theta; - nnu = -*nu; - + double *negv, *negu; + negv = (double *) malloc(*n * sizeof(double)); + negu = (double *) malloc(*n * sizeof(double)); + double ntheta, nnu; + int nfamily; + ntheta = -*theta; + nnu = -*nu; + for(int i=0;i<*n;i++) - { - if(u[i]UMAX) u[i]=UMAX; - if(v[i]UMAX) v[i]=UMAX; - } - - if((*family)==43) - { - nfamily=3; - if(*theta > 0){ - ntheta=2*(*theta)/(1-*theta); - Hfunc (&nfamily, n, v, u, &ntheta, &nnu, out); - }else{ - ntheta=-2*(*theta)/(1+*theta); - for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} - Hfunc(&nfamily, n, negv, u, &ntheta, &nnu, out); - for (int i = 0; i < *n; i++) {out[i]=1-out[i];}; - } - }else if((*family)==44) - { - nfamily=4; - if(*theta > 0){ - ntheta=1/(1-*theta); - Hfunc (&nfamily, n, v, u, &ntheta, &nnu, out); - }else{ - ntheta=1/(1+*theta); - for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} - Hfunc(&nfamily, n, negv, u, &ntheta, &nnu, out); - for (int i = 0; i < *n; i++) {out[i]=1-out[i];}; } - }else{ - - if(((*family==23) | (*family==24) | (*family==26) | (*family==27) | (*family==28) | (*family==29) | (*family==30) | (*family==61) )) { - nfamily=(*family)-20; - for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} - Hfunc(&nfamily, n, negv, u, &ntheta, &nnu, out); - for (int i = 0; i < *n; i++) {out[i]=1-out[i];}; + if(u[i]UMAX) u[i]=UMAX; + if(v[i]UMAX) v[i]=UMAX; } - else if(((*family==33) | (*family==34) | (*family==36) | (*family==37) | (*family==38) | (*family==39) | (*family==40) | (*family==71) )) - { - nfamily=(*family)-30; - for (int i = 0; i < *n; ++i) {negu[i]=1 - u[i];} - Hfunc(&nfamily, n, v, negu, &ntheta, &nnu, out); - } - // else if(*family==104 | *family==204 | *family==114 | *family==214) - // { - // u und v vertauschen (Unsauber, aber so sollte es funktionieren in unserer bisherigen Notation) - // Hfunc(family,n,u,v,theta,nu,out); - // } - else if((*family==124) | (*family==224)) - { - nfamily=(*family)-20; - for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} - Hfunc(&nfamily, n, negv, u, &ntheta, nu, out); - for (int i = 0; i < *n; i++) {out[i]=1-out[i];}; - } - else if((*family==134) | (*family==234)) - { - nfamily=(*family)-30; - for (int i = 0; i < *n; ++i) {negu[i]=1 - u[i];} - Hfunc(&nfamily, n, v, negu, &ntheta, nu, out); - } - else - { - Hfunc(family, n, v, u, theta, nu, out); + + if((*family)==43) + { + nfamily=3; + if(*theta > 0){ + ntheta=2*(*theta)/(1-*theta); + Hfunc (&nfamily, n, v, u, &ntheta, &nnu, out); + }else{ + ntheta=-2*(*theta)/(1+*theta); + for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} + Hfunc(&nfamily, n, negv, u, &ntheta, &nnu, out); + for (int i = 0; i < *n; i++) {out[i]=1-out[i];}; + } + }else if((*family)==44) + { + nfamily=4; + if(*theta > 0){ + ntheta=1/(1-*theta); + Hfunc (&nfamily, n, v, u, &ntheta, &nnu, out); + }else{ + ntheta=1/(1+*theta); + for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} + Hfunc(&nfamily, n, negv, u, &ntheta, &nnu, out); + for (int i = 0; i < *n; i++) {out[i]=1-out[i];}; } + }else{ + + if(((*family==23) | (*family==24) | (*family==26) | (*family==27) | (*family==28) | (*family==29) | (*family==30) | (*family==61) )) + { + nfamily=(*family)-20; + for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} + Hfunc(&nfamily, n, negv, u, &ntheta, &nnu, out); + for (int i = 0; i < *n; i++) {out[i]=1-out[i];}; + } + else if(((*family==33) | (*family==34) | (*family==36) | (*family==37) | (*family==38) | (*family==39) | (*family==40) | (*family==71) )) + { + nfamily=(*family)-30; + for (int i = 0; i < *n; ++i) {negu[i]=1 - u[i];} + Hfunc(&nfamily, n, v, negu, &ntheta, &nnu, out); + } + // else if(*family==104 | *family==204 | *family==114 | *family==214) + // { + // u und v vertauschen (Unsauber, aber so sollte es funktionieren in unserer bisherigen Notation) + // Hfunc(family,n,u,v,theta,nu,out); + // } + else if((*family==124) | (*family==224)) + { + nfamily=(*family)-20; + for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} + Hfunc(&nfamily, n, negv, u, &ntheta, nu, out); + for (int i = 0; i < *n; i++) {out[i]=1-out[i];}; + } + else if((*family==134) | (*family==234)) + { + nfamily=(*family)-30; + for (int i = 0; i < *n; ++i) {negu[i]=1 - u[i];} + Hfunc(&nfamily, n, v, negu, &ntheta, nu, out); + } + else + { + Hfunc(family, n, v, u, theta, nu, out); + } } - } - // ensure that results are in [0,1] - for(int i=0; i < *n; ++i) {out[i] = MIN(MAX(out[i], 0), 1);} - free(negv); - free(negu); + // ensure that results are in [0,1] + for(int i=0; i < *n; ++i) {out[i] = MIN(MAX(out[i], 0), 1);} + free(negv); + free(negu); } @@ -390,534 +390,534 @@ ////////////////////////////////////////////////////////////// void Hfunc(int* family, int* n, double* u, double* v, double* theta, double* nu, double* out) { - int j; - double *h; - h = Calloc(*n,double); - double x; - - /*for(int i=0;i<*n;i++) - { - if(u[i]UMAX) u[i]=UMAX; - if(v[i]UMAX) v[i]=UMAX; - }*/ -//Rprintf("family in Hfunc: %d\n", *family); -//Rprintf("theta=par1 in Hfunc: %f\n", *theta); -//Rprintf("nu=par2 in Hfunc: %f\n", *nu); - for(j=0;j<*n;j++) - { - if((v[j]==0) | ( u[j]==0)) h[j] = 0; - else if (v[j]==1) h[j] = u[j]; - else - { - if(*family==0) //independent - { - h[j] = u[j]; - } - else if(*family==1) //gaussian - { - x = (qnorm(u[j],0.0,1.0,1,0) - *theta*qnorm(v[j],0.0,1.0,1,0))/sqrt(1.0-pow(*theta,2.0)); - if (isfinite(x)) - h[j] = pnorm(x,0.0,1.0,1,0); - else if ((qnorm(u[j],0.0,1.0,1,0) - *theta*qnorm(v[j],0.0,1.0,1,0)) < 0) - h[j] = 0; - else - h[j] = 1; - } - else if(*family==2) //student - { - double t1, t2, mu, sigma2; - t1 = qt(u[j],*nu,1,0); t2 = qt(v[j],*nu,1,0); mu = *theta*t2; sigma2 = ((*nu+t2*t2)*(1.0-*theta*(*theta)))/(*nu+1.0); - h[j] = pt((t1-mu)/sqrt(sigma2),*nu+1.0,1,0); - } - else if(*family==3) //clayton - { - if(*theta == 0) h[j] = u[j] ; - if(*theta < XEPS) h[j] = u[j] ; - else - { - x = pow(u[j],-*theta)+pow(v[j],-*theta)-1.0 ; - h[j] = pow(v[j],-*theta-1.0)*pow(x,-1.0-1.0/(*theta)); - if(*theta < 0) - { - if(x < 0) h[j] = 0; - } - } - } - else if(*family==4) //gumbel - { - if(*theta == 1) h[j] = u[j] ; - else - { - h[j] = -(exp(-pow(pow(-log(v[j]),*theta)+pow(-log(u[j]),*theta),1.0/(*theta)))*pow(pow(-log(v[j]),*theta)+pow(-log(u[j]),*theta),1.0/(*theta)-1.0)*pow(-log(v[j]),*theta))/(v[j]*log(v[j])); - } - } - else if(*family==5) //frank - { - if(*theta==0) h[j]=u[j]; - else - { - h[j] = -(exp(*theta)*(exp(*theta*u[j])-1.0))/(exp(*theta*v[j]+*theta*u[j])-exp(*theta*v[j]+*theta)-exp(*theta*u[j]+*theta)+exp(*theta)); - } - } - else if(*family==6) //joe - { - if(*theta==1) h[j]=u[j]; - else - { - h[j] = pow(pow(1.0-u[j],*theta) + pow(1.0-v[j],*theta) - pow(1.0-u[j],*theta)*pow(1.0-v[j],*theta),1.0/(*theta)-1) * pow(1.0-v[j],*theta-1.0)*(1-pow(1-u[j],*theta)); - } - } - else if(*family==7) //BB1 - { - double* param; - param = Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - int T=1; - if(*nu==1) - { - if(*theta==0) h[j]=u[j]; - else h[j]=pow(pow(u[j],-*theta)+pow(v[j],-*theta)-1,-1/(*theta)-1)*pow(v[j],-*theta-1); - } - else if(*theta==0) - { - h[j]=-(exp(-pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)))*pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)-1.0)*pow(-log(v[j]),*nu))/(v[j]*log(v[j])); - } - else - { - pcondbb1(&v[j],&u[j],&T,param,&h[j]); - } - Free(param); - } - else if(*family==8) //BB6 - { - double* param; - param = Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - int T=1; - if(*theta==1) - { - if(*nu==1) h[j]=u[j]; - else h[j]=-(exp(-pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)))*pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)-1.0)*pow(-log(v[j]),*nu))/(v[j]*log(v[j])); - } - else if(*nu==1) - { - h[j]=pow(pow(1.0-u[j],*theta) + pow(1.0-v[j],*theta) - pow(1.0-u[j],*theta)*pow(1.0-v[j],*theta),1.0/(*theta)-1) * pow(1.0-v[j],*theta-1.0)*(1-pow(1-u[j],*theta)); - } - else - { - pcondbb6(&v[j],&u[j],&T,param,&h[j]); - } - Free(param); - } - else if(*family==9) //BB7 - { - double* param; - param = Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - int T=1; - if(*theta==1) - { - if(*nu==0) h[j]=u[j]; - else h[j]=pow(pow(u[j],-*nu)+pow(v[j],-*nu)-1,-1/(*nu)-1)*pow(v[j],-*nu-1); - } - else if(*nu==0) - { - h[j] = pow(pow(1.0-u[j],*theta) + pow(1.0-v[j],*theta) - pow(1.0-u[j],*theta)*pow(1.0-v[j],*theta),1.0/(*theta)-1) * pow(1.0-v[j],*theta-1.0)*(1-pow(1-u[j],*theta)); - } - else - { - pcondbb7(&v[j],&u[j],&T,param,&h[j]); - } - Free(param); - } - else if(*family==10) //BB8 - { - double* param; - param = Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - int T=1; - if(*nu==0) - { - h[j]=u[j]; - } - else if(*nu==1) - { - if(*theta==1) h[j]=u[j]; - else h[j]=pow(pow(1.0-u[j],*theta) + pow(1.0-v[j],*theta) - pow(1.0-u[j],*theta)*pow(1.0-v[j],*theta),1.0/(*theta)-1) * pow(1.0-v[j],*theta-1.0)*(1-pow(1-u[j],*theta)); - } - else - { - pcondbb8(&v[j],&u[j],&T,param,&h[j]); - } - Free(param); - } - else if(*family==13) //rotated clayton (180?) - { - if(*theta == 0) h[j] = u[j] ; - if(*theta < XEPS) h[j] = u[j] ; - else - { - u[j]=1-u[j]; - v[j]=1-v[j]; - x = pow(u[j],-*theta)+pow(v[j],-*theta)-1.0 ; - h[j] = pow(v[j],-*theta-1.0)*pow(x,-1.0-1.0/(*theta)); // pow(v[j],-*theta-1.0)*pow(pow(u[j],-*theta)+pow(v[j],-*theta)-1.0,-1.0-1.0/(*theta)); - h[j]= 1-h[j]; - u[j]=1-u[j]; - v[j]=1-v[j]; - } - } - else if(*family==14) //rotated gumbel (180?) - { - v[j]= 1-v[j]; - u[j]= 1-u[j]; - h[j]= -(exp(-pow(pow(-log(v[j]),*theta)+pow(-log(u[j]),*theta),1.0/(*theta)))*pow(pow(-log(v[j]),*theta)+pow(-log(u[j]),*theta),1.0/(*theta)-1.0)*pow(-log(v[j]),*theta))/(v[j]* log(v[j])); - h[j]= 1-h[j]; - u[j]=1-u[j]; - v[j]=1-v[j]; - } - else if(*family==16) - { - v[j]= 1-v[j]; - u[j]= 1-u[j]; - h[j] = pow(pow(1.0-u[j],*theta) + pow(1.0-v[j],*theta) - pow(1.0-u[j],*theta)*pow(1.0-v[j],*theta),1.0/(*theta)-1) * pow(1.0-v[j],*theta-1.0)*(1-pow(1-u[j],*theta)); - h[j]= 1-h[j]; - u[j]=1-u[j]; - v[j]=1-v[j]; - } - else if(*family==17) //rotated BB1 - { - double* param; - param = Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - int T=1; - if(*nu==1) - { - if(*theta==0) h[j]=u[j]; - else - { - h[j]=pow(pow(1-u[j],-*theta)+pow(1-v[j],-*theta)-1,-1/(*theta)-1)*pow(1-v[j],-*theta-1); - h[j]= 1-h[j]; - } - } - else if(*theta==0) - { - h[j]=-(exp(-pow(pow(-log(1-v[j]),*nu)+pow(-log(1-u[j]),*nu),1.0/(*nu)))*pow(pow(-log(1-v[j]),*nu)+pow(-log(1-u[j]),*nu),1.0/(*nu)-1.0)*pow(-log(1-v[j]),*nu))/((1-v[j])*log(1-v[j])); - h[j]= 1-h[j]; - } - else - { - v[j]= 1-v[j]; - u[j]= 1-u[j]; - pcondbb1(&v[j],&u[j],&T,param,&h[j]); - u[j]=1-u[j]; - v[j]=1-v[j]; - h[j]= 1-h[j]; - } - Free(param); - } - else if(*family==18) //rotated BB6 - { - double* param; - param = Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - int T=1; - if(*theta==1) - { - if(*nu==1) h[j]=u[j]; - else - { - h[j]=-(exp(-pow(pow(-log(1-v[j]),*nu)+pow(-log(1-u[j]),*nu),1.0/(*nu)))*pow(pow(-log(1-v[j]),*nu)+pow(-log(1-u[j]),*nu),1.0/(*nu)-1.0)*pow(-log(1-v[j]),*nu))/((1-v[j])*log(1-v[j])); - h[j]= 1-h[j]; - } - } - else if(*nu==1) - { - h[j]=pow(pow(u[j],*theta) + pow(v[j],*theta) - pow(u[j],*theta)*pow(v[j],*theta),1.0/(*theta)-1) * pow(v[j],*theta-1.0)*(1-pow(u[j],*theta)); - h[j]= 1-h[j]; - } - else - { - v[j]= 1-v[j]; - u[j]= 1-u[j]; - pcondbb6(&v[j],&u[j],&T,param,&h[j]); - u[j]=1-u[j]; - v[j]=1-v[j]; - h[j]= 1-h[j]; - } - Free(param); - } - else if(*family==19) //rotated BB7 - { - double* param; - param = Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - int T=1; - if(*theta==1) - { - if(*nu==0) h[j]=u[j]; - else{ - h[j]=pow(pow(1-u[j],-*nu)+pow(1-v[j],-*nu)-1,-1/(*nu)-1)*pow(1-v[j],-*nu-1); - h[j]= 1-h[j]; - } - } - else if(*nu==0) - { - h[j] = pow(pow(u[j],*theta) + pow(v[j],*theta) - pow(u[j],*theta)*pow(v[j],*theta),1.0/(*theta)-1) * pow(v[j],*theta-1.0)*(1-pow(u[j],*theta)); - h[j]= 1-h[j]; - } - else - { - v[j]= 1-v[j]; - u[j]= 1-u[j]; - pcondbb7(&v[j],&u[j],&T,param,&h[j]); - u[j]=1-u[j]; - v[j]=1-v[j]; - h[j]= 1-h[j]; - } - Free(param); - } - else if(*family==20) //rotated BB8 - { - double* param; - param = Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - int T=1; - if(*nu==0) - { - h[j]=u[j]; - } - else if(*nu==1) - { - if(*theta==1) h[j]=u[j]; - else{ - h[j]=pow(pow(u[j],*theta) + pow(v[j],*theta) - pow(u[j],*theta)*pow(v[j],*theta),1.0/(*theta)-1) * pow(v[j],*theta-1.0)*(1-pow(u[j],*theta)); - h[j]= 1-h[j]; - } - } - else - { - v[j]= 1-v[j]; - u[j]= 1-u[j]; - pcondbb8(&v[j],&u[j],&T,param,&h[j]); - u[j]=1-u[j]; - v[j]=1-v[j]; - h[j]= 1-h[j]; - } - Free(param); - } - else if(*family==41) - { - double t1,t2,t3; - t1=qgamma(1.0-u[j],*theta,1,1,0); - t2=qgamma(1.0-v[j],*theta,1,1,0); - t3=pow(pow(t1,*theta)+pow(t2,*theta),(1.0/(*theta))); - h[j]=exp(-t3+t1); - } - else if(*family==104) - { - int T=1; - double par3=1; - dC_dv(&u[j],&v[j],&T,theta,nu,&par3,&h[j]); - } - else if(*family==114) - { - int T=1; - double par3=1; - v[j]= 1-v[j]; - u[j]= 1-u[j]; - dC_dv(&u[j],&v[j],&T,theta,nu,&par3,&h[j]); - u[j]=1-u[j]; - v[j]=1-v[j]; - h[j]= 1-h[j]; - } - else if(*family==204) - { - int T=1; - double par3=*nu, par2=1; - dC_dv(&u[j],&v[j],&T,theta,&par2,&par3,&h[j]); - } - else if(*family==214) - { - int T=1; - double par3=*nu, par2=1; - v[j]= 1-v[j]; - u[j]= 1-u[j]; - dC_dv(&u[j],&v[j],&T,theta,&par2,&par3,&h[j]); - u[j]=1-u[j]; - v[j]=1-v[j]; - h[j]= 1-h[j]; - } + int j; + double *h; + h = Calloc(*n,double); + double x; + + /*for(int i=0;i<*n;i++) + { + if(u[i]UMAX) u[i]=UMAX; + if(v[i]UMAX) v[i]=UMAX; + }*/ + //Rprintf("family in Hfunc: %d\n", *family); + //Rprintf("theta=par1 in Hfunc: %f\n", *theta); + //Rprintf("nu=par2 in Hfunc: %f\n", *nu); + for(j=0;j<*n;j++) + { + if((v[j]==0) | ( u[j]==0)) h[j] = 0; + else if (v[j]==1) h[j] = u[j]; + else + { + if(*family==0) //independent + { + h[j] = u[j]; + } + else if(*family==1) //gaussian + { + x = (qnorm(u[j],0.0,1.0,1,0) - *theta*qnorm(v[j],0.0,1.0,1,0))/sqrt(1.0-pow(*theta,2.0)); + if (isfinite(x)) + h[j] = pnorm(x,0.0,1.0,1,0); + else if ((qnorm(u[j],0.0,1.0,1,0) - *theta*qnorm(v[j],0.0,1.0,1,0)) < 0) + h[j] = 0; + else + h[j] = 1; + } + else if(*family==2) //student + { + double t1, t2, mu, sigma2; + t1 = qt(u[j],*nu,1,0); t2 = qt(v[j],*nu,1,0); mu = *theta*t2; sigma2 = ((*nu+t2*t2)*(1.0-*theta*(*theta)))/(*nu+1.0); + h[j] = pt((t1-mu)/sqrt(sigma2),*nu+1.0,1,0); + } + else if(*family==3) //clayton + { + if(*theta == 0) h[j] = u[j] ; + if(*theta < XEPS) h[j] = u[j] ; + else + { + x = pow(u[j],-*theta)+pow(v[j],-*theta)-1.0 ; + h[j] = pow(v[j],-*theta-1.0)*pow(x,-1.0-1.0/(*theta)); + if(*theta < 0) + { + if(x < 0) h[j] = 0; + } + } + } + else if(*family==4) //gumbel + { + if(*theta == 1) h[j] = u[j] ; + else + { + h[j] = -(exp(-pow(pow(-log(v[j]),*theta)+pow(-log(u[j]),*theta),1.0/(*theta)))*pow(pow(-log(v[j]),*theta)+pow(-log(u[j]),*theta),1.0/(*theta)-1.0)*pow(-log(v[j]),*theta))/(v[j]*log(v[j])); + } + } + else if(*family==5) //frank + { + if(*theta==0) h[j]=u[j]; + else + { + h[j] = -(exp(*theta)*(exp(*theta*u[j])-1.0))/(exp(*theta*v[j]+*theta*u[j])-exp(*theta*v[j]+*theta)-exp(*theta*u[j]+*theta)+exp(*theta)); + } + } + else if(*family==6) //joe + { + if(*theta==1) h[j]=u[j]; + else + { + h[j] = pow(pow(1.0-u[j],*theta) + pow(1.0-v[j],*theta) - pow(1.0-u[j],*theta)*pow(1.0-v[j],*theta),1.0/(*theta)-1) * pow(1.0-v[j],*theta-1.0)*(1-pow(1-u[j],*theta)); + } + } + else if(*family==7) //BB1 + { + double* param; + param = Calloc(2,double); + param[0]=*theta; + param[1]=*nu; + int T=1; + if(*nu==1) + { + if(*theta==0) h[j]=u[j]; + else h[j]=pow(pow(u[j],-*theta)+pow(v[j],-*theta)-1,-1/(*theta)-1)*pow(v[j],-*theta-1); + } + else if(*theta==0) + { + h[j]=-(exp(-pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)))*pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)-1.0)*pow(-log(v[j]),*nu))/(v[j]*log(v[j])); + } + else + { + pcondbb1(&v[j],&u[j],&T,param,&h[j]); + } + Free(param); + } + else if(*family==8) //BB6 + { + double* param; + param = Calloc(2,double); + param[0]=*theta; + param[1]=*nu; + int T=1; + if(*theta==1) + { + if(*nu==1) h[j]=u[j]; + else h[j]=-(exp(-pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)))*pow(pow(-log(v[j]),*nu)+pow(-log(u[j]),*nu),1.0/(*nu)-1.0)*pow(-log(v[j]),*nu))/(v[j]*log(v[j])); + } + else if(*nu==1) + { + h[j]=pow(pow(1.0-u[j],*theta) + pow(1.0-v[j],*theta) - pow(1.0-u[j],*theta)*pow(1.0-v[j],*theta),1.0/(*theta)-1) * pow(1.0-v[j],*theta-1.0)*(1-pow(1-u[j],*theta)); + } + else + { + pcondbb6(&v[j],&u[j],&T,param,&h[j]); + } + Free(param); + } + else if(*family==9) //BB7 + { + double* param; + param = Calloc(2,double); + param[0]=*theta; + param[1]=*nu; + int T=1; + if(*theta==1) + { + if(*nu==0) h[j]=u[j]; + else h[j]=pow(pow(u[j],-*nu)+pow(v[j],-*nu)-1,-1/(*nu)-1)*pow(v[j],-*nu-1); + } + else if(*nu==0) + { [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vinecopula -r 108 From noreply at r-forge.r-project.org Tue Aug 4 16:08:16 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 4 Aug 2015 16:08:16 +0200 (CEST) Subject: [Vinecopula-commits] r109 - pkg/R Message-ID: <20150804140816.BAA51186FDE@r-forge.r-project.org> Author: tnagler Date: 2015-08-04 16:08:16 +0200 (Tue, 04 Aug 2015) New Revision: 109 Added: pkg/R/BiCopCheck.R Modified: pkg/R/BiCop.R pkg/R/BiCopCDF.r pkg/R/BiCopDeriv.r pkg/R/BiCopDeriv2.r pkg/R/BiCopGofTest.r pkg/R/BiCopHfunc.r pkg/R/BiCopHfuncDeriv.r pkg/R/BiCopHfuncDeriv2.r pkg/R/BiCopLambda.r pkg/R/BiCopMetaContour.r pkg/R/BiCopPDF.r pkg/R/BiCopPar2Beta.r pkg/R/BiCopPar2TailDep.r pkg/R/BiCopPar2Tau.r pkg/R/BiCopSim.R pkg/R/RVineMatrix.R Log: - add function BiCopCheck (internal) for checking of family/parameter consistency - code cosmetics Modified: pkg/R/BiCop.R =================================================================== --- pkg/R/BiCop.R 2015-08-04 12:42:28 UTC (rev 108) +++ pkg/R/BiCop.R 2015-08-04 14:08:16 UTC (rev 109) @@ -1,90 +1,7 @@ BiCop <- function(family, par, par2 = 0) { ## family/parameter consistency checks - 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, 51, 61, 71, - 104, 114, 124, 134, - 204, 214, 224, 234))) - stop("Copula family not implemented.") - if (family %in% c(2, 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 t-, 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.") + BiCopCheck(family, par, par2) - 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.") - 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].") - ## return BiCop object out <- list(family = family, par = par, par2 = par2) class(out) <- "BiCop" Modified: pkg/R/BiCopCDF.r =================================================================== --- pkg/R/BiCopCDF.r 2015-08-04 12:42:28 UTC (rev 108) +++ pkg/R/BiCopCDF.r 2015-08-04 14:08:16 UTC (rev 109) @@ -14,19 +14,15 @@ family <- NA if (missing(par)) par <- NA + # for short hand usage extract obj from family + if (class(family) == "BiCop") + obj <- family if (!is.null(obj)) { stopifnot(class(obj) == "BiCop") family <- obj$family par <- obj$par par2 <- obj$par2 } - if (class(family) == "BiCop") { - # for short hand usage extract from family - obj <- family - family <- obj$family - par <- obj$par - par2 <- obj$par2 - } ## sanity checks for family and parameters if (is.na(family) | is.na(par)) @@ -43,70 +39,8 @@ 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.") + BiCopCheck(family, par, par2) - 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 Added: pkg/R/BiCopCheck.R =================================================================== --- pkg/R/BiCopCheck.R (rev 0) +++ pkg/R/BiCopCheck.R 2015-08-04 14:08:16 UTC (rev 109) @@ -0,0 +1,106 @@ +BiCopCheck <- function(family, par, par2 = 0, obj = NULL) { + ## extract family and parameters if BiCop object is provided + if (missing(family)) + family <- NA + if (missing(par)) + par <- NA + # for short hand usage extract obj from family + if (class(family) == "BiCop") + obj <- family + if (!is.null(obj)) { + stopifnot(class(obj) == "BiCop") + family <- obj$family + par <- obj$par + par2 <- obj$par2 + } + + ## sanity checks for family and parameters + if (is.na(family) | is.na(par)) + stop("Provide either 'family' and 'par' or 'obj'") + 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))) + 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.") + + 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.") + 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 == 42) { + a <- par + b <- par2 + limA <- (b - 3 - sqrt(9 + 6 * b - 3 * b^2))/2 + if (abs(b) > 1) + stop("The second parameter of the two-parametric asymmetric copulas has to be in the interval [-1,1]") + if (a > 1 || a < limA) + stop("The first parameter of the two-parametric asymmetric copula has to be in the interval [limA(par2),1]") + } + 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].") + + ## return TRUE if all checks pass + TRUE +} \ No newline at end of file Modified: pkg/R/BiCopDeriv.r =================================================================== --- pkg/R/BiCopDeriv.r 2015-08-04 12:42:28 UTC (rev 108) +++ pkg/R/BiCopDeriv.r 2015-08-04 14:08:16 UTC (rev 109) @@ -14,21 +14,15 @@ family <- NA if (missing(par)) par <- NA + # for short hand usage extract obj from family + if (class(family) == "BiCop") + obj <- family if (!is.null(obj)) { stopifnot(class(obj) == "BiCop") family <- obj$family par <- obj$par par2 <- obj$par2 } - if (class(family) == "BiCop") { - # for short hand usage extract from family - if (class(par) == "character") - deriv <- par - obj <- family - family <- obj$family - par <- obj$par - par2 <- obj$par2 - } ## sanity checks for family and parameters if (is.na(family) | is.na(par)) @@ -39,29 +33,11 @@ stop("For t-copulas, 'par2' must be set.") if (family %in% c(1, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36) && length(par) < 1) stop("'par' not set.") - 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.") - 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 == 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 (deriv == "par2" && family != 2) stop("The derivative with respect to the second parameter can only be derived for the t-copula.") if (log == TRUE && (deriv %in% c("u1", "u2"))) stop("The derivative with respect to one of the arguments are not available in the log case.") + BiCopCheck(family, par, par2) ## call C routines for specified 'deriv' case n <- length(u1) Modified: pkg/R/BiCopDeriv2.r =================================================================== --- pkg/R/BiCopDeriv2.r 2015-08-04 12:42:28 UTC (rev 108) +++ pkg/R/BiCopDeriv2.r 2015-08-04 14:08:16 UTC (rev 109) @@ -14,21 +14,15 @@ family <- NA if (missing(par)) par <- NA + # for short hand usage extract obj from family + if (class(family) == "BiCop") + obj <- family if (!is.null(obj)) { stopifnot(class(obj) == "BiCop") family <- obj$family par <- obj$par par2 <- obj$par2 } - if (class(family) == "BiCop") { - # for short hand usage extract from family - if (class(par) == "character") - deriv <- par - obj <- family - family <- obj$family - par <- obj$par - par2 <- obj$par2 - } ## sanity checks for family and parameters if (is.na(family) | is.na(par)) @@ -37,35 +31,12 @@ stop("Copula family not implemented.") if (family == 2 && par2 == 0) stop("For t-copulas, 'par2' must be set.") - if (family %in% c(1, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36) && length(par) < 1) - stop("'par' not set.") - - 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.") - 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 == 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 (deriv == "par2" && family != 2) stop("The derivative with respect to the second parameter can only be derived for the t-copula.") + BiCopCheck(family, par, par2) - # Unterscheidung in die verschiedenen Ableitungen - + ## calculate derivatives n <- length(u1) - if (deriv == "par") { if (family == 2) { out <- .C("diff2PDF_rho_tCopula", Modified: pkg/R/BiCopGofTest.r =================================================================== --- pkg/R/BiCopGofTest.r 2015-08-04 12:42:28 UTC (rev 108) +++ pkg/R/BiCopGofTest.r 2015-08-04 14:08:16 UTC (rev 109) @@ -18,19 +18,15 @@ ## extract family and parameters if BiCop object is provided if (missing(family)) family <- NA + # for short hand usage extract obj from family + if (class(family) == "BiCop") + obj <- family if (!is.null(obj)) { stopifnot(class(obj) == "BiCop") family <- obj$family par <- obj$par par2 <- obj$par2 } - if (class(family) == "BiCop") { - # for short hand usage extract from family - obj <- family - family <- obj$family - par <- obj$par - par2 <- obj$par2 - } ## sanity checks for family and parameters if (is.na(family)) @@ -42,59 +38,8 @@ stop("For t-, BB1, BB6, BB7 and BB8 copulas, 'par2' must be set.") if (c(1, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36) %in% family && length(par) < 1) stop("'par' not set.") - - if (par != 0) { - 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.") - 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 (par != 0) + BiCopCheck(family, par, par2) if (family == 2 && method == "kendall") stop("The goodness-of-fit test based on Kendall's process is not implemented for the t-copula.") if (family %in% c(7, 8, 9, 10, 17, 18, 19, 20, 27, 28, 29, 30, 37, 38, 39, 40) && Modified: pkg/R/BiCopHfunc.r =================================================================== --- pkg/R/BiCopHfunc.r 2015-08-04 12:42:28 UTC (rev 108) +++ pkg/R/BiCopHfunc.r 2015-08-04 14:08:16 UTC (rev 109) @@ -25,119 +25,38 @@ family <- NA if (missing(par)) par <- NA + # for short hand usage extract obj from family + if (class(family) == "BiCop") + obj <- family if (!is.null(obj)) { stopifnot(class(obj) == "BiCop") family <- obj$family par <- obj$par par2 <- obj$par2 } - if (class(family) == "BiCop") { - # for short hand usage extract from family - obj <- family - family <- obj$family - par <- obj$par - par2 <- obj$par2 - } - + ## sanity checks for family and parameters - if (is.na(family) | is.na(par)) - stop("Provide either 'family' and 'par' or 'obj'") - 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))) - 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.") + BiCopCheck(family, par, par2) - 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.") - 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) [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vinecopula -r 109 From noreply at r-forge.r-project.org Tue Aug 4 16:09:18 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 4 Aug 2015 16:09:18 +0200 (CEST) Subject: [Vinecopula-commits] r110 - in pkg: . R man Message-ID: <20150804140918.8A308183BD7@r-forge.r-project.org> Author: tnagler Date: 2015-08-04 16:09:18 +0200 (Tue, 04 Aug 2015) New Revision: 110 Added: pkg/R/BiCopHinv.R pkg/man/BiCopHinv.Rd Modified: pkg/NAMESPACE Log: - new function BiCopHinv for computation of inverse h-functions Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2015-08-04 14:08:16 UTC (rev 109) +++ pkg/NAMESPACE 2015-08-04 14:09:18 UTC (rev 110) @@ -33,6 +33,7 @@ export(BiCopSelect) export(BiCopName) export(BiCopHfunc) +export(BiCopHinv) export(BiCopDeriv) export(BiCopDeriv2) export(BiCopHfuncDeriv) Added: pkg/R/BiCopHinv.R =================================================================== --- pkg/R/BiCopHinv.R (rev 0) +++ pkg/R/BiCopHinv.R 2015-08-04 14:09:18 UTC (rev 110) @@ -0,0 +1,54 @@ +BiCopHinv <- function(u1, u2, family, par, par2 = 0, obj = NULL) { + ## sanity checks for u1, u2 + if (is.null(u1) == TRUE || is.null(u2) == TRUE) + stop("u1 and/or u2 are not set or have length zero.") + if (length(u1) != length(u2)) + stop("Lengths of 'u1' and 'u2' do not match.") + if (any(c(u1, u2) > 1) || any(c(u1, u2) < 0)) + stop("Data has be in the interval [0,1].") + + ## extract family and parameters if BiCop object is provided + if (missing(family)) + family <- NA + if (missing(par)) + par <- NA + # for short hand usage extract obj from family + if (class(family) == "BiCop") + obj <- family + if (!is.null(obj)) { + stopifnot(class(obj) == "BiCop") + family <- obj$family + par <- obj$par + par2 <- obj$par2 + } + + ## check for family/parameter consistency + BiCopCheck(family, par, par2) + + ## hinv(u2 | u1) + hinv1 <- .C("Hinv1", + as.integer(family), + as.integer(length(u2)), + as.double(u2), + as.double(u1), + as.double(par), + as.double(par2), + as.double(rep(0, length(u1))), + package = "VineCopula")[[7]] + + ## hinv(u2 | u1) + hinv2 <- .C("Hinv2", + as.integer(family), + as.integer(length(u2)), + as.double(u1), + as.double(u2), + as.double(par), + as.double(par2), + as.double(rep(0, length(u1))), + package = "VineCopula")[[7]] + + + ## return results + list(hinv1 = hinv1, hinv2 = hinv2) +} + Added: pkg/man/BiCopHinv.Rd =================================================================== --- pkg/man/BiCopHinv.Rd (rev 0) +++ pkg/man/BiCopHinv.Rd 2015-08-04 14:09:18 UTC (rev 110) @@ -0,0 +1,109 @@ +\name{BiCopHinv} +\alias{BiCopHinv} + +\title{Inverse Conditional Distribution Function of a Bivariate Copula} + +\description{ +This function evaluates the inverse conditional distribution function (inverse h-function) of a given parametric bivariate copula. +} + +\usage{ +BiCopHinv(u1, u2, family, par, par2 = 0, obj = NULL) +} + +\arguments{ + \item{u1, u2}{Numeric vectors of equal length with values in [0,1].} + \item{family}{An integer defining the bivariate copula family: \cr + \code{0} = independence copula \cr + \code{1} = Gaussian copula \cr + \code{2} = Student t copula (t-copula) \cr + \code{3} = Clayton copula \cr + \code{4} = Gumbel copula \cr + \code{5} = Frank copula \cr + \code{6} = Joe copula \cr + \code{7} = BB1 copula \cr + \code{8} = BB6 copula \cr + \code{9} = BB7 copula \cr + \code{10} = BB8 copula \cr + \code{13} = rotated Clayton copula (180 degrees; ``survival Clayton'') \cr + \code{14} = rotated Gumbel copula (180 degrees; ``survival Gumbel'') \cr + \code{16} = rotated Joe copula (180 degrees; ``survival Joe'') \cr + \code{17} = rotated BB1 copula (180 degrees; ``survival BB1'')\cr + \code{18} = rotated BB6 copula (180 degrees; ``survival BB6'')\cr + \code{19} = rotated BB7 copula (180 degrees; ``survival BB7'')\cr + \code{20} = rotated BB8 copula (180 degrees; ``survival BB8'')\cr + \code{23} = rotated Clayton copula (90 degrees) \cr + \code{24} = rotated Gumbel copula (90 degrees) \cr + \code{26} = rotated Joe copula (90 degrees) \cr + \code{27} = rotated BB1 copula (90 degrees) \cr + \code{28} = rotated BB6 copula (90 degrees) \cr + \code{29} = rotated BB7 copula (90 degrees) \cr + \code{30} = rotated BB8 copula (90 degrees) \cr + \code{33} = rotated Clayton copula (270 degrees) \cr + \code{34} = rotated Gumbel copula (270 degrees) \cr + \code{36} = rotated Joe copula (270 degrees) \cr + \code{37} = rotated BB1 copula (270 degrees) \cr + \code{38} = rotated BB6 copula (270 degrees) \cr + \code{39} = rotated BB7 copula (270 degrees) \cr + \code{40} = rotated BB8 copula (270 degrees) \cr + \code{104} = Tawn type 1 copula \cr + \code{114} = rotated Tawn type 1 copula (180 degrees) \cr + \code{124} = rotated Tawn type 1 copula (90 degrees) \cr + \code{134} = rotated Tawn type 1 copula (270 degrees) \cr + \code{204} = Tawn type 2 copula \cr + \code{214} = rotated Tawn type 2 copula (180 degrees) \cr + \code{224} = rotated Tawn type 2 copula (90 degrees) \cr + \code{234} = rotated Tawn type 2 copula (270 degrees) \cr + } + \item{par}{Copula parameter.} + \item{par2}{Second parameter for bivariate copulas with two parameters (t, BB1, BB6, BB7, BB8, Tawn type 1 and type 2; default: \code{par2 = 0}).} + \item{obj}{\code{BiCop} object containing the family and parameter specification.} + +} + +\details{ +The h-function is defined as the conditional distribution function of a bivariate copula, i.e., +\deqn{ +h(u|v,\boldsymbol{\theta}) := F(u|v) = +\frac{\partial C(u,v)}{\partial v}, +}{ +h(u|v,\theta) := F(u|v) = +\partial C(u,v) / \partial v, +} +where \eqn{C} is a bivariate copula distribution function with parameter(s) \eqn{\boldsymbol{\theta}}{\theta}. +For more details see Aas et al. (2009). +\cr \cr +If the family and parameter specification is stored in a \code{\link{BiCop}} object \code{obj}, the alternative version \cr +\preformatted{BiCopHinv(u1, u2, obj)} +can be used. +} + + +\value{ +\item{hinv1}{Numeric vector of the inverse conditional distribution function (h-function) evaluated at \code{u2} given \code{u1}, i.e., \eqn{h^{-1}(\code{u2}|\code{u1},\boldsymbol{\theta})}{h^{-1}(u2|u1,\theta)}.} +\item{hinv2}{Numeric vector of the inverse conditional distribution function (h-function) evaluated at \code{u1} given \code{u2}, i.e., \eqn{h^{-1}(\code{u1}|\code{u2},\boldsymbol{\theta})}{h^{-1}(u1|u2,\theta)}.} +} + +\references{ +Aas, K., C. Czado, A. Frigessi, and H. Bakken (2009). +Pair-copula constructions of multiple dependence. +Insurance: Mathematics and Economics 44 (2), 182-198. +} + +\author{Thomas Nagler} + +\seealso{\code{\link{BiCopPDF}}, \code{\link{BiCopCDF}}, \code{\link{RVineLogLik}}, \code{\link{RVineSeqEst}}, \code{\link{BiCop}}} + +\examples{ +# inverse h-functions of the Gaussian copula +cop <- BiCop(1, 0.5) +h1 <- BiCopHinv(0.1, 0.2, cop) +\dontshow{ +h1 +} +## check if it is actually the inverse +cop <- BiCop(3, 3) +all.equal(0.2, BiCopHfunc(0.1, BiCopHinv(0.1, 0.2, cop)$hinv1, cop)$hfunc1) +all.equal(0.1, BiCopHfunc(BiCopHinv(0.1, 0.2, cop)$hinv2, 0.2, cop)$hfunc2) + +} From noreply at r-forge.r-project.org Thu Aug 6 17:23:55 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 6 Aug 2015 17:23:55 +0200 (CEST) Subject: [Vinecopula-commits] r111 - in pkg: R src src/include Message-ID: <20150806152355.D17C9187A33@r-forge.r-project.org> Author: tnagler Date: 2015-08-06 17:23:55 +0200 (Thu, 06 Aug 2015) New Revision: 111 Modified: pkg/R/BiCopCDF.r pkg/R/BiCopCheck.R pkg/R/BiCopDeriv.r pkg/R/BiCopDeriv2.r pkg/R/BiCopHfunc.r pkg/R/BiCopHfuncDeriv.r pkg/R/BiCopHfuncDeriv2.r pkg/R/BiCopHinv.R pkg/R/BiCopPDF.r pkg/R/BiCopPar2Beta.r pkg/R/BiCopPar2TailDep.r pkg/R/BiCopPar2Tau.r pkg/R/BiCopSim.R pkg/R/BiCopTau2Par.r pkg/src/deriv.c pkg/src/deriv2.c pkg/src/hfunc.c pkg/src/hfuncderiv.c pkg/src/hfuncderiv2.c pkg/src/include/deriv.h pkg/src/include/deriv2.h pkg/src/include/hfunc.h pkg/src/include/likelihood.h pkg/src/include/logderiv.h pkg/src/include/tcopuladeriv.h pkg/src/include/tcopuladeriv_new.h pkg/src/likelihood.c pkg/src/logderiv.c pkg/src/tcopuladeriv.c pkg/src/tcopuladeriv_new.c Log: - correct call for non-t families in BiCopHfuncDeriv2.r(.., deriv ="par1u2")) - use C function "Hinv1" instead of "pcc" for BiCopSim - vectorize BiCop-functions w.r.t. family, par, par2: * in C: BiCopPDF, BiCopHfunc, BiCopHinv, BiCopDeriv, BiCopDeriv2, BiCopHfuncDeriv, BiCopHfuncDeriv2 * in R: BiCopCDF, BiCopPar2Tau, BiCopPar2Beta, BiCopPar2TailDep - add check.pars parameter to the above functions for the option to omit family/parameter consistency checks (for internal usage) Modified: pkg/R/BiCopCDF.r =================================================================== --- pkg/R/BiCopCDF.r 2015-08-04 14:09:18 UTC (rev 110) +++ pkg/R/BiCopCDF.r 2015-08-06 15:23:55 UTC (rev 111) @@ -1,13 +1,14 @@ -BiCopCDF <- function(u1, u2, family, par, par2 = 0, obj = NULL) { +BiCopCDF <- function(u1, u2, family, par, par2 = 0, obj = NULL, check.pars = TRUE) { ## sanity checks for u1, u2 - 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 (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.") + n <- length(u1) ## extract family and parameters if BiCop object is provided if (missing(family)) @@ -24,26 +25,52 @@ par2 <- obj$par2 } - ## sanity checks for family and parameters - if (is.na(family) | is.na(par)) + ## check for reasonable input + if (any(is.na(family)) | any(is.na(par))) stop("Provide either 'family' and 'par' or 'obj'") - if (family == 2) + if (any(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.") - BiCopCheck(family, par, par2) - res <- rep(NA, length(u1)) + ## adjust length for parameter vectors; stop if not matching + if (any(c(length(family), length(par), length(par2)) == n)) { + if (length(family) == 1) + family <- rep(family, n) + if (length(par) == 1) + par <- rep(par, n) + if (length(par2) == 1) + par2 <- rep(par2, n) + } + if (!(length(family) %in% c(1, n))) + stop("'family' has to be a single number or a size n vector") + if (!(length(par) %in% c(1, n))) + stop("'par' has to be a single number or a size n vector") + if (!(length(par2) %in% c(1, n))) + stop("'par2' has to be a single number or a size n vector") - ## CDFs for the different families + ## check for family/parameter consistency + if (check.pars) + BiCopCheck(family, par, par2) + + ## calculate CDF + if (length(par) == 1) { + # call for single parameters + out <- calcCDF(u1, u2, family, par, par2) + } else { + # vectorized call + out <- vapply(1:length(par), + function(i) calcCDF(u1[i], + u2[i], + family[i], + par[i], + par2[i]), + numeric(1)) + } + + ## return result + out +} + +calcCDF <- function(u1, u2, family, par, par2) { if (family == 0) { res <- u1 * u2 } else if (family == 1) { @@ -134,8 +161,11 @@ par3 <- par2 par2 <- 1 res <- u1 - C(u1, 1 - u2, -par, par2, par3) + } else { + ## CDFs for the different families + res <- rep(NA, length(u1)) } - } + } ## return results res Modified: pkg/R/BiCopCheck.R =================================================================== --- pkg/R/BiCopCheck.R 2015-08-04 14:09:18 UTC (rev 110) +++ pkg/R/BiCopCheck.R 2015-08-06 15:23:55 UTC (rev 111) @@ -1,106 +1,97 @@ -BiCopCheck <- function(family, par, par2 = 0, obj = NULL) { - ## extract family and parameters if BiCop object is provided - if (missing(family)) - family <- NA - if (missing(par)) - par <- NA - # for short hand usage extract obj from family - if (class(family) == "BiCop") - obj <- family - if (!is.null(obj)) { - stopifnot(class(obj) == "BiCop") - family <- obj$family - par <- obj$par - par2 <- obj$par2 - } - - ## sanity checks for family and parameters - if (is.na(family) | is.na(par)) - stop("Provide either 'family' and 'par' or 'obj'") - 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))) +BiCopCheck <- function(family, par, par2) { + ## check if all required parameters are set + if (!(all(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)))) 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) + if (any((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)) & (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) + if (length(par) < 1) stop("'par' not set.") + stopifnot(length(par) == length(par2)) - 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.") - 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 == 42) { - a <- par - b <- par2 - limA <- (b - 3 - sqrt(9 + 6 * b - 3 * b^2))/2 - if (abs(b) > 1) - stop("The second parameter of the two-parametric asymmetric copulas has to be in the interval [-1,1]") - if (a > 1 || a < limA) - stop("The first parameter of the two-parametric asymmetric copula has to be in the interval [limA(par2),1]") + ## check for family/parameter consistency + checkPars <- function(x) { + family <- x[1] + par <- x[2] + par2 <- x[3] + if ((family == 1 || family == 2) && abs(par) >= 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.") + 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 == 42) { + a <- par + b <- par2 + limA <- (b - 3 - sqrt(9 + 6 * b - 3 * b^2))/2 + if (abs(b) > 1) + stop("The second parameter of the two-parametric asymmetric copulas has to be in the interval [-1,1]") + if (a > 1 || a < limA) + stop("The first parameter of the two-parametric asymmetric copula has to be in the interval [limA(par2),1]") + } + 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].") } - 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].") + apply(cbind(family, par, par2), 1, checkPars) + ## return TRUE if all checks pass TRUE } \ No newline at end of file Modified: pkg/R/BiCopDeriv.r =================================================================== --- pkg/R/BiCopDeriv.r 2015-08-04 14:09:18 UTC (rev 110) +++ pkg/R/BiCopDeriv.r 2015-08-06 15:23:55 UTC (rev 111) @@ -1,4 +1,4 @@ -BiCopDeriv <- function(u1, u2, family, par, par2 = 0, deriv = "par", log = FALSE, obj = NULL) { +BiCopDeriv <- function(u1, u2, family, par, par2 = 0, deriv = "par", log = FALSE, obj = NULL, check.pars = TRUE) { ## sanity checks for u1, u2 if (is.null(u1) == TRUE || is.null(u2) == TRUE) stop("u1 and/or u2 are not set or have length zero.") @@ -8,6 +8,7 @@ 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].") + n <- length(u1) ## extract family and parameters if BiCop object is provided if (missing(family)) @@ -24,103 +25,191 @@ par2 <- obj$par2 } - ## sanity checks for family and parameters - if (is.na(family) | is.na(par)) + ## check for reasonable input + if (any(is.na(family)) | any(is.na(par))) stop("Provide either 'family' and 'par' or 'obj'") - if (!(family %in% c(0, 1, 2, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36))) + if (!all(family %in% c(0, 1, 2, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36))) stop("Copula family not implemented.") - if (family == 2 && par2 == 0) + if (any((family == 2) & (par2 == 0))) stop("For t-copulas, 'par2' must be set.") - if (family %in% c(1, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36) && length(par) < 1) - stop("'par' not set.") - if (deriv == "par2" && family != 2) + if ((deriv == "par2") && any(family != 2)) stop("The derivative with respect to the second parameter can only be derived for the t-copula.") - if (log == TRUE && (deriv %in% c("u1", "u2"))) - stop("The derivative with respect to one of the arguments are not available in the log case.") - BiCopCheck(family, par, par2) + if ((log == TRUE) && (deriv %in% c("u1", "u2"))) + stop("The derivative with respect to one of the arguments is not available in the log case.") + ## adjust length for parameter vectors; stop if not matching + if (any(c(length(family), length(par), length(par2)) == n)) { + if (length(family) == 1) + family <- rep(family, n) + if (length(par) == 1) + par <- rep(par, n) + if (length(par2) == 1) + par2 <- rep(par2, n) + } + if (!(length(family) %in% c(1, n))) + stop("'family' has to be a single number or a size n vector") + if (!(length(par) %in% c(1, n))) + stop("'par' has to be a single number or a size n vector") + if (!(length(par2) %in% c(1, n))) + stop("'par2' has to be a single number or a size n vector") + + ## check for family/parameter consistency + if (check.pars) + BiCopCheck(family, par, par2) + ## call C routines for specified 'deriv' case - n <- length(u1) - if (log == TRUE) { - if (deriv == "par") { - if (family == 2) { - out <- .C("difflPDF_rho_tCopula", + if (length(par) == 1) { + ## call for single parameters + if (log == TRUE) { + if (deriv == "par") { + if (family == 2) { + out <- .C("difflPDF_rho_tCopula", + as.double(u1), + as.double(u2), + as.integer(n), + as.double(c(par, par2)), + as.integer(2), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[6]] + } else { + out <- .C("difflPDF_mod", + as.double(u1), + as.double(u2), + as.integer(n), + as.double(par), + as.integer(family), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[6]] + } + } else if (deriv == "par2") { + out <- .C("difflPDF_nu_tCopula_new", + as.double(u1), + as.double(u2), + as.integer(n), + as.double(c(par, par2)), + as.integer(2), + as.double(rep(0, n)), PACKAGE = "VineCopula")[[6]] + } + } else { + if (deriv == "par") { + if (family == 2) { + out <- .C("diffPDF_rho_tCopula", + as.double(u1), + as.double(u2), + as.integer(n), + as.double(c(par, par2)), + as.integer(2), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[6]] + } else { + out <- .C("diffPDF_mod", + as.double(u1), + as.double(u2), + as.integer(n), + as.double(par), + as.integer(family), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[6]] + } + } else if (deriv == "par2") { + out <- .C("diffPDF_nu_tCopula_new", as.double(u1), as.double(u2), as.integer(n), as.double(c(par, par2)), - as.integer(2), - as.double(rep(0, n)), + as.integer(2), + as.double(rep(0, n)), PACKAGE = "VineCopula")[[6]] - } else { - out <- .C("difflPDF_mod", + } else if (deriv == "u1") { + out <- .C("diffPDF_u_mod", as.double(u1), as.double(u2), as.integer(n), - as.double(par), + as.double(c(par, par2)), as.integer(family), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[6]] + } else if (deriv == "u2") { + out <- .C("diffPDF_v_mod", + as.double(u1), + as.double(u2), + as.integer(n), + as.double(c(par, par2)), + as.integer(family), as.double(rep(0, n)), PACKAGE = "VineCopula")[[6]] + } else { + stop("This kind of derivative is not implemented") } - } else if (deriv == "par2") { - out <- .C("difflPDF_nu_tCopula_new", - as.double(u1), - as.double(u2), - as.integer(n), - as.double(c(par, par2)), - as.integer(2), - as.double(rep(0, n)), PACKAGE = "VineCopula")[[6]] } } else { - if (deriv == "par") { - if (family == 2) { - out <- .C("diffPDF_rho_tCopula", + ## vectorized call + if (log == TRUE) { + if (deriv == "par") { + out <- .C("difflPDF_mod_vec", as.double(u1), as.double(u2), - as.integer(n), - as.double(c(par, par2)), - as.integer(2), + as.integer(n), + as.double(par), + as.double(par2), + as.integer(family), as.double(rep(0, n)), - PACKAGE = "VineCopula")[[6]] - } else { - out <- .C("diffPDF_mod", + PACKAGE = "VineCopula")[[7]] + } else if (deriv == "par2") { + out <- .C("difflPDF_nu_tCopula_new_vec", as.double(u1), + as.double(u2), + as.integer(n), + as.double(par), + as.double(par2), + as.integer(2), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[7]] + } + } else { + if (deriv == "par") { + out <- .C("diffPDF_mod_vec", + as.double(u1), as.double(u2), as.integer(n), as.double(par), + as.double(par2), as.integer(family), as.double(rep(0, n)), - PACKAGE = "VineCopula")[[6]] + PACKAGE = "VineCopula")[[7]] + } else if (deriv == "par2") { + out <- .C("diffPDF_nu_tCopula_new_vec", + as.double(u1), + as.double(u2), + as.integer(n), + as.double(par), + as.double(par2), + as.integer(family), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[7]] + } else if (deriv == "u1") { + out <- .C("diffPDF_u_mod_vec", + as.double(u1), + as.double(u2), + as.integer(n), + as.double(par), + as.double(par2), + as.integer(family), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[7]] + } else if (deriv == "u2") { + out <- .C("diffPDF_v_mod_vec", + as.double(u1), + as.double(u2), + as.integer(n), + as.double(par), + as.double(par2), + as.integer(family), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[7]] + } else { + stop("This kind of derivative is not implemented") } - } else if (deriv == "par2") { - out <- .C("diffPDF_nu_tCopula_new", - as.double(u1), - as.double(u2), - as.integer(n), - as.double(c(par, par2)), - as.integer(2), - as.double(rep(0, n)), - PACKAGE = "VineCopula")[[6]] - } else if (deriv == "u1") { - out <- .C("diffPDF_u_mod", - as.double(u1), - as.double(u2), - as.integer(n), - as.double(c(par, par2)), - as.integer(family), - as.double(rep(0, n)), - PACKAGE = "VineCopula")[[6]] - } else if (deriv == "u2") { - out <- .C("diffPDF_v_mod", - as.double(u1), - as.double(u2), - as.integer(n), - as.double(c(par, par2)), - as.integer(family), - as.double(rep(0, n)), - PACKAGE = "VineCopula")[[6]] - } else { - stop("This kind of derivative is not implemented") } } Modified: pkg/R/BiCopDeriv2.r =================================================================== --- pkg/R/BiCopDeriv2.r 2015-08-04 14:09:18 UTC (rev 110) +++ pkg/R/BiCopDeriv2.r 2015-08-06 15:23:55 UTC (rev 111) @@ -1,4 +1,4 @@ -BiCopDeriv2 <- function(u1, u2, family, par, par2 = 0, deriv = "par", obj = NULL) { +BiCopDeriv2 <- function(u1, u2, family, par, par2 = 0, deriv = "par", obj = NULL, check.pars = TRUE) { ## sanity checks for u1, u2 if (is.null(u1) == TRUE || is.null(u2) == TRUE) stop("u1 and/or u2 are not set or have length zero.") @@ -8,6 +8,7 @@ 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].") + n <- length(u1) ## extract family and parameters if BiCop object is provided if (missing(family)) @@ -24,136 +25,253 @@ par2 <- obj$par2 } - ## sanity checks for family and parameters - if (is.na(family) | is.na(par)) + ## check for reasonable input + if (any(is.na(family)) | any(is.na(par))) stop("Provide either 'family' and 'par' or 'obj'") - if (!(family %in% c(0, 1, 2, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36))) + if (!all(family %in% c(0, 1, 2, 3, 4, 5, 6, 13, 14, 16, 23, 24, 26, 33, 34, 36))) stop("Copula family not implemented.") - if (family == 2 && par2 == 0) + if (any((family == 2) & (par2 == 0))) stop("For t-copulas, 'par2' must be set.") - if (deriv == "par2" && family != 2) + if ((deriv %in% c("par2", "par1par2", "par2u1", "par2u2")) && any(family != 2)) stop("The derivative with respect to the second parameter can only be derived for the t-copula.") - BiCopCheck(family, par, par2) - ## calculate derivatives - n <- length(u1) - if (deriv == "par") { - if (family == 2) { - out <- .C("diff2PDF_rho_tCopula", + ## adjust length for parameter vectors; stop if not matching + if (any(c(length(family), length(par), length(par2)) == n)) { + if (length(family) == 1) + family <- rep(family, n) + if (length(par) == 1) + par <- rep(par, n) + if (length(par2) == 1) + par2 <- rep(par2, n) + } + if (!(length(family) %in% c(1, n))) + stop("'family' has to be a single number or a size n vector") + if (!(length(par) %in% c(1, n))) + stop("'par' has to be a single number or a size n vector") + if (!(length(par2) %in% c(1, n))) + stop("'par2' has to be a single number or a size n vector") + + ## check for family/parameter consistency + if (check.pars) + BiCopCheck(family, par, par2) + + ## call C routines for specified 'deriv' case + if (length(par) == 1) { + ## call for single parameters + if (deriv == "par") { + if (family == 2) { + out <- .C("diff2PDF_rho_tCopula", + as.double(u1), + as.double(u2), + as.integer(n), + as.double(c(par, par2)), + as.integer(2), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[6]] + } else { + out <- .C("diff2PDF_mod", + as.double(u1), + as.double(u2), + as.integer(n), + as.double(par), + as.integer(family), + as.double(rep(0, n)), + PACKAGE = "VineCopula")[[6]] + } + } else if (deriv == "par2") { + out <- .C("diff2PDF_nu_tCopula_new", as.double(u1), - as.double(u2), + as.double(u2), as.integer(n), - as.double(c(par, par2)), + as.double(c(par, par2)), as.integer(2), as.double(rep(0, n)), PACKAGE = "VineCopula")[[6]] - } else { - out <- .C("diff2PDF_mod", + } else if (deriv == "u1") { [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vinecopula -r 111 From noreply at r-forge.r-project.org Thu Aug 6 20:06:25 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 6 Aug 2015 20:06:25 +0200 (CEST) Subject: [Vinecopula-commits] r112 - in pkg: R man Message-ID: <20150806180625.4A477187ABA@r-forge.r-project.org> Author: tnagler Date: 2015-08-06 20:06:24 +0200 (Thu, 06 Aug 2015) New Revision: 112 Modified: pkg/R/BiCopPar2Beta.r pkg/man/BiCopCDF.Rd pkg/man/BiCopDeriv.Rd pkg/man/BiCopDeriv2.Rd pkg/man/BiCopHfunc.Rd pkg/man/BiCopHfuncDeriv.Rd pkg/man/BiCopHfuncDeriv2.Rd pkg/man/BiCopHinv.Rd pkg/man/BiCopPDF.Rd pkg/man/BiCopPar2Beta.Rd pkg/man/BiCopPar2TailDep.Rd pkg/man/BiCopPar2Tau.Rd pkg/man/BiCopSim.Rd pkg/man/BiCopTau2Par.Rd Log: update manual files (see previous commit) Modified: pkg/R/BiCopPar2Beta.r =================================================================== --- pkg/R/BiCopPar2Beta.r 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/R/BiCopPar2Beta.r 2015-08-06 18:06:24 UTC (rev 112) @@ -1,4 +1,4 @@ -BiCopPar2Beta <- function(family, par, par2 = 0, obj = NULL) { +BiCopPar2Beta <- function(family, par, par2 = 0, obj = NULL, check.pars = TRUE) { ## extract family and parameters if BiCop object is provided if (missing(family)) family <- NA @@ -21,5 +21,11 @@ stop("Input lengths don't match") ## calculate beta - 4 * BiCopCDF(rep(0.5, n), rep(0.5, n), family, par, par2) - 1 + Cuv <- BiCopCDF(rep(0.5, n), + rep(0.5, n), + family, + par, + par2, + check.pars = check.pars) + 4 * Cuv - 1 } \ No newline at end of file Modified: pkg/man/BiCopCDF.Rd =================================================================== --- pkg/man/BiCopCDF.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopCDF.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,12 +8,12 @@ } \usage{ -BiCopCDF(u1, u2, family, par, par2 = 0, obj = NULL) +BiCopCDF(u1, u2, family, par, par2 = 0, obj = NULL, check.pars = TRUE) } \arguments{ - \item{u1,u2}{Numeric vectors of equal length with values in [0,1].} - \item{family}{An integer defining the bivariate copula family: \cr + \item{u1,u2}{numeric vectors of equal length with values in [0,1].} + \item{family}{integer; single number or vector of size \code{length(u1)}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{3} = Clayton copula \cr @@ -54,14 +54,20 @@ \code{224} = rotated Tawn type 2 copula (90 degrees) \cr \code{234} = rotated Tawn type 2 copula (270 degrees) \cr } - \item{par}{Copula parameter.} - \item{par2}{Second parameter for bivariate copulas with two parameters (t, BB1, BB6, BB7, BB8, Tawn type 1 and type 2; default: \code{par2 = 0}). \code{par2} should be an positive integer for the Students's t copula \code{family = 2}.} + \item{par}{numeric; single number or vector of size \code{length(u1)}; copula parameter.} + \item{par2}{numeric; single number or vector of size \code{length(u1)}; second parameter for bivariate copulas with two parameters (BB1, BB6, BB7, BB8, Tawn type 1 and type 2; default: \code{par2 = 0}).} \item{obj}{\code{BiCop} object containing the family and parameter specification.} + \item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} } \value{ -A numeric vector of the bivariate copula distribution function evaluated at \code{u1} and \code{u2}. +A numeric vector of the bivariate copula distribution function +\itemize{ + \item{of the copula \code{family}} + \item{with parameter(s) \code{par}, \code{par2}} + \item{evaluated at \code{u1} and \code{u2}.} } +} \details{ If the family and parameter specification is stored in a \code{\link{BiCop}} object \code{obj}, the alternative version \cr Modified: pkg/man/BiCopDeriv.Rd =================================================================== --- pkg/man/BiCopDeriv.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopDeriv.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,12 +8,13 @@ } \usage{ -BiCopDeriv(u1, u2, family, par, par2 = 0, deriv = "par", log = FALSE, obj = NULL) +BiCopDeriv(u1, u2, family, par, par2 = 0, deriv = "par", + log = FALSE, obj = NULL, check.pars = TRUE) } \arguments{ - \item{u1,u2}{Numeric vectors of equal length with values in [0,1].} - \item{family}{An integer defining the bivariate copula family: \cr + \item{u1,u2}{numeric vectors of equal length with values in [0,1].} + \item{family}{integer; single number or vector of size \code{length(u1)}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{2} = Student t copula (t-copula) \cr @@ -31,8 +32,8 @@ \code{34} = rotated Gumbel copula (270 degrees) \cr \code{36} = rotated Joe copula (270 degrees) \cr } - \item{par}{Copula parameter.} - \item{par2}{Second parameter for bivariate t-copula; default: \code{par2 = 0}.} + \item{par}{numeric; single number or vector of size \code{length(u1)}; copula parameter.} + \item{par2}{integer; single number or vector of size \code{length(u1)}; second parameter for the t-Copula; default is \code{par2 = 0}, should be an positive integer for the Students's t copula \code{family = 2}.} \item{deriv}{Derivative argument \cr \code{"par"} = derivative with respect to the first parameter (default)\cr \code{"par2"} = derivative with respect to the second parameter (only available for the t-copula) \cr @@ -42,11 +43,18 @@ \item{log}{Logical; if \code{TRUE} than the derivative of the log-likelihood is returned (default: \code{log = FALSE}; only available for the derivatives with respect to the parameter(s) (\code{deriv = "par"} or \code{deriv = "par2"})).} \item{obj}{\code{BiCop} object containing the family and parameter specification.} + \item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} } \value{ -A numeric vector of the bivariate copula derivative with respect to \code{deriv} evaluated at \code{u1} and \code{u2} with parameter(s) \code{par} and \code{par2}. +A numeric vector of the bivariate copula derivative +\itemize{ + \item{of the copula \code{family}} + \item{with parameter(s) \code{par}, \code{par2}} + \item{with respect to \code{deriv}} + \item{evaluated at \code{u1} and \code{u2}.} } +} \details{ If the family and parameter specification is stored in a \code{\link{BiCop}} object \code{obj}, the alternative version \cr Modified: pkg/man/BiCopDeriv2.Rd =================================================================== --- pkg/man/BiCopDeriv2.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopDeriv2.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,12 +8,12 @@ } \usage{ -BiCopDeriv2(u1, u2, family, par, par2 = 0, deriv = "par", obj = NULL) +BiCopDeriv2(u1, u2, family, par, par2 = 0, deriv = "par", obj = NULL, check.pars = TRUE) } \arguments{ - \item{u1,u2}{Numeric vectors of equal length with values in [0,1].} - \item{family}{An integer defining the bivariate copula family: \cr + \item{u1,u2}{numeric vectors of equal length with values in [0,1].} + \item{family}{integer; single number or vector of size \code{length(u1)}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{2} = Student t copula (t-copula) \cr @@ -32,7 +32,7 @@ \code{36} = rotated Joe copula (270 degrees) \cr } \item{par}{Copula parameter.} - \item{par2}{Second parameter for bivariate t-copula; default: \code{par2 = 0}.} + \item{par2}{integer; single number or vector of size \code{length(u1)}; second parameter for the t-Copula; default is \code{par2 = 0}, should be an positive integer for the Students's t copula \code{family = 2}.} \item{deriv}{Derivative argument \cr \code{"par"} = second derivative with respect to the first parameter (default)\cr \code{"par2"} = second derivative with respect to the second parameter (only available for the t-copula) \cr @@ -45,11 +45,19 @@ \code{"par2u2"} = second derivative with respect to the second parameter and the second argument (only available for the t-copula) \cr } \item{obj}{\code{BiCop} object containing the family and parameter specification.} + \item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} + } \value{ -A numeric vector of the second bivariate copula derivative with respect to \code{deriv} evaluated at \code{u1} and \code{u2} with parameter(s) \code{par} and \code{par2}. +A numeric vector of the second-order bivariate copula derivative +\itemize{ + \item{of the copula \code{family}} + \item{with parameter(s) \code{par}, \code{par2}} + \item{with respect to \code{deriv}} + \item{evaluated at \code{u1} and \code{u2}.} } +} \details{ Modified: pkg/man/BiCopHfunc.Rd =================================================================== --- pkg/man/BiCopHfunc.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopHfunc.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,12 +8,12 @@ } \usage{ -BiCopHfunc(u1, u2, family, par, par2 = 0, obj = NULL) +BiCopHfunc(u1, u2, family, par, par2 = 0, obj = NULL, check.pars = TRUE) } \arguments{ - \item{u1, u2}{Numeric vectors of equal length with values in [0,1].} - \item{family}{An integer defining the bivariate copula family: \cr + \item{u1,u2}{numeric vectors of equal length with values in [0,1].} + \item{family}{integer; single number or vector of size \code{length(u1)}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{2} = Student t copula (t-copula) \cr @@ -55,10 +55,10 @@ \code{224} = rotated Tawn type 2 copula (90 degrees) \cr \code{234} = rotated Tawn type 2 copula (270 degrees) \cr } - \item{par}{Copula parameter.} - \item{par2}{Second parameter for bivariate copulas with two parameters (t, BB1, BB6, BB7, BB8, Tawn type 1 and type 2; default: \code{par2 = 0}).} + \item{par}{numeric; single number or vector of size \code{length(u1)}; copula parameter.} + \item{par2}{numeric; single number or vector of size \code{length(u1)}; second parameter for bivariate copulas with two parameters (t, BB1, BB6, BB7, BB8, Tawn type 1 and type 2; default: \code{par2 = 0}). \code{par2} should be an positive integer for the Students's t copula \code{family = 2}.} \item{obj}{\code{BiCop} object containing the family and parameter specification.} - +\item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} } \details{ @@ -71,8 +71,8 @@ \partial C(u,v) / \partial v, } where \eqn{C} is a bivariate copula distribution function with parameter(s) \eqn{\boldsymbol{\theta}}{\theta}. -For more details see Aas et al. (2009). -\cr \cr +For more details see Aas et al. (2009). \cr \cr + If the family and parameter specification is stored in a \code{\link{BiCop}} object \code{obj}, the alternative version \cr \preformatted{BiCopHfunc(u1, u2, obj)} can be used. @@ -80,8 +80,8 @@ \value{ -\item{hfunc1}{Numeric vector of the conditional distribution function (h-function) evaluated at \code{u2} given \code{u1}, i.e., \eqn{h(\code{u2}|\code{u1},\boldsymbol{\theta})}{h(u2|u1,\theta)}.} -\item{hfunc2}{Numeric vector of the conditional distribution function (h-function) evaluated at \code{u1} given \code{u2}, i.e., \eqn{h(\code{u1}|\code{u2},\boldsymbol{\theta})}{h(u1|u2,\theta)}.} +\item{hfunc1}{Numeric vector of the conditional distribution function (h-function) of the copula \code{family} with parameter(s) \code{par}, \code{par2} evaluated at \code{u2} given \code{u1}, i.e., \eqn{h(\code{u2}|\code{u1},\boldsymbol{\theta})}{h(u2|u1,\theta)}.} +\item{hfunc2}{Numeric vector of the conditional distribution function (h-function) of the copula \code{family} with parameter(s) \code{par}, \code{par2} evaluated at \code{u1} given \code{u2}, i.e., \eqn{h(\code{u1}|\code{u2},\boldsymbol{\theta})}{h(u1|u2,\theta)}.} } \references{ Modified: pkg/man/BiCopHfuncDeriv.Rd =================================================================== --- pkg/man/BiCopHfuncDeriv.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopHfuncDeriv.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,12 +8,13 @@ } \usage{ -BiCopHfuncDeriv(u1, u2, family, par, par2 = 0, deriv = "par", obj = NULL) +BiCopHfuncDeriv(u1, u2, family, par, par2 = 0, deriv = "par", + obj = NULL, check.pars = TRUE) } \arguments{ - \item{u1, u2}{Numeric vectors of equal length with values in [0,1].} - \item{family}{An integer defining the bivariate copula family: \cr + \item{u1,u2}{numeric vectors of equal length with values in [0,1].} + \item{family}{integer; single number or vector of size \code{length(u1)}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{2} = Student t copula (t-copula) \cr @@ -31,19 +32,26 @@ \code{34} = rotated Gumbel copula (270 degrees) \cr \code{36} = rotated Joe copula (270 degrees) \cr } - \item{par}{Copula parameter.} - \item{par2}{Second parameter for bivariate t-copula; default: \code{par2 = 0}.} + \item{par}{numeric; single number or vector of size \code{length(u1)}; copula parameter.} + \item{par2}{integer; single number or vector of size \code{length(u1)}; second parameter for the t-Copula; default is \code{par2 = 0}, should be an positive integer for the Students's t copula \code{family = 2}.} \item{deriv}{Derivative argument \cr \code{"par"} = derivative with respect to the first parameter (default)\cr \code{"par2"} = derivative with respect to the second parameter (only available for the t-copula) \cr \code{"u2"} = derivative with respect to the second argument \code{u2} \cr } \item{obj}{\code{BiCop} object containing the family and parameter specification.} + \item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} } \value{ -A numeric vector of the conditional bivariate copula derivative with respect to \code{deriv} evaluated at \code{u1} and \code{u2} with parameter(s) \code{par} and \code{par2}. +A numeric vector of the conditional bivariate copula derivative +\itemize{ + \item{of the copula \code{family}} + \item{with parameter(s) \code{par}, \code{par2}} + \item{with respect to \code{deriv}} + \item{evaluated at \code{u1} and \code{u2}.} } +} \details{ If the family and parameter specification is stored in a \code{\link{BiCop}} object \code{obj}, the alternative version \cr Modified: pkg/man/BiCopHfuncDeriv2.Rd =================================================================== --- pkg/man/BiCopHfuncDeriv2.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopHfuncDeriv2.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,12 +8,13 @@ } \usage{ -BiCopHfuncDeriv2(u1, u2, family, par, par2 = 0, deriv = "par", obj = NULL) +BiCopHfuncDeriv2(u1, u2, family, par, par2 = 0, deriv = "par", + obj = NULL, check.pars = TRUE) } \arguments{ - \item{u1, u2}{Numeric vectors of equal length with values in [0,1].} - \item{family}{An integer defining the bivariate copula family: \cr + \item{u1,u2}{numeric vectors of equal length with values in [0,1].} + \item{family}{integer; single number or vector of size \code{length(u1)}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{2} = Student t copula (t-copula) \cr @@ -31,8 +32,8 @@ \code{34} = rotated Gumbel copula (270 degrees) \cr \code{36} = rotated Joe copula (270 degrees) \cr } - \item{par}{Copula parameter.} - \item{par2}{Second parameter for bivariate t-copula; default: \code{par2 = 0}.} + \item{par}{numeric; single number or vector of size \code{length(u1)}; copula parameter.} + \item{par2}{integer; single number or vector of size \code{length(u1)}; second parameter for the t-Copula; default is \code{par2 = 0}, should be an positive integer for the Students's t copula \code{family = 2}.} \item{deriv}{Derivative argument \cr \code{"par"} = second derivative with respect to the first parameter (default)\cr \code{"par2"} = second derivative with respect to the second parameter (only available for the t-copula) \cr @@ -42,11 +43,19 @@ \code{"par2u2"} = second derivative with respect to the second parameter and the second argument (only available for the t-copula) \cr } \item{obj}{\code{BiCop} object containing the family and parameter specification.} + \item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} + } \value{ -A numeric vector of the second conditional bivariate copula derivative with respect to \code{deriv} evaluated at \code{u1} and \code{u2} with parameter(s) \code{par} and \code{par2}. +A numeric vector of the second-order conditional bivariate copula derivative +\itemize{ + \item{of the copula \code{family}} + \item{with parameter(s) \code{par}, \code{par2}} + \item{with respect to \code{deriv}} + \item{evaluated at \code{u1} and \code{u2}.} } +} \details{ If the family and parameter specification is stored in a \code{\link{BiCop}} object \code{obj}, the alternative version \cr Modified: pkg/man/BiCopHinv.Rd =================================================================== --- pkg/man/BiCopHinv.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopHinv.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,12 +8,12 @@ } \usage{ -BiCopHinv(u1, u2, family, par, par2 = 0, obj = NULL) +BiCopHinv(u1, u2, family, par, par2 = 0, obj = NULL, check.pars = TRUE) } \arguments{ - \item{u1, u2}{Numeric vectors of equal length with values in [0,1].} - \item{family}{An integer defining the bivariate copula family: \cr + \item{u1,u2}{numeric vectors of equal length with values in [0,1].} + \item{family}{integer; single number or vector of size \code{length(u1)}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{2} = Student t copula (t-copula) \cr @@ -55,10 +55,10 @@ \code{224} = rotated Tawn type 2 copula (90 degrees) \cr \code{234} = rotated Tawn type 2 copula (270 degrees) \cr } - \item{par}{Copula parameter.} - \item{par2}{Second parameter for bivariate copulas with two parameters (t, BB1, BB6, BB7, BB8, Tawn type 1 and type 2; default: \code{par2 = 0}).} + \item{par}{numeric; single number or vector of size \code{length(u1)}; copula parameter.} + \item{par2}{numeric; single number or vector of size \code{length(u1)}; second parameter for bivariate copulas with two parameters (t, BB1, BB6, BB7, BB8, Tawn type 1 and type 2; default: \code{par2 = 0}). \code{par2} should be an positive integer for the Students's t copula \code{family = 2}.} \item{obj}{\code{BiCop} object containing the family and parameter specification.} - + \item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} } \details{ @@ -73,6 +73,7 @@ where \eqn{C} is a bivariate copula distribution function with parameter(s) \eqn{\boldsymbol{\theta}}{\theta}. For more details see Aas et al. (2009). \cr \cr + If the family and parameter specification is stored in a \code{\link{BiCop}} object \code{obj}, the alternative version \cr \preformatted{BiCopHinv(u1, u2, obj)} can be used. @@ -80,8 +81,8 @@ \value{ -\item{hinv1}{Numeric vector of the inverse conditional distribution function (h-function) evaluated at \code{u2} given \code{u1}, i.e., \eqn{h^{-1}(\code{u2}|\code{u1},\boldsymbol{\theta})}{h^{-1}(u2|u1,\theta)}.} -\item{hinv2}{Numeric vector of the inverse conditional distribution function (h-function) evaluated at \code{u1} given \code{u2}, i.e., \eqn{h^{-1}(\code{u1}|\code{u2},\boldsymbol{\theta})}{h^{-1}(u1|u2,\theta)}.} +\item{hinv1}{Numeric vector of the inverse conditional distribution function (inverse h-function) of the copula \code{family} with parameter(s) \code{par}, \code{par2} evaluated at \code{u2} given \code{u1}, i.e., \eqn{h^{-1}(\code{u2}|\code{u1},\boldsymbol{\theta})}{h^{-1}(u2|u1,\theta)}.} +\item{hinv2}{Numeric vector of the inverse conditional distribution function (inverse h-function) of the copula \code{family} with parameter(s) \code{par}, \code{par2}evaluated at \code{u1} given \code{u2}, i.e., \eqn{h^{-1}(\code{u1}|\code{u2},\boldsymbol{\theta})}{h^{-1}(u1|u2,\theta)}.} } \references{ Modified: pkg/man/BiCopPDF.Rd =================================================================== --- pkg/man/BiCopPDF.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopPDF.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,12 +8,12 @@ } \usage{ -BiCopPDF(u1, u2, family, par, par2 = 0, obj = NULL) +BiCopPDF(u1, u2, family, par, par2 = 0, obj = NULL, check.pars = TRUE) } \arguments{ - \item{u1, u2}{Numeric vectors of equal length with values in [0,1].} - \item{family}{An integer defining the bivariate copula family: \cr + \item{u1,u2}{numeric vectors of equal length with values in [0,1].} + \item{family}{integer; single number or vector of size \code{length(u1)}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{2} = Student t copula (t-copula) \cr @@ -21,7 +21,7 @@ \code{4} = Gumbel copula \cr \code{5} = Frank copula \cr \code{6} = Joe copula \cr - \code{7} = BB1 copula \cr + \code{7} = BB1 copula \cr/ \code{8} = BB6 copula \cr \code{9} = BB7 copula \cr \code{10} = BB8 copula \cr @@ -55,14 +55,20 @@ \code{224} = rotated Tawn type 2 copula (90 degrees) \cr \code{234} = rotated Tawn type 2 copula (270 degrees) \cr } - \item{par}{Copula parameter.} - \item{par2}{Second parameter for the two parameter t-, BB1, BB6, BB7, BB8, Tawn type 1 and type 2 copulas (default: \code{par2 = 0}).} + \item{par}{numeric; single number or vector of size \code{length(u1)}; copula parameter.} + \item{par2}{numeric; single number or vector of size \code{length(u1)}; second parameter for bivariate copulas with two parameters (t, BB1, BB6, BB7, BB8, Tawn type 1 and type 2; default: \code{par2 = 0}). \code{par2} should be an positive integer for the Students's t copula \code{family = 2}.} \item{obj}{\code{BiCop} object containing the family and parameter specification.} +\item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} } \value{ -A numeric vector of the bivariate copula density evaluated at \code{u1} and \code{u2}. +A numeric vector of the bivariate copula density +\itemize{ + \item{of the copula \code{family}} + \item{with parameter(s) \code{par}, \code{par2}} + \item{evaluated at \code{u1} and \code{u2}.} } +} \details{ If the family and parameter specification is stored in a \code{\link{BiCop}} object \code{obj}, the alternative version \cr Modified: pkg/man/BiCopPar2Beta.Rd =================================================================== --- pkg/man/BiCopPar2Beta.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopPar2Beta.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,11 +8,11 @@ } \usage{ -BiCopPar2Beta(family, par, par2 = 0, obj = NULL) +BiCopPar2Beta(family, par, par2 = 0, obj = NULL, check.pars = TRUE) } \arguments{ - \item{family}{An integer defining the bivariate copula family:\cr + \item{family}{integer; single number or vector of size \code{m}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{3} = Clayton copula \cr @@ -54,14 +54,15 @@ \code{234} = rotated Tawn type 2 copula (270 degrees) \cr Note that the Student's t-copula is not allowed since the CDF of the t-copula is not implemented (see \code{\link{BiCopCDF}}). } - \item{par}{Copula parameter.} - \item{par2}{Second parameter for the two parameter BB1, BB6, BB7, BB8, Tawn type 1 and type 2 copulas (default: \code{par2 = 0}).} + \item{par}{numeric; single number or vector of size \code{m}; copula parameter.} + \item{par2}{numeric; single number or vector of size \code{m}; second parameter for the two parameter BB1, BB6, BB7, BB8, Tawn type 1 and type 2 copulas (default: \code{par2 = 0}).} \item{obj}{\code{BiCop} object containing the family and parameter specification.} + \item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} } \value{ -Theoretical value of Blomqvist's beta corresponding to the bivariate copula family and parameter(s) +Theoretical value of Blomqvist's beta corresponding to the bivariate copula \code{family} and parameter(s) \code{par}, \code{par2}. } \details{ @@ -70,6 +71,10 @@ can be used. } +\note{ +The number \code{m} can be chosen arbitrarily. +} + \author{Ulf Schepsmeier} \references{ Modified: pkg/man/BiCopPar2TailDep.Rd =================================================================== --- pkg/man/BiCopPar2TailDep.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopPar2TailDep.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,11 +8,11 @@ } \usage{ -BiCopPar2TailDep(family, par, par2 = 0, obj = NULL) +BiCopPar2TailDep(family, par, par2 = 0, obj = NULL, check.pars = TRUE) } \arguments{ - \item{family}{An integer defining the bivariate copula family:\cr + \item{family}{integer; single number or vector of size \code{m}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{2} = Student t copula (t-copula) \cr @@ -54,20 +54,22 @@ \code{224} = rotated Tawn type 2 copula (90 degrees) \cr \code{234} = rotated Tawn type 2 copula (270 degrees) \cr } - \item{par}{Copula parameter.} - \item{par2}{Second parameter for the two parameter t-, BB1, BB6, BB7, BB8, Tawn type 1 and type 2 copulas (default: \code{par2 = 0}).} + \item{par}{numeric; single number or vector of size \code{m}; copula parameter.} + \item{par2}{numeric; single number or vector of size \code{m}; second parameter for bivariate copulas with two parameters (t, BB1, BB6, BB7, BB8, Tawn type 1 and type 2; default: \code{par2 = 0}). \code{par2} should be an positive integer for the Students's t copula \code{family = 2}.} \item{obj}{\code{BiCop} object containing the family and parameter specification.} + \item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} + } \value{ - \item{lower}{Lower tail dependence coefficient of the given bivariate copula family \eqn{C}: + \item{lower}{Lower tail dependence coefficient for the given bivariate copula \code{family} and parameter(s) \code{par}, \code{par2}: \deqn{ \lambda_L = \lim_{u\searrow 0}\frac{C(u,u)}{u} }{ \lambda_L = lim_{u->0} C(u,u)/u } } - \item{upper}{Upper tail dependence coefficient of the given bivariate copula family \eqn{C}: + \item{upper}{Upper tail dependence coefficient for the given bivariate copula family \code{family} and parameter(s) \code{par}, \code{par2}: \deqn{ \lambda_U = \lim_{u\nearrow 1}\frac{1-2u+C(u,u)}{1-u} }{ @@ -117,6 +119,10 @@ } +\note{ +The number \code{m} can be chosen arbitrarily. +} + \author{Eike Brechmann} \references{ Modified: pkg/man/BiCopPar2Tau.Rd =================================================================== --- pkg/man/BiCopPar2Tau.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopPar2Tau.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,11 +8,11 @@ } \usage{ -BiCopPar2Tau(family, par, par2 = 0, obj = NULL) +BiCopPar2Tau(family, par, par2 = 0, obj = NULL, check.pars = TRUE) } \arguments{ - \item{family}{An integer defining the bivariate copula family:\cr + \item{family}{integer; single number or vector of size \code{m}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{2} = Student t copula (t-copula) \cr @@ -54,11 +54,12 @@ \code{224} = rotated Tawn type 2 copula (90 degrees) \cr \code{234} = rotated Tawn type 2 copula (270 degrees) \cr } - \item{par}{Copula parameter (vector).} - \item{par2}{Second parameter (vector of same length as \code{par}) for the two parameter t-, BB1, BB6, BB7, BB8, Tawn type 1 and type 2 copulas (default: \code{par2 = 0}). + \item{par}{numeric; single number or vector of size \code{m}; copula parameter.} + \item{par2}{numeric; single number or vector of size \code{m}; second parameter for bivariate copulas with two parameters (t, BB1, BB6, BB7, BB8, Tawn type 1 and type 2; default: \code{par2 = 0}). Note that the degrees of freedom parameter of the t-copula does not need to be set, because the theoretical Kendall's tau value of the t-copula is independent of this choice.} \item{obj}{\code{BiCop} object containing the family and parameter specification.} + \item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} } \details{ @@ -67,10 +68,12 @@ can be used. } +\note{ +The number \code{m} can be chosen arbitrarily. +} + \value{ -Theoretical value of Kendall's tau (vector) corresponding to the bivariate copula family and parameter(vectors) -(\eqn{\theta} for one parameter families and the first parameter of the t-copula, -\eqn{\theta} and \eqn{\delta} for the two parameter BB1, BB6, BB7, BB8, Tawn type 1 and type 2 copulas). +Theoretical value of Kendall's tau (vector) corresponding to the bivariate copula \code{family} and parameter vector \eqn{(\theta, \delta) =} \code{(par, par2)}. \tabular{ll}{ No. (\code{family}) \tab Kendall's tau (\code{tau}) \cr \code{1, 2} \tab \eqn{\frac{2}{\pi}\arcsin(\theta)}{2 / \pi arcsin(\theta)} \cr Modified: pkg/man/BiCopSim.Rd =================================================================== --- pkg/man/BiCopSim.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopSim.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -8,12 +8,12 @@ } \usage{ -BiCopSim(N, family, par, par2 = 0, obj = NULL) +BiCopSim(N, family, par, par2 = 0, obj = NULL, check.pars = TRUE) } \arguments{ \item{N}{Number of bivariate observations simulated.} - \item{family}{An integer defining the bivariate copula family: \cr + \item{family}{integer; single number or vector of size \code{N}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{2} = Student t copula (t-copula) \cr @@ -55,13 +55,14 @@ \code{224} = rotated Tawn type 2 copula (90 degrees) \cr \code{234} = rotated Tawn type 2 copula (270 degrees) \cr } - \item{par}{Copula parameter.} - \item{par2}{Second parameter for the two parameter BB1, BB6, BB7, BB8, Tawn type 1 and type 2 copulas (default: \code{par2 = 0}).} + \item{par}{numeric; single number or vector of size \code{N}; copula parameter.} + \item{par2}{numeric; single number or vector of size \code{N}; second parameter for bivariate copulas with two parameters (t, BB1, BB6, BB7, BB8, Tawn type 1 and type 2; default: \code{par2 = 0}). \code{par2} should be an positive integer for the Students's t copula \code{family = 2}.} \item{obj}{\code{BiCop} object containing the family and parameter specification.} +\item{check.pars}{logical; default is \code{TRUE}; if \code{FALSE}, checks for family/parameter-consistency are ommited (should only be used with care).} } \value{ -An \code{N} x 2 matrix of data simulated from the bivariate copula. +An \code{N} x 2 matrix of data simulated from the bivariate copula with \code{family} and parameter(s) \code{par}, \code{par2}. } \details{ Modified: pkg/man/BiCopTau2Par.Rd =================================================================== --- pkg/man/BiCopTau2Par.Rd 2015-08-06 15:23:55 UTC (rev 111) +++ pkg/man/BiCopTau2Par.Rd 2015-08-06 18:06:24 UTC (rev 112) @@ -12,7 +12,7 @@ } \arguments{ - \item{family}{An integer defining the bivariate copula family:\cr + \item{family}{integer; single number or vector of size \code{m}; defines the bivariate copula family: \cr \code{0} = independence copula \cr \code{1} = Gaussian copula \cr \code{2} = Student t copula (Here only the first parameter can be computed) \cr @@ -30,7 +30,7 @@ \code{34} = rotated Gumbel copula (270 degrees) \cr \code{36} = rotated Joe copula (270 degrees)\cr Note that (with exception of the t-copula) two parameter bivariate copula families cannot be used.} - \item{tau}{Kendall's tau value (vector with elements in [-1,1]).} + \item{tau}{numeric; single number or vector of size \code{m}; Kendall's tau value (vector with elements in [-1,1]).} } \value{ From noreply at r-forge.r-project.org Thu Aug 6 20:44:36 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 6 Aug 2015 20:44:36 +0200 (CEST) Subject: [Vinecopula-commits] r113 - pkg/R Message-ID: <20150806184436.3E085184BDE@r-forge.r-project.org> Author: tnagler Date: 2015-08-06 20:44:35 +0200 (Thu, 06 Aug 2015) New Revision: 113 Modified: pkg/R/BiCopEst.r pkg/R/BiCopSelect.r Log: set check.pars option in BiCopEst, BiCopSelect Modified: pkg/R/BiCopEst.r =================================================================== --- pkg/R/BiCopEst.r 2015-08-06 18:06:24 UTC (rev 112) +++ pkg/R/BiCopEst.r 2015-08-06 18:44:35 UTC (rev 113) @@ -1,989 +1,993 @@ -BiCopEst <- function(u1, u2, family, method = "mle", se = FALSE, max.df = 30, max.BB = list(BB1 = c(5, 6), BB6 = c(6, 6), BB7 = c(5, 6), BB8 = c(6, 1)), - weights = NA) { - # Function that estimates the parameter(s) of the bivatiate copula - #--------------------------------------------------------- - # INPUT: - # u1,u2 Data for which to estimate parameter - # family The array definig the copulas in the pcc copula construction - # OUTPUT: - # theta Estimated Parameters - #---------------------------------------------------------- - # Author: Carlos Almeida - # Update: Ulf Schepsmeier - # Date: 2008-12-08 - # Update date: 2011-05-27 - # Version: 1.1 - #--------------------------------------------------------------- - - # sanity checks - if (is.null(u1) == TRUE || is.null(u2) == TRUE) - stop("u1 and/or u2 are not set or have length zero.") - if (length(u1) != length(u2)) - stop("Lengths of 'u1' and 'u2' do not match.") - if (length(u1) < 2) - stop("Number of observations has to be at least 2.") - 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 (!(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, 51, 61, 71, 104, 114, 124, 134, 204, 214, 224, 234))) - stop("Copula family not implemented.") - - if (max.df <= 2) - stop("The upper bound for the degrees of freedom parameter has to be larger than 2.") - if (!is.list(max.BB)) - stop("'max.BB' has to be a list.") - if (max.BB$BB1[1] < 0.001) - stop("The upper bound for the first parameter of the BB1 copula should be greater than 0.001 (lower bound for estimation).") - if (max.BB$BB1[2] < 1.001) - stop("The upper bound for the second parameter of the BB1 copula should be greater than 1.001 (lower bound for estimation).") - if (max.BB$BB6[1] < 1.001) - stop("The upper bound for the first parameter of the BB6 copula should be greater than 1.001 (lower bound for estimation).") - if (max.BB$BB6[2] < 1.001) - stop("The upper bound for the second parameter of the BB6 copula should be greater than 1.001 (lower bound for estimation).") - if (max.BB$BB7[1] < 1.001) - stop("The upper bound for the first parameter of the BB7 copula should be greater than 1.001 (lower bound for estimation).") - if (max.BB$BB7[2] < 0.001) - stop("The upper bound for the second parameter of the BB7 copula should be greater than 0.001 (lower bound for estimation).") - if (max.BB$BB8[1] < 1.001) - stop("The upper bound for the first parameter of the BB1 copula should be greater than 0.001 (lower bound for estimation).") - if (max.BB$BB8[2] < 0.001 || max.BB$BB8[2] > 1) - stop("The upper bound for the second parameter of the BB1 copula should be in the interval [0,1].") - - if (method != "mle" && method != "itau") - stop("Estimation method has to be either 'mle' or 'itau'.") - if (method == "itau" && family %in% c(2, 7, 8, 9, 10, 17, 18, 19, 20, 27, 28, 29, 30, 37, 38, 39, 40, 104, 114, 124, 134, 204, 214, 224, 234)) { - message("For two parameter copulas the estimation method 'itau' cannot be used. The method is automatically set to 'mle'.") - method <- "mle" - } - if (is.logical(se) == FALSE) - stop("'se' has to be a logical variable (TRUE or FALSE).") - - - ## calculate empirical kendall's tau - if (family != 0) { - # tau <- cor(u1,u2,method='kendall') - tau <- fasttau(u1, u2) - } - - ## inversion of kendall's tau - theta <- 0 - if (family == 0) { - # independent - theta <- 0 - } else if (family == 1) { - ## Gaussian - theta <- sin(tau * pi/2) - } else if (family == 3 || family == 13) { - ## Clayton - if (tau <= 0) { - warning("Clayton copula cannot be used for negatively dependent data.") - tau <- 0.05 - } - theta <- max(0, 2 * tau/(1 - tau)) - } else if (family == 4 || family == 14) { - ## Gumbel - if (tau < 0) { - warning("Gumbel copula cannot be used for negatively dependent data.") - tau <- 0.05 - } - theta <- max(1, 1/(1 - tau)) - } else if (family == 5) { - ## Frank - theta <- Frank.itau.JJ(tau) - } else if (family == 6 || family == 16) { - ## Joe - if (tau <= 0) { - warning("Joe copula cannot be used for negatively dependent data.") - tau <- 0.05 - } - theta <- Joe.itau.JJ(tau) - } else if (family == 23 || family == 33) { - if (tau >= 0) { - warning("Rotated Clayton copula cannot be used for positively dependent data.") - tau <- -0.05 - } - theta <- (2 * tau/(1 + tau)) - } else if (family == 24 || family == 34) { - if (tau > 0) { - warning("Rotated Gumbel copula cannot be used for positively dependent data.") - tau <- -0.05 - } - theta <- -(1/(1 + tau)) - } else if (family == 26 || family == 36) { - if (tau >= 0) { - warning("Rotated Joe copula cannot be used for positively dependent data.") - tau <- -0.05 - } - theta <- -Joe.itau.JJ(-tau) - } else if (family %in% c(41, 51)) { - theta <- ipsA.tau2cpar(tau) - } else if (family %in% c(61, 71)) { - theta <- -ipsA.tau2cpar(-tau) - } - - ## standard errors for method itau - se1 <- 0 - if (method == "itau" && se == TRUE) { - p <- 2 - n <- length(u1) - ec <- numeric(n) - u <- cbind(u1, u2) - v <- matrix(0, n, p * (p - 1)/2) - - if (family == 1) - tauder <- function(x) 2/(pi * sqrt(1 - x^2)) else if (family %in% c(3, 13, 23, 33)) - tauder <- function(x) 2 * (2 + x)^(-2) else if (family %in% c(4, 14, 24, 34)) - tauder <- function(x) x^(-2) else if (family == 5) { - tauder <- function(x) { - f <- function(x) x/(exp(x) - 1) - 4/x^2 - 8/x^3 * integrate(f, lower = 0 + .Machine$double.eps^0.5, upper = x)$value + 4/(x * (exp(x) - 1)) - } - } else if (family %in% c(6, 16, 26, 36)) { - tauder <- function(x) { - euler <- 0.577215664901533 - -((-2 + 2 * euler + 2 * log(2) + digamma(1/x) + digamma(1/2 * (2 + x)/x) + x)/(-2 + x)^2) + ((-trigamma(1/x)/x^2 + trigamma(1/2 * (2 + - x)/x) * (1/(2 + x) - (2 + x)/(2 * x^2)) + 1)/(-2 + x)) - } - } else if (family %in% c(41, 51, 61, 71)) { - tauder <- function(x) { - 2 * sqrt(pi) * gamma(0.5 + x) * (digamma(1 + x) - digamma(0.5 + x))/gamma(1 + x) - } - } - - l <- 1 - for (j in 1:(p - 1)) { - for (i in (j + 1):p) { - for (k in 1:n) ec[k] <- sum(u[, i] <= u[k, i] & u[, j] <= u[k, j])/n - v[, l] <- 2 * ec - u[, i] - u[, j] - l <- l + 1 - } - } - - if (family == 0) - D <- 0 else if (family %in% c(1, 3, 4, 5, 6, 13, 14, 16, 41, 51)) - D <- 1/tauder(theta) else if (family %in% c(23, 33, 24, 34, 26, 36, 61, 71)) - D <- 1/tauder(-theta) - - - se1 <- as.numeric(sqrt(16/n * var(v %*% D))) - } - - ## set starting parameters for maximum likelihood estimation - if (method == "mle") { - theta1 <- 0 - delta <- 0 - - if (!(family %in% c(2, 6, 7, 8, 9, 10, 17, 18, 19, 20, 27, 28, 29, 30, 37, 38, 39, 40, 104, 114, 124, 134, 204, 214, 224, 234))) { - theta1 <- theta - } - if (family == 2) { - ## t - theta1 <- sin(tau * pi/2) - delta1 <- min(10, (max.df + 2)/2) # Take the middle between 2 and max.df - delta <- MLE_intern(cbind(u1, u2), - c(theta1, delta1), - family = family, - se = FALSE, - max.df, - max.BB, - cor.fixed = TRUE, - weights)$par[2] - } else if (family == 7 || family == 17) { - ## BB1 - if (tau < 0) { - print("The BB1 or survival BB1 copula cannot be used for negatively dependent data.") - delta <- 1.001 - theta1 <- 0.001 - } else { - delta <- min(1.5, max((max.BB$BB1[2] + 1.001)/2, 1.001)) - theta1 <- min(0.5, max((max.BB$BB1[1] + 0.001)/2, 0.001)) - } - } else if (family == 27 || family == 37) { - ## BB1 - if (tau > 0) { - print("The rotated BB1 copulas cannot be used for positively dependent data.") - delta <- -1.001 - theta1 <- -0.001 - } else { - delta <- max(-1.5, -max((max.BB$BB1[2] + 1.001)/2, 1.001)) - theta1 <- max(-0.5, -max((max.BB$BB1[1] + 0.001)/2, 0.001)) - } - } else if (family == 8 || family == 18) { - ## BB6 - if (tau < 0) { - print("The BB6 or survival BB6 copula cannot be used for negatively dependent data.") - delta <- 1.001 - theta1 <- 1.001 - } else { - delta <- min(1.5, max((max.BB$BB6[2] + 1.001)/2, 1.001)) - theta1 <- min(1.5, max((max.BB$BB6[1] + 1.001)/2, 1.001)) - } - } else if (family == 28 || family == 38) { - ## BB6 - if (tau > 0) { - print("The rotated BB6 copulas cannot be used for positively dependent data.") - delta <- -1.001 - theta1 <- -1.001 - } else { - delta <- max(-1.5, -max((max.BB$BB6[2] + 1.001)/2, 1.001)) - theta1 <- max(-1.5, -max((max.BB$BB6[1] + 1.001)/2, 1.001)) - } - } else if (family == 9 || family == 19) { - ## BB7 - if (tau < 0) { - print("The BB7 or survival BB7 copula cannot be used for negatively dependent data.") - delta <- 0.001 - theta <- 1.001 - } else { - delta <- min(0.5, max((max.BB$BB7[2] + 0.001)/2, 0.001)) - theta1 <- min(1.5, max((max.BB$BB7[1] + 1.001)/2, 1.001)) - } - } else if (family == 29 || family == 39) { - ## BB7 - if (tau > 0) { - print("The rotated BB7 copulas cannot be used for positively dependent data.") - delta <- -0.001 - theta1 <- -1.001 - } else { - delta <- max(-0.5, -max((max.BB$BB7[2] + 0.001)/2, 0.001)) - theta1 <- max(-1.5, -max((max.BB$BB7[1] + 1.001)/2, 1.001)) - } - } else if (family == 10 || family == 20) { - ## BB8 - if (tau < 0) { - print("The BB8 or survival BB8 copula cannot be used for negatively dependent data.") - delta <- 0.001 - theta <- 1.001 - } else { - delta <- min(0.5, max((max.BB$BB8[2] + 0.001)/2, 0.001)) - theta1 <- min(1.5, max((max.BB$BB8[1] + 1.001)/2, 1.001)) - } - } else if (family == 30 || family == 40) { - ## BB8 - if (tau > 0) { - print("The rotated BB8 copulas cannot be used for positively dependent data.") - delta <- -0.001 - theta1 <- -1.001 - } else { - delta <- max(-0.5, -max((max.BB$BB8[2] + 0.001)/2, 0.001)) - theta1 <- max(-1.5, -max((max.BB$BB8[1] + 1.001)/2, 1.001)) - } - } else if (family %in% c(104, 114, 124, 134, 204, 214, 224, 234)) { - ## Tawn - - # the folllowing gives a theoretical kendall's tau close to the empirical one - delta <- min(abs(tau) + 0.1, 0.999) - theta1 <- 1 + 6 * abs(tau) - - # check if data can be modeled by selected family - if (family %in% c(104, 114)) { - if (tau < 0) { - print("The Tawn or survival Tawn copula cannot be used for negatively dependent data.") - delta <- 1 - theta1 <- 1.001 - } - } else if (family %in% c(124, 134)) { - if (tau > 0) { - print("The rotated Tawn copula cannot be used for positively dependent data.") - delta <- 1 - theta1 <- -1.001 - } else theta1 <- -theta1 - - } else if (family %in% c(204, 214)) { - if (tau < 0) { - print("The Tawn2 or survival Tawn2 copula cannot be used for negatively dependent data.") - delta <- 1 - theta1 <- 1.001 - } - } else if (family %in% c(224, 234)) { - if (tau > 0) { - print("The rotated Tawn2 copula cannot be used for positively dependent data.") - delta <- 1 - theta1 <- -1.001 - } else theta1 <- -theta1 - } - } - - ## likelihood optimization - if (family != 0 && family < 100) { - out <- MLE_intern(cbind(u1, u2), - c(theta1, delta), - family = family, - se, - max.df, - max.BB - , weights) - theta <- out$par - if (se == TRUE) - se1 <- out$se - } else if (family != 0 && family > 100) { - # New - out <- MLE_intern_Tawn(cbind(u1, u2), - c(theta1, delta), - family = family, - se) - theta <- out$par - if (se == TRUE) - se1 <- out$se - } - } - - ## store estimated parameters - out2 <- list(family = family) - if (length(theta) == 2) { - out2$par <- theta[1] - out2$par2 <- theta[2] - } else { - out2$par <- theta - out2$par2 <- 0 - } - - ## store standard errors (if asked for) - if (se == TRUE) { - if (length(se1) == 2) { - out2$se <- se1[1] - out2$se2 <- se1[2] - } else { - out2$se <- se1 - out2$se2 <- 0 - } - } - - ## return results - class(out2) <- "BiCop" - out2 -} - - - -Frank.itau.JJ <- function(tau) { - a <- 1 - if (tau < 0) { - a <- -1 - tau <- -tau - } - f <- function(x) { - x/(exp(x) - 1) - } - tauF <- function(x) 1 - 4/x + 4/x^2 * integrate(f, - lower = 0 + .Machine$double.eps^0.5, - upper = x)$value - v <- uniroot(function(x) tau - tauF(x), - lower = 0, - upper = 500, - tol = .Machine$double.eps^0.5)$root - return(a * v) -} - - - -Joe.itau.JJ <- function(tau) { - if (tau < 0) { - return(1.000001) - } else { - tauF <- function(a) { - # euler=0.5772156649015328606 1+((-2+2*euler+2*log(2)+digamma(1/a)+digamma(1/2*(2+a)/a)+a)/(-2+a)) - 1 + 4/a^2 * integrate(function(x) log(x) * x * (1 - x)^(2 * (1 - a)/a), 0, 1)$value - } - - v <- uniroot(function(x) tau - tauF(x), - lower = 1, - upper = 500, - tol = .Machine$double.eps^0.5)$root - return(v) - } -} - -ipsA.tau2cpar <- function(tau, mxiter = 20, eps = 1e-06, dstart = 0, iprint = FALSE) { - con <- log((1 - tau) * sqrt(pi)/2) - de <- dstart - if (dstart <= 0) - de <- tau + 1 - iter <- 0 - diff <- 1 - while (iter < mxiter & max(abs(diff)) > eps) { - g <- con + lgamma(1 + de) - lgamma(de + 0.5) - gp <- digamma(1 + de) - digamma(de + 0.5) - iter <- iter + 1 - diff <- g/gp - de <- de - diff - while (min(de) <= 0) { - diff <- diff/2 - de <- de + diff - } - if (iprint) - cat(iter, " ", de, " ", diff, "\n") - } - if (iter >= mxiter) - cat("did not converge\n") - de -} - - -############################################################# -# bivariate MLE function -# -#------------------------------------------------------------ -# INPUT: -# data Data for which to estimate parameter -# start.parm Start parameter for the MLE -# Maxiter max number of iterations -# se TRUE or FALSE -# OUTPUT: -# out Estimated Parameters and standard error (if se==TRUE) -#-------------------------------------------------------------- -# Author: Ulf Schepsmeier -# Date: 2011-02-04 -# Version: 1.1 -#--------------------------------------------------------------- - -MLE_intern <- function(data, start.parm, family, se = FALSE, max.df = 30, - max.BB = list(BB1 = c(5, 6), BB6 = c(6, 6), BB7 = c(5, 6), BB8 = c(6, 1)), - weights = NULL, cor.fixed = FALSE) { - - n <- dim(data)[1] - if (any(is.na(weights))) - weights <- NULL - - if (family %in% c(7, 8, 9, 10, 17, 18, 19, 20, 27, 28, 29, 30, 37, 38, 39, 40)) { - t_LL <- function(param) { - - if (is.null(weights)) { - ll <- .C("LL_mod2", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param[1]), - as.double(param[2]), - as.double(0), - PACKAGE = "VineCopula")[[7]] - } else { - ll <- .C("LL_mod_seperate", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param[1]), - as.double(param[2]), - as.double(rep(0, n)), - PACKAGE = "VineCopula")[[7]] %*% weights - } - - if (is.infinite(ll) || is.na(ll) || ll < -10^250) - ll <- -10^250 - - return(ll) - } - - if (family == 7 || family == 17) { - low <- c(0.001, 1.001) - up <- max.BB$BB1 - } else if (family == 8 || family == 18) { - low <- c(1.001, 1.001) - up <- max.BB$BB6 - } else if (family == 9 | family == 19) { - low <- c(1.001, 0.001) - up <- max.BB$BB7 - } else if (family == 10 | family == 20) { - low <- c(1.001, 0.001) - up <- max.BB$BB8 - } else if (family == 27 | family == 37) { - up <- c(-0.001, -1.001) - low <- -max.BB$BB1 - } else if (family == 28 | family == 38) { - up <- c(-1.001, -1.001) - low <- -max.BB$BB6 - } else if (family == 29 | family == 39) { - up <- c(-1.001, -0.001) - low <- -max.BB$BB7 - } else if (family == 30 | family == 40) { - up <- c(-1.001, -0.001) - low <- -max.BB$BB8 - } - - if (se == TRUE) { - optimout <- optim(par = start.parm, - fn = t_LL, - method = "L-BFGS-B", - lower = low, - upper = up, - control = list(fnscale = -1, maxit = 500), - hessian = TRUE) - } else { - optimout <- optim(par = start.parm, - fn = t_LL, - method = "L-BFGS-B", - lower = low, - upper = up, - control = list(fnscale = -1, maxit = 500)) - } - - } else if (family == 2) { - - if (cor.fixed == FALSE) { - - t_LL <- function(param) { - if (param[1] < -0.9999 | param[1] > 0.9999 | param[2] < 2.0001 | param[2] > max.df) { - ll <- -10^10 - } else { - if (is.null(weights)) { - ll <- .C("LL_mod2", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param[1]), - as.double(param[2]), - as.double(0), - PACKAGE = "VineCopula")[[7]] - } else { - ll <- .C("LL_mod_seperate", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param[1]), - as.double(param[2]), - as.double(rep(0, n)), - PACKAGE = "VineCopula")[[7]] %*% weights - } - - if (is.infinite(ll) || is.na(ll) || ll < -10^10) - ll <- -10^10 - } - return(ll) - } - - gr_LL <- function(param) { - gr <- rep(0, 2) - gr[1] <- sum(BiCopDeriv(data[, 1], - data[, 2], - family = 2, - par = param[1], - par2 = param[2], - deriv = "par", - log = TRUE)) - gr[2] <- sum(BiCopDeriv(data[, 1], - data[, 2], - family = 2, - par = param[1], - par2 = param[2], - deriv = "par2", - log = TRUE)) - return(gr) - } - - if (is.null(weights)) { - if (se == TRUE) { - optimout <- optim(par = start.parm, - fn = t_LL, - gr = gr_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - hessian = TRUE, - lower = c(-0.9999, 2.0001), - upper = c(0.9999, max.df)) - } else { - optimout <- optim(par = start.parm, - fn = t_LL, - gr = gr_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - lower = c(-0.9999, 2.0001), - upper = c(0.9999, max.df)) - } - } else { - if (se == TRUE) { - optimout <- optim(par = start.parm, - fn = t_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - hessian = TRUE, - lower = c(-0.9999, 2.0001), - upper = c(0.9999, max.df)) - } else { - optimout <- optim(par = start.parm, - fn = t_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - lower = c(-0.9999, 2.0001), - upper = c(0.9999, max.df)) - } - } - - if (optimout$par[2] >= (max.df - 1e-04)) - warning(paste("Degrees of freedom of the t-copula estimated to be larger than ", - max.df, ". Consider using the Gaussian copula instead.", - sep = "")) - - } else { - t_LL <- function(param) { - if (is.null(weights)) { - ll <- .C("LL_mod2", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(start.parm[1]), - as.double(param[1]), - as.double(0), - PACKAGE = "VineCopula")[[7]] - } else { - ll <- .C("LL_mod_seperate", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(start.parm[1]), - as.double(param[1]), - as.double(rep(0, n)), - PACKAGE = "VineCopula")[[7]] %*% weights - } - - if (is.infinite(ll) || is.na(ll) || ll < -10^250) - ll <- -10^250 - - return(ll) - } - - gr_LL <- function(param) { - gr <- sum(BiCopDeriv(data[, 1], - data[, 2], - family = 2, - par = start.parm[1], - par2 = param[1], - deriv = "par2", - log = TRUE)) - return(gr) - } - - if (se == TRUE) { - if (is.null(weights)) { - optimout <- optim(par = start.parm[2], - fn = t_LL, - gr = gr_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - hessian = TRUE, - lower = 2.0001, - upper = max.df) - } else { - optimout <- optim(par = start.parm[2], - fn = t_LL, - method = "L-BFGS-B", - control = list(fnscale = -1, maxit = 500), - hessian = TRUE, - lower = 2.0001, - upper = max.df) - } - } else { - optimout <- optimize(f = t_LL, - maximum = TRUE, - interval = c(2.0001, max.df)) - optimout$par <- optimout$maximum - } - optimout$par <- c(0, optimout$par) - - } - - } else { - - t_LL <- function(param) { - if (is.null(weights)) { - ll <- .C("LL_mod2", as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param), - as.double(0), as.double(0), - PACKAGE = "VineCopula")[[7]] - } else { - ll <- .C("LL_mod_seperate", - as.integer(family), - as.integer(n), - as.double(data[, 1]), - as.double(data[, 2]), - as.double(param[1]), - as.double(0), - as.double(rep(0, n)), - PACKAGE = "VineCopula")[[7]] %*% weights - } - if (is.infinite(ll) || is.na(ll) || ll < -10^250) - ll <- -10^250 - - return(ll) - } - - gr_LL <- function(param) { - gr <- sum(BiCopDeriv(data[, 1], - data[, 2], - family = family, - par = param, - deriv = "par", - log = TRUE)) - return(gr) - } - - low <- -Inf - up <- Inf - - if (family == 1) { - low <- -0.9999 - up <- 0.9999 - } else if (family %in% c(3, 13)) { - low <- 1e-04 - up <- BiCopTau2Par(family, 0.99) - if (t_LL(up) == -10^250) - up <- BiCopTau2Par(family, 0.95) - if (t_LL(up) == -10^250) - up <- BiCopTau2Par(family, 0.9) - } else if (family %in% c(4, 14)) { - low <- 1.0001 - up <- BiCopTau2Par(family, 0.99) - if (t_LL(up) == -10^250) - up <- BiCopTau2Par(family, 0.95) - if (t_LL(up) == -10^250) - up <- BiCopTau2Par(family, 0.9) - } else if (family %in% c(5)) { - low <- BiCopTau2Par(family, -0.99) - if (t_LL(low) == -10^250) - low <- BiCopTau2Par(family, -0.95) - if (t_LL(low) == -10^250) - low <- BiCopTau2Par(family, -0.9) - up <- BiCopTau2Par(family, 0.99) - if (t_LL(up) == -10^250) - up <- BiCopTau2Par(family, 0.95) - if (t_LL(up) == -10^250) - up <- BiCopTau2Par(family, 0.9) - } else if (family %in% c(6, 16)) { - low <- 1.0001 - up <- BiCopTau2Par(family, 0.99) - if (t_LL(up) == -10^250) - up <- BiCopTau2Par(family, 0.95) - if (t_LL(up) == -10^250) - up <- BiCopTau2Par(family, 0.9) - } else if (family %in% c(23, 33)) { - up <- -1e-04 - low <- BiCopTau2Par(family, -0.99) - if (t_LL(low) == -10^250) - low <- BiCopTau2Par(family, -0.95) - if (t_LL(low) == -10^250) - low <- BiCopTau2Par(family, -0.9) - } else if (family %in% c(24, 34)) { - up <- -1.0001 - low <- BiCopTau2Par(family, -0.99) - if (t_LL(low) == -10^250) - low <- BiCopTau2Par(family, -0.95) - if (t_LL(low) == -10^250) - low <- BiCopTau2Par(family, -0.9) - } else if (family %in% c(26, 36)) { - up <- -1.0001 - low <- BiCopTau2Par(family, -0.99) - if (t_LL(low) == -10^250) - low <- BiCopTau2Par(family, -0.95) - if (t_LL(low) == -10^250) - low <- BiCopTau2Par(family, -0.9) - } else if (family %in% c(41, 51)) { - low <- 1e-04 - up <- BiCopTau2Par(family, 0.85) - # if(t_LL(up)==-10^250) up=BiCopTau2Par(family,0.95) if(t_LL(up)==-10^250) up=BiCopTau2Par(family,0.9) - } else if (family %in% c(61, 71)) { - up <- -1e-04 [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vinecopula -r 113 From noreply at r-forge.r-project.org Mon Aug 10 08:52:47 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 10 Aug 2015 08:52:47 +0200 (CEST) Subject: [Vinecopula-commits] r114 - / pkg pkg/R pkg/inst pkg/src Message-ID: <20150810065248.134A518045A@r-forge.r-project.org> 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 -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 +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 From noreply at r-forge.r-project.org Tue Aug 11 10:20:17 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 11 Aug 2015 10:20:17 +0200 (CEST) Subject: [Vinecopula-commits] r115 - pkg/src Message-ID: <20150811082017.B9140187A7D@r-forge.r-project.org> Author: tnagler Date: 2015-08-11 10:20:17 +0200 (Tue, 11 Aug 2015) New Revision: 115 Modified: pkg/src/likelihood.c Log: * prevent log(0)/exp(-Inf)-type bugs in pdf calculations Modified: pkg/src/likelihood.c =================================================================== --- pkg/src/likelihood.c 2015-08-10 06:52:47 UTC (rev 114) +++ pkg/src/likelihood.c 2015-08-11 08:20:17 UTC (rev 115) @@ -23,6 +23,7 @@ #define XEPS 1e-4 +#define XINFMAX DBL_MAX ////////////////////////////////////////////////////////////// // Generatorfunction of BB1, BB6, BB7 and BB8 @@ -868,6 +869,7 @@ t1 = qnorm(dat[0],0.0,1.0,1,0); t2 = qnorm(dat[1],0.0,1.0,1,0); f = 1.0/sqrt(1.0-pow(rho,2.0))*exp((pow(t1,2.0)+pow(t2,2.0))/2.0+(2.0*rho*t1*t2-pow(t1,2.0)-pow(t2,2.0))/(2.0*(1.0-pow(rho,2.0)))); if(log(f)>XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -880,6 +882,7 @@ t1 = qt(dat[0],*nu,1,0); t2 = qt(dat[1],*nu,1,0); f = StableGammaDivision((*nu+2.0)/2.0,*nu/2.0)/(*nu*pi*sqrt(1.0-pow(rho,2.0))*dt(t1,*nu,0)*dt(t2,*nu,0))*pow(1.0+(pow(t1,2.0)+pow(t2,2.0)-2.0*rho*t1*t2)/(*nu*(1.0-pow(rho,2.0))),-(*nu+2.0)/2.0); if(log(f)>XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -893,7 +896,9 @@ { dat[0] = u[j]; dat[1] = v[j]; f=log1p(*theta)-(1.0+*theta)*log(dat[0]*dat[1])-(2.0+1.0/(*theta))*log(pow(dat[0],-*theta)+pow(dat[1],-*theta)-1.0); - ll +=f; + if(f>XINFMAX) ll += XINFMAX; + else if(fXINFMAX) ll += XINFMAX; + else if(fXINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -924,6 +932,7 @@ { f = pow(pow(1-u[j],*theta)+pow(1-v[j],*theta)-pow(1-u[j],*theta)*pow(1-v[j],*theta),1/(*theta)-2)*pow(1-u[j],*theta-1)*pow(1-v[j],*theta-1)*(*theta-1+pow(1-u[j],*theta)+pow(1-v[j],*theta)-pow(1-u[j],*theta)*pow(1-v[j],*theta)); if(log(f)>XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -935,7 +944,9 @@ dat[0] = u[j]; dat[1] = v[j]; t1 = pow(-log(dat[0]),*nu)+pow(-log(dat[1]),*nu); f= -pow(t1,1/(*nu))+(2/(*nu)-2)*log(t1)+(*nu-1)*log(log(dat[0])*log(dat[1]))-log(dat[0]*dat[1])+log(1+(*nu-1)*pow(t1,-1.0/(*nu))); - ll += f; + if(f>XINFMAX) ll += XINFMAX; + else if(fXINFMAX) ll += log(XINFMAX); + else if(fuc[j]XINFMAX) ll += log(XINFMAX); + else if(fuc[j]XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -1032,6 +1046,7 @@ } if(log(fuc[j])>XINFMAX) ll += log(XINFMAX); + else if(fuc[j]XINFMAX) ll += log(XINFMAX); + else if(fuc[j]XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -1083,6 +1100,7 @@ t2 = exp(-pow(t1,1.0/(*theta))); f = t2/(dat[0]*dat[1])*pow(t1,-2.0+2.0/(*theta))*pow(log(dat[0])*log(dat[1]),*theta-1.0)*(1.0+(*theta-1.0)*pow(t1,-1.0/(*theta))); if(log(f)>XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -1093,6 +1111,7 @@ u[j]=1-u[j]; v[j]=1-v[j]; f = pow(pow(1-u[j],*theta)+pow(1-v[j],*theta)-pow(1-u[j],*theta)*pow(1-v[j],*theta),1/(*theta)-2)*pow(1-u[j],*theta-1)*pow(1-v[j],*theta-1)*(*theta-1+pow(1-u[j],*theta)+pow(1-v[j],*theta)-pow(1-u[j],*theta)*pow(1-v[j],*theta)); if(log(f)>XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); u[j]=1-u[j]; v[j]=1-v[j]; } @@ -1105,7 +1124,9 @@ dat[0] = 1-u[j]; dat[1] = 1-v[j]; t1 = pow(-log(dat[0]),*nu)+pow(-log(dat[1]),*nu); f= -pow(t1,1/(*nu))+(2/(*nu)-2)*log(t1)+(*nu-1)*log(log(dat[0])*log(dat[1]))-log(dat[0]*dat[1])+log(1+(*nu-1)*pow(t1,-1.0/(*nu))); - ll += f; + if(f>XINFMAX) ll += XINFMAX; + else if(fXINFMAX) ll += log(XINFMAX); + else if(fuc[j]XINFMAX) ll += log(XINFMAX); + else if(fuc[j]XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } }else{ @@ -1214,6 +1238,7 @@ } if(log(fuc[j])>XINFMAX) ll += log(XINFMAX); + else if(fuc[j]XINFMAX) ll += log(XINFMAX); + else if(fuc[j]XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -1275,6 +1302,7 @@ f=con*tem*exp(-tem+tem1+tem2)/sm; if(log(f)>XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -1286,6 +1314,7 @@ { TawnPDF(&u[j], &v[j], &T, theta, nu, &par3, &f); if(log(f)>XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -1298,6 +1327,7 @@ dat[0] = 1-u[j]; dat[1] = 1-v[j]; TawnPDF(&dat[0], &dat[1], &T, theta, nu, &par3, &f); if(log(f)>XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -1309,6 +1339,7 @@ { TawnPDF(&u[j], &v[j], &T, theta, &par2, nu, &f); if(log(f)>XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } @@ -1321,6 +1352,7 @@ dat[0] = 1-u[j]; dat[1] = 1-v[j]; TawnPDF(&dat[0], &dat[1], &T, theta, &par2, nu, &f); if(log(f)>XINFMAX) ll += log(XINFMAX); + else if(f < DBL_MIN) ll += log(DBL_MIN); else ll += log(f); } } From noreply at r-forge.r-project.org Tue Aug 11 10:23:13 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 11 Aug 2015 10:23:13 +0200 (CEST) Subject: [Vinecopula-commits] r116 - pkg/R Message-ID: <20150811082313.6DD44187A78@r-forge.r-project.org> Author: tnagler Date: 2015-08-11 10:23:12 +0200 (Tue, 11 Aug 2015) New Revision: 116 Modified: pkg/R/RVineCopSelect.r pkg/R/RVineSeqEst.R pkg/R/RVineStructureSelect.r Log: * RVineSeqEst, RVineCopSelect, RVineStructureSelect: free before returning results (memory usage kept increasing in R-3.3.0) Modified: pkg/R/RVineCopSelect.r =================================================================== --- pkg/R/RVineCopSelect.r 2015-08-11 08:20:17 UTC (rev 115) +++ pkg/R/RVineCopSelect.r 2015-08-11 08:23:12 UTC (rev 116) @@ -122,11 +122,12 @@ } } - ## return results - RVM <- RVineMatrix(Mold, - family = Types, - par = Params, - par2 = Params2, - names = varnames) - return(RVM) + ## free memory and return results + .RVM <- RVineMatrix(Mold, + family = Types, + par = Params, + par2 = Params2, + names = varnames) + rm(list = ls()) + .RVM } Modified: pkg/R/RVineSeqEst.R =================================================================== --- pkg/R/RVineSeqEst.R 2015-08-11 08:20:17 UTC (rev 115) +++ pkg/R/RVineSeqEst.R 2015-08-11 08:23:12 UTC (rev 116) @@ -168,12 +168,16 @@ } } + ## store results oldRVM$par <- Params oldRVM$par2 <- Params2 - if (se == FALSE) { - return(list(RVM = oldRVM)) + .out <- list(RVM = oldRVM) } else { - return(list(RVM = oldRVM, se = seMat1, se2 = seMat2)) + .out <- list(RVM = oldRVM, se = seMat1, se2 = seMat2) } + + ## free memory and return results + rm(list = ls()) + .out } Modified: pkg/R/RVineStructureSelect.r =================================================================== --- pkg/R/RVineStructureSelect.r 2015-08-11 08:20:17 UTC (rev 115) +++ pkg/R/RVineStructureSelect.r 2015-08-11 08:23:12 UTC (rev 116) @@ -82,8 +82,10 @@ RVine$Graph[[i]] <- g } - ## return results as 'RVineMatrix' object - as.RVM(RVine) + ## free memory and return results as 'RVineMatrix' object + .RVine <- RVine + rm(list = ls()) + as.RVM(.RVine) } ## full graph with Kendall's tau as edge weights From noreply at r-forge.r-project.org Tue Aug 11 11:12:00 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 11 Aug 2015 11:12:00 +0200 (CEST) Subject: [Vinecopula-commits] r117 - pkg/R Message-ID: <20150811091200.3108E18010E@r-forge.r-project.org> Author: tnagler Date: 2015-08-11 11:11:59 +0200 (Tue, 11 Aug 2015) New Revision: 117 Modified: pkg/R/RVineStructureSelect.r Log: * initializeFirstGraph, buildNextGraph: tidy code and make fns run faster using apply-family instead of loops Modified: pkg/R/RVineStructureSelect.r =================================================================== --- pkg/R/RVineStructureSelect.r 2015-08-11 08:23:12 UTC (rev 116) +++ pkg/R/RVineStructureSelect.r 2015-08-11 09:11:59 UTC (rev 117) @@ -1,7 +1,7 @@ RVineStructureSelect <- function(data, familyset = NA, type = 0, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, trunclevel = NA, progress = FALSE, weights = NA, rotations = TRUE) { - d <- n <- dim(data)[2] - N <- dim(data)[1] + d <- ncol(data) + N <- nrow(data) ## sanity checks if (type == 0) @@ -30,7 +30,7 @@ ## set variable names and trunclevel if not provided if (is.null(colnames(data))) - colnames(data) <- paste("V", 1:n, sep = "") + colnames(data) <- paste("V", 1:d, sep = "") if (is.na(trunclevel)) trunclevel <- d @@ -61,7 +61,7 @@ oldVineGraph <- VineTree ## estimation in higher trees -------------------------- - for (i in 2:(n - 1)) { + for (i in 2:(d - 1)) { # only estimate pair-copulas if not truncated if (trunclevel == i - 1) familyset <- 0 @@ -88,31 +88,25 @@ as.RVM(.RVine) } -## full graph with Kendall's tau as edge weights initializeFirstGraph <- function(data.univ, weights) { - # C = cor(data.univ,method='kendall') - q <- dim(data.univ)[2] -# C <- matrix(rep(1, q * q), ncol = q) -# -# for (i in 1:(q - 1)) { -# for (j in (i + 1):q) { -# tau <- fasttau(data.univ[, i], data.univ[, j], weights) -# C[i, j] <- tau -# C[j, i] <- tau -# } -# } -# rownames(C) <- colnames(C) <- colnames(data.univ) - C <- TauMatrix(data = data.univ, weights = weights) + ## calculate Kendall's tau + taus <- TauMatrix(data = data.univ, weights = weights) - g <- graph_from_adjacency_matrix(C, mode = "lower", weighted = TRUE, diag = FALSE) + ## create graph with Kendall's tau as weights + g <- graph_from_adjacency_matrix(taus, + mode = "lower", + weighted = TRUE, + diag = FALSE) E(g)$tau <- E(g)$weight E(g)$name <- paste(as_edgelist(g)[, 1], as_edgelist(g)[, 2], sep = ",") - for (i in 1:gsize(g)) { - E(g)$conditionedSet[[i]] <- ends(g, i, names = FALSE) - } - return(g) + ## store condition sets + E(g)$conditionedSet <- unname(split(ends(g, 1:gsize(g), names = FALSE), + 1:gsize(g))) + + ## return graph object + g } ## find maximum spanning tree/ first vine tree @@ -307,128 +301,128 @@ ## initialize graph for next vine tree (possible edges) buildNextGraph <- function(oldVineGraph, weights = NA) { - # EL <- as_edgelist(oldVineGraph) d <- gsize(oldVineGraph) - + ## initialize with full graph g <- make_full_graph(d) V(g)$name <- E(oldVineGraph)$name V(g)$conditionedSet <- E(oldVineGraph)$conditionedSet - if (!is.null(E(oldVineGraph)$conditioningSet)) { V(g)$conditioningSet <- E(oldVineGraph)$conditioningSet } - for (i in 1:gsize(g)) { + ## get info for all edges + out <- lapply(1:gsize(g), + getEdgeInfo, + g = g, + oldVineGraph = oldVineGraph, + weights = weights) + + ## annotate graph (same order as in old version of this function) + E(g)$weight <- sapply(out, function(x) x$tau) + E(g)$name <- sapply(out, function(x) x$name) + E(g)$conditionedSet <- lapply(out, function(x) x$nedSet) + E(g)$conditioningSet <- lapply(out, function(x) x$ningSet) + E(g)$todel <- sapply(out, function(x) x$todel) + E(g)$tau <- E(g)$weight + + ## delete edges that are prohibited by the proximity condition + g <- delete_edges(g, E(g)[E(g)$todel]) + + ## return new graph + g +} + +## function for obtaining edge information +getEdgeInfo <- function(i, g, oldVineGraph, weights) { + + ## get edge + con <- as.vector(ends(g, i, names = FALSE)) + temp <- ends(oldVineGraph, con, names = FALSE) + + ## check for proximity condition + ok <- FALSE + if ((temp[1, 1] == temp[2, 1]) || (temp[1, 2] == temp[2, 1])) { + ok <- TRUE + same <- temp[2, 1] + } else { + if ((temp[1, 1] == temp[2, 2]) || (temp[1, 2] == temp[2, 2])) { + ok <- TRUE + same <- temp[2, 2] + } + } + + ## dummy output + tau <- nedSet <- ningSet <- name <- NA + todel <- TRUE + + ## calculate edge info if proximity condition is fulfilled + if (ok) { + # get data + if (temp[1, 1] == same) { + zr1 <- E(oldVineGraph)[con[1]]$Copula.CondData.2 + } else { + zr1 <- E(oldVineGraph)[con[1]]$Copula.CondData.1 + } + if (temp[2, 1] == same) { + zr2 <- E(oldVineGraph)[con[2]]$Copula.CondData.2 + } else { + zr2 <- E(oldVineGraph)[con[2]]$Copula.CondData.1 + } + if (is.list(zr1)) { + zr1a <- as.vector(zr1[[1]]) + zr2a <- as.vector(zr2[[1]]) + } else { + zr1a <- zr1 + zr2a <- zr2 + } - con <- as.vector(ends(g, i, names = FALSE)) + # calculate Kendall's tau + keine_nas <- !(is.na(zr1a) | is.na(zr2a)) + tau <- fasttau(zr1a[keine_nas], + zr2a[keine_nas], + weights) - temp <- ends(oldVineGraph, con, names = FALSE) + # get names + name.node1 <- strsplit(V(g)[con[1]]$name, split = " *[,;] *")[[1]] + name.node2 <- strsplit(V(g)[con[2]]$name, split = " *[,;] *")[[1]] - ## check for proximity condition - ok <- FALSE - if ((temp[1, 1] == temp[2, 1]) || (temp[1, 2] == temp[2, 1])) { - ok <- TRUE - same <- temp[2, 1] + # infer conditioned set and conditioning set + if (is.list(V(g)[con[1]]$conditionedSet)) { + l1 <- c(as.vector(V(g)[con[1]]$conditionedSet[[1]]), + as.vector(V(g)[con[1]]$conditioningSet[[1]])) + l2 <- c(as.vector(V(g)[con[2]]$conditionedSet[[1]]), + as.vector(V(g)[con[2]]$conditioningSet[[1]])) } else { - if ((temp[1, 1] == temp[2, 2]) || (temp[1, 2] == temp[2, 2])) { - ok <- TRUE - same <- temp[2, 2] - } + l1 <- c(V(g)[con[1]]$conditionedSet, + V(g)[con[1]]$conditioningSet) + l2 <- c(V(g)[con[2]]$conditionedSet, + V(g)[con[2]]$conditioningSet) } + nedSet <- c(setdiff(l1, l2), setdiff(l2, l1)) + ningSet <- intersect(l1, l2) + + # set edge name + nmdiff <- c(setdiff(name.node1, name.node2), + setdiff(name.node2, name.node1)) + nmsect <- intersect(name.node1, name.node2) + name <- paste(paste(nmdiff, collapse = ","), + paste(nmsect, collapse = ","), + sep = " ; ") - ## if proximity condition is fulfilled - if (ok) { - # other1 <- temp[1, temp[1, ] != same] - # other2 <- temp[2, temp[2, ] != same] - - if (temp[1, 1] == same) { - zr1 <- E(oldVineGraph)[con[1]]$Copula.CondData.2 - } else { - zr1 <- E(oldVineGraph)[con[1]]$Copula.CondData.1 - } - - if (temp[2, 1] == same) { - zr2 <- E(oldVineGraph)[con[2]]$Copula.CondData.2 - } else { - zr2 <- E(oldVineGraph)[con[2]]$Copula.CondData.1 - } - # print(is.list(zr1)) - if (is.list(zr1)) { - zr1a <- as.vector(zr1[[1]]) - zr2a <- as.vector(zr2[[1]]) - } else { - zr1a <- zr1 - zr2a <- zr2 - } - keine_nas <- !(is.na(zr1a) | is.na(zr2a)) - # print(keine_nas) print(zr1a) E(g)[i]$weight = cor(x=zr1[keine_nas],y=zr2[keine_nas], method='kendall') - E(g)[i]$weight <- TauMatrix(cbind(zr1a[keine_nas], zr2a[keine_nas]), weights)[2,1] - - name.node1 <- strsplit(V(g)[con[1]]$name, split = " *[,;] *")[[1]] - name.node2 <- strsplit(V(g)[con[2]]$name, split = " *[,;] *")[[1]] - - ## conditioning set - schnitt <- intersect(name.node1, name.node2) -# for (j in 1:length(name.node1)) { -# for (k in 1:length(name.node2)) { -# if (name.node1[j] == name.node2[k]) { -# schnitt <- c(schnitt, name.node1[j]) -# name.node1[j] <- "" -# name.node2[k] <- "" -# break -# } -# } -# } - - ## conditioned set - differenz <- c(setdiff(name.node1, name.node2), setdiff(name.node2, name.node1)) -# for (j in 1:length(name.node1)) { -# if (name.node1[j] != "") { -# differenz <- c(differenz, name.node1[j]) -# } -# } -# for (j in 1:length(name.node2)) { -# if (name.node2[j] != "") { -# differenz <- c(differenz, name.node2[j]) -# } -# } - - E(g)[i]$name <- paste(paste(differenz, collapse = ","), - paste(schnitt, collapse = ","), - sep = " ; ") - - if (is.list(V(g)[con[1]]$conditionedSet)) { - l1 <- c(as.vector(V(g)[con[1]]$conditionedSet[[1]]), - as.vector(V(g)[con[1]]$conditioningSet[[1]])) - l2 <- c(as.vector(V(g)[con[2]]$conditionedSet[[1]]), - as.vector(V(g)[con[2]]$conditioningSet[[1]])) - } else { - l1 <- c(V(g)[con[1]]$conditionedSet, - V(g)[con[1]]$conditioningSet) - l2 <- c(V(g)[con[2]]$conditionedSet, - V(g)[con[2]]$conditioningSet) - } - out <- intern_SchnittDifferenz(l1, l2) - - suppressWarnings({ - E(g)$conditionedSet[i] <- list(out$differenz) - }) - suppressWarnings({ - E(g)$conditioningSet[i] <- list(out$schnitt) - }) - } - - E(g)[i]$todel <- !ok + # mark as ok + todel <- FALSE } - E(g)$tau <- E(g)$weight - - g <- delete_edges(g, E(g)[E(g)$todel]) - - return(g) + ## return edge information + list(tau = tau, + nedSet = nedSet, + ningSet = ningSet, + name = name, + todel = todel) } + wrapper_fit.ACopula <- function(parameterForACopula, type, ...) { return(fit.ACopula(parameterForACopula$zr1, parameterForACopula$zr2, @@ -436,35 +430,6 @@ ...)) } -intern_SchnittDifferenz <- function(liste1, liste2) { - out <- list() - out$schnitt <- intersect(liste1, liste2) - out$differenz <- c(setdiff(liste1, liste2), setdiff(liste2, liste1)) - -# for (j in 1:length(liste1)) { -# for (k in 1:length(liste2)) { -# if (!is.na(liste2[k]) && liste1[j] == liste2[k]) { -# out$schnitt <- c(out$schnitt, liste1[j]) -# liste1[j] <- NA -# liste2[k] <- NA -# break -# } -# } -# } -# -# for (j in 1:length(liste1)) { -# if (!is.na(liste1[j])) { -# out$differenz <- c(out$differenz, liste1[j]) -# } -# } -# for (j in 1:length(liste2)) { -# if (!is.na(liste2[j])) { -# out$differenz <- c(out$differenz, liste2[j]) -# } -# } - - return(out) -} ## bivariate copula selection fit.ACopula <- function(u1, u2, familyset = NA, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, weights = NA) { From noreply at r-forge.r-project.org Thu Aug 20 15:38:39 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 20 Aug 2015 15:38:39 +0200 (CEST) Subject: [Vinecopula-commits] r118 - / Message-ID: <20150820133840.12903185F3A@r-forge.r-project.org> Author: tnagler Date: 2015-08-20 15:38:38 +0200 (Thu, 20 Aug 2015) New Revision: 118 Modified: .Rprofile Log: * use https protocol for CRAN mirror Modified: .Rprofile =================================================================== --- .Rprofile 2015-08-11 09:11:59 UTC (rev 117) +++ .Rprofile 2015-08-20 13:38:38 UTC (rev 118) @@ -1 +1 @@ -options(repos = c(CRAN="http://cran.r-project.org")) +options(repos = c(CRAN="https://cran.r-project.org")) From noreply at r-forge.r-project.org Thu Aug 20 15:41:07 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 20 Aug 2015 15:41:07 +0200 (CEST) Subject: [Vinecopula-commits] r119 - in pkg: . R man Message-ID: <20150820134107.BCBDE181103@r-forge.r-project.org> Author: tnagler Date: 2015-08-20 15:41:07 +0200 (Thu, 20 Aug 2015) New Revision: 119 Added: pkg/R/RVineStructureSelect2.R pkg/man/RVineStructureSelect2.Rd Modified: pkg/NAMESPACE Log: * RVineStructureSelect2: same as RVineStructureSelect, but not using igraph Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2015-08-20 13:38:38 UTC (rev 118) +++ pkg/NAMESPACE 2015-08-20 13:41:07 UTC (rev 119) @@ -51,6 +51,7 @@ export(RVineCopSelect) export(RVineMLE) export(RVineStructureSelect) +export(RVineStructureSelect2) export(RVineTreePlot) export(RVineVuongTest) export(RVineClarkeTest) @@ -110,4 +111,4 @@ S3method(pairs, copuladata) S3method(plot, BiCop) -useDynLib("VineCopula") \ No newline at end of file +useDynLib("VineCopula") Added: pkg/R/RVineStructureSelect2.R =================================================================== --- pkg/R/RVineStructureSelect2.R (rev 0) +++ pkg/R/RVineStructureSelect2.R 2015-08-20 13:41:07 UTC (rev 119) @@ -0,0 +1,673 @@ +RVineStructureSelect2 <- function(data, familyset = NA, type = 0, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, trunclevel = NA, progress = FALSE, weights = NA, rotations = TRUE) { + d <- ncol(data) + n <- nrow(data) + + ## sanity checks + if (type == 0) + type <- "RVine" else if (type == 1) + type <- "CVine" + if (type != "RVine" & type != "CVine") + stop("Vine model not implemented.") + if (n < 2) + stop("Number of observations has to be at least 2.") + if (d < 3) + stop("Dimension has to be at least 3.") + if (any(data > 1) || any(data < 0)) + stop("Data has to be in the interval [0,1].") + if (!is.na(familyset[1])) { + for (i in 1:length(familyset)) { + if (!(familyset[i] %in% c(0, 1:10, 13, 14, 16:20, + 23, 24, 26:30, 33, 34, 36:40, + 104, 114, 124, 134, 204, 214, 224, 234))) + stop("Copula family not implemented.") + } + } + if (selectioncrit != "AIC" && selectioncrit != "BIC") + stop("Selection criterion not implemented.") + if (level < 0 & level > 1) + stop("Significance level has to be between 0 and 1.") + + ## set variable names and trunclevel if not provided + if (is.null(colnames(data))) + colnames(data) <- paste0("V", 1:d) + if (is.na(trunclevel)) + trunclevel <- d + + ## adjust familyset + if (trunclevel == 0) + familyset <- 0 + if (rotations) + familyset <- with_rotations(familyset) + + ## initialize object for results + RVine <- list(Tree = NULL, Graph = NULL) + + ## estimation in first tree ---------------------------- + # find optimal tree + g <- initializeFirstGraph2(data, weights) + MST <- findMaximumTauTree2(g,mode = type) + + # estimate pair-copulas + VineTree <- fit.FirstTreeCopulas2(MST, + data, + familyset, + selectioncrit, + indeptest, + level, + weights = weights) + # store results + RVine$Tree[[1]] <- VineTree + RVine$Graph[[1]] <- g + oldVineGraph <- VineTree + + ## estimation in higher trees -------------------------- + for (i in 2:(d - 1)) { + # only estimate pair-copulas if not truncated + if (trunclevel == i - 1) + familyset <- 0 + # find optimal tree + g <- buildNextGraph2(VineTree, weights) + MST <- findMaximumTauTree2(g, mode = type) + # estimate pair-copulas + VineTree <- fit.TreeCopulas2(MST, + VineTree, + familyset, + selectioncrit, + indeptest, + level, + progress, + weights = weights) + # store results + RVine$Tree[[i]] <- VineTree + RVine$Graph[[i]] <- g + } + + ## free memory and return results as 'RVineMatrix' object + .RVine <- RVine + rm(list = ls()) + as.RVM2(.RVine) +} + +initializeFirstGraph2 <- function(data.univ, weights) { + ## calculate Kendall's tau + taus <- TauMatrix(data = data.univ, weights = weights) + + ## return full graph with tau as weights + graphFromTauMatrix(taus) +} + +findMaximumTauTree2 <- function(g, mode = "RVine") { + ## construct adjency matrix + A <- adjacencyMatrix(g) + d <- ncol(A) + + if (mode == "RVine") { + ## initialize + tree <- NULL + edges <- matrix(NA, d - 1, 2) + w <- numeric(d - 1) + i <- 1 + + ## construct minimum spanning tree + for (k in 1:(d - 1)) { + # add selected edge to tree + tree <- c(tree, i) + + # find edge with minimal weight + m <- apply(as.matrix(A[, tree]), 2, min) + a <- apply(as.matrix(A[, tree]), 2, function(x) order(rank(x)))[1, ] + b <- apply(as.matrix(m), 2, function(x) order(rank(x)))[1] + j <- tree[b] + i <- a[b] + + # store edge and weight + edges[k, ] <- c(j, i) + w[k] <- A[i, j] + + ## adjust adjecency matrix to prevent loops + for (t in tree) + A[i, t] <- A[t, i] <- Inf + } + + ## reorder edges for backwads compatibility with igraph output + edges <- t(apply(edges, 1, function(x) sort(x))) + edges <- edges[order(edges[, 2], edges[, 1]), ] + + ## delete unused edges from graph + E <- g$E$nums + in.tree <- apply(matrix(edges, ncol = 2), 1, + function(x) which((x[1] == E[, 1]) & (x[2] == E[, 2]))) + g$E$todel <- rep(TRUE, nrow(E)) + g$E$todel[in.tree] <- FALSE + MST <- deleteEdges(g) + } else if (mode == "CVine") { + ## set root as vertex with minimal sum of weights + A <- adjacencyMatrix(g) + diag(A) <- 0 + sumtaus <- rowSums(A) + root <- which.min(sumtaus) + + ## delete unused edges + g$E$todel <- !((g$E$nums[, 2] == root) | (g$E$nums[, 1] == root)) + MST <- g + if (any(g$E$todel )) + MST <- deleteEdges(g) + } else { + stop("vine not implemented") + } + + ## return result + MST +} + + +# not required any longer? Use TauMatrix instead +fasttau <- function(x, y, weights = NA) { + if (any(is.na(weights))) { + m <- length(x) + n <- length(y) + if (m == 0 || n == 0) + stop("both 'x' and 'y' must be non-empty") + if (m != n) + stop("'x' and 'y' must have the same length") + out <- .C("ktau", + x = as.double(x), + y = as.double(y), + N = as.integer(n), + tau = as.double(0), + S = as.double(0), + D = as.double(0), + T = as.integer(0), + U = as.integer(0), + V = as.integer(0), + PACKAGE = "VineCopula") + ktau <- out$tau + } else { + ktau <- TauMatrix(matrix(c(x, y), length(x), 2), weights)[2, 1] + } + return(ktau) +} + +## fit pair-copulas for the first vine tree +fit.FirstTreeCopulas2 <- function(MST, data.univ, type, copulaSelectionBy, testForIndependence, testForIndependence.level, weights = NA) { + + ## initialize estimation results with empty list + d <- nrow(MST$E$nums) + parameterForACopula <- lapply(1:d, function(i) NULL) + + ## prepare for estimation and store names + for (i in 1:d) { + ## get edge and corresponding data + a <- MST$E$nums[i, ] + parameterForACopula[[i]]$zr1 <- data.univ[, a[1]] + parameterForACopula[[i]]$zr2 <- data.univ[, a[2]] + MST$E$Copula.Data.1[i] <- list(data.univ[, a[1]]) + MST$E$Copula.Data.2[i] <- list(data.univ[, a[2]]) + + ## set names for this edge + if (is.null(MST$V$names[a[1]])) { + MST$E$Copula.CondName.1[i] <- a[1] + } else { + MST$E$Copula.CondName.1[i] <- MST$V$names[a[1]] + } + if (is.null(MST$V$names[a[2]])) { + MST$E$Copula.CondName.2[i] <- a[2] + } else { + MST$E$Copula.CondName.2[i] <- MST$V$names[a[2]] + } + if (is.null(MST$V$names[a[1]]) || is.null(MST$V$names[a[2]])) { + MST$E$Copula.Name[i] <- paste(a[1], a[2], sep = " , ") + } else { + MST$E$Copula.Name[i] <- paste(MST$V$names[a[1]], + MST$V$names[a[2]], + sep = " , ") + } + } + + ## estimate parameters and select family + outForACopula <- lapply(X = parameterForACopula, + FUN = wrapper_fit.ACopula, + type, + copulaSelectionBy, + testForIndependence, + testForIndependence.level, + weights) + + ## store estimated model and pseudo-obversations for next tree + for (i in 1:d) { + MST$E$Copula.param[[i]] <- c(outForACopula[[i]]$par, + outForACopula[[i]]$par2) + MST$E$Copula.type[i] <- outForACopula[[i]]$family + MST$E$Copula.out[i] <- list(outForACopula[[i]]) + + MST$E$Copula.CondData.1[i] <- list(outForACopula[[i]]$CondOn.1) + MST$E$Copula.CondData.2[i] <- list(outForACopula[[i]]$CondOn.2) + } + + ## return results + MST +} + +## fit pair-copulas for vine trees 2,... +fit.TreeCopulas2 <- function(MST, oldVineGraph, type, copulaSelectionBy, testForIndependence, testForIndependence.level, progress, weights = NA) { + + ## initialize estimation results with empty list + d <- nrow(MST$E$nums) + parameterForACopula <- lapply(1:d, function(i) NULL) + + + ## prepare for estimation + for (i in 1:d) { + ## get edge and corresponding data + con <- MST$E$nums[i, ] + temp <- oldVineGraph$E$nums[con, ] + + ## fetch corresponding data and names + if ((temp[1, 1] == temp[2, 1]) || (temp[1, 2] == temp[2, 1])) { + same <- temp[2, 1] + } else { + if ((temp[1, 1] == temp[2, 2]) || (temp[1, 2] == temp[2, 2])) { + same <- temp[2, 2] + } + } + + if (temp[1, 1] == same) { + zr1 <- oldVineGraph$E$Copula.CondData.2[con[1]] + n1 <- oldVineGraph$E$Copula.CondName.2[con[1]] + } else { + zr1 <- oldVineGraph$E$Copula.CondData.1[con[1]] + n1 <- oldVineGraph$E$Copula.CondName.1[con[1]] + } + if (temp[2, 1] == same) { + zr2 <- oldVineGraph$E$Copula.CondData.2[con[2]] + n2 <- oldVineGraph$E$Copula.CondName.2[con[2]] + } else { + zr2 <- oldVineGraph$E$Copula.CondData.1[con[2]] + n2 <- oldVineGraph$E$Copula.CondName.1[con[2]] + } + + if (is.list(zr1)) { + zr1a <- as.vector(zr1[[1]]) + zr2a <- as.vector(zr2[[1]]) + n1a <- as.vector(n1[[1]]) + n2a <- as.vector(n2[[1]]) + } else { + zr1a <- zr1 + zr2a <- zr2 + n1a <- n1 + n2a <- n2 + } + + if (progress == TRUE) + message(n1a, " + ", n2a, " --> ", MST$E$names[i]) + + parameterForACopula[[i]]$zr1 <- zr1a + parameterForACopula[[i]]$zr2 <- zr2a + + MST$E$Copula.Data.1[i] <- list(zr1a) + MST$E$Copula.Data.2[i] <- list(zr2a) + + MST$E$Copula.CondName.1[i] <- n1a + MST$E$Copula.CondName.2[i] <- n2a + } + + ## estimate parameters and select family + outForACopula <- lapply(X = parameterForACopula, + FUN = wrapper_fit.ACopula, + type, + copulaSelectionBy, + testForIndependence, + testForIndependence.level, + weights) + + ## store estimated model and pseudo-obversations for next tree + for (i in 1:d) { + MST$E$Copula.param[[i]] <- c(outForACopula[[i]]$par, + outForACopula[[i]]$par2) + MST$E$Copula.type[i] <- outForACopula[[i]]$family + MST$E$Copula.out[i] <- list(outForACopula[[i]]) + + MST$E$Copula.CondData.1[i] <- list(outForACopula[[i]]$CondOn.1) + MST$E$Copula.CondData.2[i] <- list(outForACopula[[i]]$CondOn.2) + } + + ## return results + MST +} + +## initialize graph for next vine tree (possible edges) +buildNextGraph2 <- function(oldVineGraph, weights = NA) { + + d <- nrow(oldVineGraph$E$nums) + + ## initialize with full graph + g <- makeFullGraph(d) + g$V$names <- oldVineGraph$E$names + g$V$conditionedSet <- oldVineGraph$E$conditionedSet + g$V$conditioningSet <- oldVineGraph$E$conditioningSet + + ## get info for all edges + out <- lapply(1:nrow(g$E$nums), + getEdgeInfo2, + g = g, + oldVineGraph = oldVineGraph, + weights = weights) + + ## annotate graph (same order as in old version of this function) + g$E$weights <- sapply(out, function(x) x$tau) + g$E$names <- sapply(out, function(x) x$name) + g$E$conditionedSet <- lapply(out, function(x) x$nedSet) + g$E$conditioningSet <- lapply(out, function(x) x$ningSet) + g$E$todel <- sapply(out, function(x) x$todel) + + ## delete edges that are prohibited by the proximity condition + deleteEdges(g) +} + +## function for obtaining edge information +getEdgeInfo2 <- function(i, g, oldVineGraph, weights) { + + ## get edge + con <- g$E$nums[i, ] + temp <- oldVineGraph$E$nums[con, ] + + ## check for proximity condition + ok <- FALSE + if ((temp[1, 1] == temp[2, 1]) || (temp[1, 2] == temp[2, 1])) { + ok <- TRUE + same <- temp[2, 1] + } else { + if ((temp[1, 1] == temp[2, 2]) || (temp[1, 2] == temp[2, 2])) { + ok <- TRUE + same <- temp[2, 2] + } + } + + ## dummy output + tau <- nedSet <- ningSet <- name <- NA + todel <- TRUE + + # info if proximity condition is fulfilled ... + if (ok) { + ## get data + if (temp[1, 1] == same) { + zr1 <- oldVineGraph$E$Copula.CondData.2[con[1]] + } else { + zr1 <- oldVineGraph$E$Copula.CondData.1[con[1]] + } + if (temp[2, 1] == same) { + zr2 <- oldVineGraph$E$Copula.CondData.2[con[2]] + } else { + zr2 <- oldVineGraph$E$Copula.CondData.1[con[2]] + } + if (is.list(zr1)) { + zr1a <- as.vector(zr1[[1]]) + zr2a <- as.vector(zr2[[1]]) + } else { + zr1a <- zr1 + zr2a <- zr2 + } + + ## calculate Kendall's tau + keine_nas <- !(is.na(zr1a) | is.na(zr2a)) + tau <- fasttau(zr1a[keine_nas], zr2a[keine_nas], weights) + + ## get names + name.node1 <- strsplit(g$V$names[con[1]], split = " *[,;] *")[[1]] + name.node2 <- strsplit(g$V$names[con[2]], split = " *[,;] *")[[1]] + + ## infer conditioned set and conditioning set + l1 <- c(g$V$conditionedSet[[con[1]]], + g$V$conditioningSet[[con[1]]]) + l2 <- c(g$V$conditionedSet[[con[2]]], + g$V$conditioningSet[[con[2]]]) + nedSet <- c(setdiff(l1, l2), setdiff(l2, l1)) + ningSet <- intersect(l1, l2) + + ## set edge name + nmdiff <- c(setdiff(name.node1, name.node2), + setdiff(name.node2, name.node1)) + nmsect <- intersect(name.node1, name.node2) + name <- paste(paste(nmdiff, collapse = ","), + paste(nmsect, collapse = ","), + sep = " ; ") + + ## mark as ok + todel <- FALSE + } + + ## return edge information + list(tau = tau, + nedSet = nedSet, + ningSet = ningSet, + name = name, + todel = todel) +} + + +wrapper_fit.ACopula <- function(parameterForACopula, type, ...) { + return(fit.ACopula(parameterForACopula$zr1, + parameterForACopula$zr2, + type, + ...)) +} + + +## bivariate copula selection +fit.ACopula <- function(u1, u2, familyset = NA, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, weights = NA) { + + ## select family and estimate parameter(s) for the pair copula + out <- BiCopSelect(u1, u2, + familyset, + selectioncrit, + indeptest, + level, + weights = weights, + rotations = FALSE) + + ## change rotation if family is not symmetric wrt the main diagonal + if (out$family %in% c(23, 24, 26:30, 124, 224)) { + out$family <- out$family + 10 + } else if (out$family %in% c(33, 34, 36:40, 134, 234)) { + out$family <- out$family - 10 + } + + ## tawn copulas also have to change type + if (out$family%/%100 == 1) { + out$family <- out$family + 100 + } else if (out$family%/%200 == 1) { + out$family <- out$family - 100 + } + + ## store pseudo-observations for estimation in next tree + out$CondOn.1 <- .C("Hfunc1", + as.integer(out$family), + as.integer(length(u1)), + as.double(u1), + as.double(u2), + as.double(out$par), + as.double(out$par2), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[7]] + out$CondOn.2 <- .C("Hfunc2", + as.integer(out$family), + as.integer(length(u1)), + as.double(u2), + as.double(u1), + as.double(out$par), + as.double(out$par2), + as.double(rep(0, length(u1))), + PACKAGE = "VineCopula")[[7]] + + ## return results + out +} + +## build R-Vine matrix object based on nested set of trees +as.RVM2 <- function(RVine) { + + ## initialize objects + n <- length(RVine$Tree) + 1 + con <- list() + nam <- RVine$Tree[[1]]$V$names + nedSets <- list() + crspParams <- list() + crspTypes <- list() + + ## get selected pairs, families and estimated parameters + for (k in 1:(n - 2)) { + nedSets[[k]] <- RVine$Tree[[k]]$E$conditionedSet + crspParams[[k]] <- as.list(RVine$Tree[[k]]$E$Copula.param) + crspTypes[[k]] <- as.list(RVine$Tree[[k]]$E$Copula.type) + } + crspParams[[n - 1]] <- as.list(RVine$Tree[[n - 1]]$E$Copula.param) + crspTypes[[n - 1]] <- as.list(RVine$Tree[[n - 1]]$E$Copula.type) + if (is.list(RVine$Tree[[n - 1]]$E$conditionedSet)) { + nedSets[[n - 1]] <- list(RVine$Tree[[n - 1]]$E$conditionedSet[[1]]) + } else { + nedSets[[n - 1]] <- list(RVine$Tree[[n - 1]]$E$conditionedSet) + } + + ## initialize matrices for RVineMatrix object + Param <- array(dim = c(n, n)) + Params2 <- array(0, dim = c(n, n)) + Type <- array(dim = c(n, n)) + M <- matrix(NA, n, n) + + ## store structure, families and parameters in matrices + for (k in 1:(n - 1)) { + w <- nedSets[[n - k]][[1]][1] + + M[k, k] <- w + M[(k + 1), k] <- nedSets[[n - k]][[1]][2] + + Param[(k + 1), k] <- crspParams[[n - k]][[1]][1] + Params2[(k + 1), k] <- crspParams[[n - k]][[1]][2] + Type[(k + 1), k] <- crspTypes[[n - k]][[1]] + + if (k == (n - 1)) { + M[(k + 1), (k + 1)] <- nedSets[[n - k]][[1]][2] + } else { + for (i in (k + 2):n) { + for (j in 1:length(nedSets[[n - i + 1]])) { + cs <- nedSets[[n - i + 1]][[j]] + cty <- crspTypes[[n - i + 1]][[j]] + if (cs[1] == w) { + M[i, k] <- cs[2] + Type[i, k] <- cty + break + } else if (cs[2] == w) { + # correct family for rotations + if (cty %in% c(23, 24, 26:30, 124, 224)) { + cty <- cty + 10 + } else if (cty %in% c(33, 34, 36:40, 134, 234)) { + cty <- cty - 10 + } + # change type for Tawn + if (cty%/%100 == 1) { + cty <- cty + 100 + } else if (cty%/%200 == 1) { + cty <- cty - 100 + } + M[i, k] <- cs[1] + Type[i, k] <- cty + break + } + } + Param[i, k] <- crspParams[[n - i + 1]][[j]][1] + Params2[i, k] <- crspParams[[n - i + 1]][[j]][2] + nedSets[[n - i + 1]][[j]] <- NULL + crspParams[[n - i + 1]][[j]] <- NULL + crspTypes[[n - i + 1]][[j]] <- NULL + } + } + } + + ## clean NAs + M[is.na(M)] <- 0 + Type[is.na(Type)] <- 0 + + ## return RVineMatrix object + RVineMatrix(M, family = Type, par = Param, par2 = Params2, names = nam) +} + + +## functions for handling the tree structure ------------------------- +graphFromTauMatrix <- function(tau) { + d <- ncol(tau) + # get variable names + nms <- colnames(tau) + # construct edge set + E <- cbind(do.call(c, sapply(1:(d-1), function(i) seq.int(i))), + do.call(c, sapply(1:(d-1), function(i) rep(i+1, i)))) + # add edge names + E.names <- apply(E, 1, function(x) paste(nms[x[1]], nms[x[2]], sep = ",")) + # set weights + w <- tau[upper.tri(tau)] + + ## return results + list(V = list(names = nms, + conditionedSet = NULL, + conditioningSet = NULL), + E = list(nums = E, + names = E.names, + weights = w, + conditionedSet = lapply(1:nrow(E), function(i) E[i, ]), + conditioningSet = NULL)) +} + +makeFullGraph <- function(d) { + ## create matrix of all combinations + E <- cbind(do.call(c, lapply(1:(d-1), function(i) rep(i, d-i))), + do.call(c, lapply(1:(d-1), function(i) (i+1):d))) + E <- matrix(E, ncol = 2) + + ## output dummy list with edges set + list(V = list(names = NULL, + conditionedSet = NULL, + conditioningSet = NULL), + E = list(nums = E, + names = NULL, + weights = NULL, + conditionedSet = E, + conditioningSet = NULL)) +} + +adjacencyMatrix <- function(g) { + ## create matrix of all combinations + d <- length(g$V$names) + v.all <- cbind(do.call(c, lapply(1:(d-1), function(i) seq.int(i))), + do.call(c, lapply(1:(d-1), function(i) rep(i+1, i)))) + + ## fnd weight + vals <- apply(v.all, 1, set_weight, E = g$E) + + ## create symmetric matrix of weights + M <- matrix(0, d, d) + M[upper.tri(M)] <- vals + M <- M + t(M) + diag(M) <- Inf + + ## return final matrix + M +} + +set_weight <- function(x, E) { + is.edge <- (x[1] == E$nums[, 1]) & (x[2] == E$nums[, 2]) + if (!any(is.edge)) 1 else (1 - abs(E$weights[which(is.edge)])) +} + + +deleteEdges <- function(g) { + ## reduce edge list + keep <- which(!g$E$todel) + E <- list(nums = matrix(g$E$nums[keep, ], ncol = 2), + names = g$E$names[keep], + weights = g$E$weights[keep], + conditionedSet = g$E$conditionedSet[keep], + conditioningSet = g$E$conditioningSet[keep]) + + ## return reduced graph + list(V = g$V, E = E) +} + Added: pkg/man/RVineStructureSelect2.Rd =================================================================== --- pkg/man/RVineStructureSelect2.Rd (rev 0) +++ pkg/man/RVineStructureSelect2.Rd 2015-08-20 13:41:07 UTC (rev 119) @@ -0,0 +1,145 @@ +\name{RVineStructureSelect} +\alias{RVineStructureSelect} + +\title{Sequential Specification of R- and C-Vine Copula Models} + +\description{ +This function fits either an R- or a C-vine copula model to a d-dimensional copula data set. +Tree structures are determined and appropriate pair-copula families are selected using \code{\link{BiCopSelect}} and estimated sequentially (forward selection of trees). +} + +\usage{ +RVineStructureSelect2(data, familyset = NA, type = 0, selectioncrit = "AIC", + indeptest = FALSE, level = 0.05, trunclevel = NA, + progress = FALSE, weights = NA, rotations = TRUE) +} + +\arguments{ + \item{data}{An N x d data matrix (with uniform margins).} + \item{familyset}{An integer vector of pair-copula families to select from (the independence copula MUST NOT be specified in this vector unless one wants to fit an independence vine!). + The vector has to include at least one pair-copula family that allows for positive and one that allows for negative dependence. Not listed copula families might be included to better handle limit cases. + If \code{familyset = NA} (default), selection among all possible families is performed. + Coding of pair-copula families: \cr + \code{1} = Gaussian copula \cr + \code{2} = Student t copula (t-copula) \cr + \code{3} = Clayton copula \cr + \code{4} = Gumbel copula \cr + \code{5} = Frank copula \cr + \code{6} = Joe copula \cr + \code{7} = BB1 copula \cr + \code{8} = BB6 copula \cr + \code{9} = BB7 copula \cr + \code{10} = BB8 copula \cr + \code{13} = rotated Clayton copula (180 degrees; ``survival Clayton'') \cr + \code{14} = rotated Gumbel copula (180 degrees; ``survival Gumbel'') \cr + \code{16} = rotated Joe copula (180 degrees; ``survival Joe'') \cr + \code{17} = rotated BB1 copula (180 degrees; ``survival BB1'')\cr + \code{18} = rotated BB6 copula (180 degrees; ``survival BB6'')\cr + \code{19} = rotated BB7 copula (180 degrees; ``survival BB7'')\cr + \code{20} = rotated BB8 copula (180 degrees; ``survival BB8'')\cr + \code{23} = rotated Clayton copula (90 degrees) \cr + \code{24} = rotated Gumbel copula (90 degrees) \cr + \code{26} = rotated Joe copula (90 degrees) \cr + \code{27} = rotated BB1 copula (90 degrees) \cr + \code{28} = rotated BB6 copula (90 degrees) \cr + \code{29} = rotated BB7 copula (90 degrees) \cr + \code{30} = rotated BB8 copula (90 degrees) \cr + \code{33} = rotated Clayton copula (270 degrees) \cr + \code{34} = rotated Gumbel copula (270 degrees) \cr + \code{36} = rotated Joe copula (270 degrees) \cr + \code{37} = rotated BB1 copula (270 degrees) \cr + \code{38} = rotated BB6 copula (270 degrees) \cr + \code{39} = rotated BB7 copula (270 degrees) \cr + \code{40} = rotated BB8 copula (270 degrees) \cr + \code{104} = Tawn type 1 copula \cr + \code{114} = rotated Tawn type 1 copula (180 degrees) \cr + \code{124} = rotated Tawn type 1 copula (90 degrees) \cr + \code{134} = rotated Tawn type 1 copula (270 degrees) \cr + \code{204} = Tawn type 2 copula \cr + \code{214} = rotated Tawn type 2 copula (180 degrees) \cr + \code{224} = rotated Tawn type 2 copula (90 degrees) \cr + \code{234} = rotated Tawn type 2 copula (270 degrees) \cr + } + \item{type}{Type of the vine model to be specified:\cr + \code{0} or \code{"RVine"} = R-vine (default)\cr + \code{1} or \code{"CVine"} = C-vine\cr + C- and D-vine copula models with pre-specified order can be specified using \code{CDVineCopSelect} of the package CDVine. + Similarly, R-vine copula models with pre-specified tree structure can be specified using \code{\link{RVineCopSelect}}.} + \item{selectioncrit}{Character indicating the criterion for pair-copula selection. Possible choices: \code{selectioncrit = "AIC"} (default) or \code{"BIC"} (see \code{\link{BiCopSelect}}).} + \item{indeptest}{Logical; whether a hypothesis test for the independence of \code{u1} and \code{u2} is performed before bivariate copula selection + (default: \code{indeptest = FALSE}; see \code{\link{BiCopIndTest}}). + The independence copula is chosen for a (conditional) pair if the null hypothesis of independence cannot be rejected.} + \item{level}{Numerical; significance level of the independence test (default: \code{level = 0.05}).} + \item{trunclevel}{Integer; level of truncation.} + \item{progress}{Logical; whether the tree-wise specification progress is printed (default: \code{progress = FALSE}).} + \item{weights}{Numerical; weights for each observation (opitional).} + \item{rotations}{If \code{TRUE}, all rotations of the families in \code{familyset} are included.} +} + +\details{ +R-vine trees are selected using maximum spanning trees with absolute values of pairwise Kendall's taus as weights, i.e., +the following optimization problem is solved for each tree: +\deqn{ +\max \sum_{edges\ e_{ij}\ in\ spanning\ tree} |\hat{\tau}_{ij}|, +}{ +\max \sum_{edges e_{ij} in spanning tree} |\hat{\tau}_{ij}|, +} +where \eqn{\hat{\tau}_{ij}} denote the pairwise empirical Kendall's taus and a spanning tree is a tree on all nodes. +The setting of the first tree selection step is always a complete graph. +For subsequent trees, the setting depends on the R-vine construction principles, in particular on the proximity condition. + +The root nodes of C-vine trees are determined similarly by identifying the node with strongest dependencies to all other nodes. +That is we take the node with maximum column sum in the empirical Kendall's tau matrix. + +Note that a possible way to determine the order of the nodes in the D-vine is to identify a shortest Hamiltonian path in terms +of weights \eqn{1-|\tau_{ij}|}. +This can be established for example using the package TSP. +Example code is shown below. +} + +\value{ + An \code{\link{RVineMatrix}} object with the selected structure (\code{RVM$Matrix}) and families (\code{RVM$family}) + as well as sequentially estimated parameters stored in \code{RVM$par} and \code{RVM$par2}. +} + +\references{ +Brechmann, E. C., C. Czado, and K. Aas (2012). +Truncated regular vines in high dimensions with applications to financial data. +Canadian Journal of Statistics 40 (1), 68-85. + +Dissmann, J. F., E. C. Brechmann, C. Czado, and D. Kurowicka (2013). +Selecting and estimating regular vine copulae and application to financial returns. +Computational Statistics & Data Analysis, 59 (1), 52-69. +} + +\author{Jeffrey Dissmann, Eike Brechmann, Ulf Schepsmeier} + +\seealso{\code{\link{RVineTreePlot}}, \code{\link{RVineCopSelect}}} + +\examples{ +# load data set +data(daxreturns) + +# select the R-vine structure, families and parameters +# using only the first 4 variables and the first 750 observations +# we allow for the copula families: Gauss, t, Clayton, Gumbel, Frank and Joe +RVM <- RVineStructureSelect(daxreturns[1:750,1:4], c(1:6), progress = TRUE) + +\dontrun{ +# specify a C-vine copula model with only Clayton, Gumbel and Frank copulas (time-consuming) +CVM <- RVineStructureSelect2(daxreturns, c(3,4,5), "CVine") +} + +\dontrun{ +# determine the order of the nodes in a D-vine using the package TSP (time-consuming) +library(TSP) +d <- dim(daxreturns)[2] +M <- 1 - abs(TauMatrix(daxreturns)) +hamilton <- insert_dummy(TSP(M), label = "cut") +sol <- solve_TSP(hamilton, method = "repetitive_nn") +order <- cut_tour(sol, "cut") +DVM <- D2RVine(order, family = rep(0,d*(d-1)/2), par = rep(0, d*(d-1)/2)) +RVineCopSelect(daxreturns, c(1:6), DVM$Matrix) +} +} + From noreply at r-forge.r-project.org Thu Aug 20 17:04:09 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 20 Aug 2015 17:04:09 +0200 (CEST) Subject: [Vinecopula-commits] r120 - pkg/R Message-ID: <20150820150409.2EEAA184C47@r-forge.r-project.org> Author: tnagler Date: 2015-08-20 17:04:08 +0200 (Thu, 20 Aug 2015) New Revision: 120 Modified: pkg/R/RVineStructureSelect2.R Log: * adjust own MST algorithm for full backwards compatibility Modified: pkg/R/RVineStructureSelect2.R =================================================================== --- pkg/R/RVineStructureSelect2.R 2015-08-20 13:41:07 UTC (rev 119) +++ pkg/R/RVineStructureSelect2.R 2015-08-20 15:04:08 UTC (rev 120) @@ -1,7 +1,7 @@ RVineStructureSelect2 <- function(data, familyset = NA, type = 0, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, trunclevel = NA, progress = FALSE, weights = NA, rotations = TRUE) { d <- ncol(data) n <- nrow(data) - + ## sanity checks if (type == 0) type <- "RVine" else if (type == 1) @@ -26,27 +26,27 @@ stop("Selection criterion not implemented.") if (level < 0 & level > 1) stop("Significance level has to be between 0 and 1.") - + ## set variable names and trunclevel if not provided if (is.null(colnames(data))) colnames(data) <- paste0("V", 1:d) if (is.na(trunclevel)) trunclevel <- d - + ## adjust familyset if (trunclevel == 0) familyset <- 0 if (rotations) familyset <- with_rotations(familyset) - + ## initialize object for results RVine <- list(Tree = NULL, Graph = NULL) - + ## estimation in first tree ---------------------------- # find optimal tree g <- initializeFirstGraph2(data, weights) - MST <- findMaximumTauTree2(g,mode = type) - + MST <- findMaximumTauTree2(g, mode = type) + # estimate pair-copulas VineTree <- fit.FirstTreeCopulas2(MST, data, @@ -59,7 +59,7 @@ RVine$Tree[[1]] <- VineTree RVine$Graph[[1]] <- g oldVineGraph <- VineTree - + ## estimation in higher trees -------------------------- for (i in 2:(d - 1)) { # only estimate pair-copulas if not truncated @@ -81,7 +81,7 @@ RVine$Tree[[i]] <- VineTree RVine$Graph[[i]] <- g } - + ## free memory and return results as 'RVineMatrix' object .RVine <- RVine rm(list = ls()) @@ -91,7 +91,7 @@ initializeFirstGraph2 <- function(data.univ, weights) { ## calculate Kendall's tau taus <- TauMatrix(data = data.univ, weights = weights) - + ## return full graph with tau as weights graphFromTauMatrix(taus) } @@ -100,53 +100,60 @@ ## construct adjency matrix A <- adjacencyMatrix(g) d <- ncol(A) - + if (mode == "RVine") { ## initialize tree <- NULL edges <- matrix(NA, d - 1, 2) w <- numeric(d - 1) i <- 1 - + ## construct minimum spanning tree for (k in 1:(d - 1)) { # add selected edge to tree tree <- c(tree, i) - + # find edge with minimal weight m <- apply(as.matrix(A[, tree]), 2, min) - a <- apply(as.matrix(A[, tree]), 2, function(x) order(rank(x)))[1, ] - b <- apply(as.matrix(m), 2, function(x) order(rank(x)))[1] + cnt <- sum(m == min(m)) # count ties + a <- apply(as.matrix(A[, tree]), 2, + function(x) order(rank(x)))[1, ] + b <- order(rank(m))[cnt] j <- tree[b] i <- a[b] - + # store edge and weight edges[k, ] <- c(j, i) w[k] <- A[i, j] - + ## adjust adjecency matrix to prevent loops for (t in tree) A[i, t] <- A[t, i] <- Inf } - + ## reorder edges for backwads compatibility with igraph output edges <- t(apply(edges, 1, function(x) sort(x))) edges <- edges[order(edges[, 2], edges[, 1]), ] - + ## delete unused edges from graph E <- g$E$nums in.tree <- apply(matrix(edges, ncol = 2), 1, function(x) which((x[1] == E[, 1]) & (x[2] == E[, 2]))) + if (is.list(in.tree)) + do.call() + MST <- g g$E$todel <- rep(TRUE, nrow(E)) - g$E$todel[in.tree] <- FALSE - MST <- deleteEdges(g) + if (any(g$E$todel)) { + g$E$todel[in.tree] <- FALSE + MST <- deleteEdges(g) + } } else if (mode == "CVine") { ## set root as vertex with minimal sum of weights A <- adjacencyMatrix(g) diag(A) <- 0 sumtaus <- rowSums(A) root <- which.min(sumtaus) - + ## delete unused edges g$E$todel <- !((g$E$nums[, 2] == root) | (g$E$nums[, 1] == root)) MST <- g @@ -155,7 +162,7 @@ } else { stop("vine not implemented") } - + ## return result MST } @@ -190,11 +197,11 @@ ## fit pair-copulas for the first vine tree fit.FirstTreeCopulas2 <- function(MST, data.univ, type, copulaSelectionBy, testForIndependence, testForIndependence.level, weights = NA) { - + ## initialize estimation results with empty list d <- nrow(MST$E$nums) parameterForACopula <- lapply(1:d, function(i) NULL) - + ## prepare for estimation and store names for (i in 1:d) { ## get edge and corresponding data @@ -203,7 +210,7 @@ parameterForACopula[[i]]$zr2 <- data.univ[, a[2]] MST$E$Copula.Data.1[i] <- list(data.univ[, a[1]]) MST$E$Copula.Data.2[i] <- list(data.univ[, a[2]]) - + ## set names for this edge if (is.null(MST$V$names[a[1]])) { MST$E$Copula.CondName.1[i] <- a[1] @@ -223,7 +230,7 @@ sep = " , ") } } - + ## estimate parameters and select family outForACopula <- lapply(X = parameterForACopula, FUN = wrapper_fit.ACopula, @@ -232,36 +239,36 @@ testForIndependence, testForIndependence.level, weights) - + ## store estimated model and pseudo-obversations for next tree for (i in 1:d) { MST$E$Copula.param[[i]] <- c(outForACopula[[i]]$par, outForACopula[[i]]$par2) MST$E$Copula.type[i] <- outForACopula[[i]]$family MST$E$Copula.out[i] <- list(outForACopula[[i]]) - + MST$E$Copula.CondData.1[i] <- list(outForACopula[[i]]$CondOn.1) MST$E$Copula.CondData.2[i] <- list(outForACopula[[i]]$CondOn.2) } - + ## return results MST } ## fit pair-copulas for vine trees 2,... fit.TreeCopulas2 <- function(MST, oldVineGraph, type, copulaSelectionBy, testForIndependence, testForIndependence.level, progress, weights = NA) { - + ## initialize estimation results with empty list d <- nrow(MST$E$nums) parameterForACopula <- lapply(1:d, function(i) NULL) - - + + ## prepare for estimation for (i in 1:d) { ## get edge and corresponding data con <- MST$E$nums[i, ] temp <- oldVineGraph$E$nums[con, ] - + ## fetch corresponding data and names if ((temp[1, 1] == temp[2, 1]) || (temp[1, 2] == temp[2, 1])) { same <- temp[2, 1] @@ -270,7 +277,7 @@ same <- temp[2, 2] } } - + if (temp[1, 1] == same) { zr1 <- oldVineGraph$E$Copula.CondData.2[con[1]] n1 <- oldVineGraph$E$Copula.CondName.2[con[1]] @@ -285,7 +292,7 @@ zr2 <- oldVineGraph$E$Copula.CondData.1[con[2]] n2 <- oldVineGraph$E$Copula.CondName.1[con[2]] } - + if (is.list(zr1)) { zr1a <- as.vector(zr1[[1]]) zr2a <- as.vector(zr2[[1]]) @@ -297,20 +304,20 @@ n1a <- n1 n2a <- n2 } - + if (progress == TRUE) message(n1a, " + ", n2a, " --> ", MST$E$names[i]) - + parameterForACopula[[i]]$zr1 <- zr1a parameterForACopula[[i]]$zr2 <- zr2a - + MST$E$Copula.Data.1[i] <- list(zr1a) MST$E$Copula.Data.2[i] <- list(zr2a) - + MST$E$Copula.CondName.1[i] <- n1a MST$E$Copula.CondName.2[i] <- n2a } - + ## estimate parameters and select family outForACopula <- lapply(X = parameterForACopula, FUN = wrapper_fit.ACopula, @@ -319,58 +326,58 @@ testForIndependence, testForIndependence.level, weights) - + ## store estimated model and pseudo-obversations for next tree for (i in 1:d) { MST$E$Copula.param[[i]] <- c(outForACopula[[i]]$par, outForACopula[[i]]$par2) MST$E$Copula.type[i] <- outForACopula[[i]]$family MST$E$Copula.out[i] <- list(outForACopula[[i]]) - + MST$E$Copula.CondData.1[i] <- list(outForACopula[[i]]$CondOn.1) MST$E$Copula.CondData.2[i] <- list(outForACopula[[i]]$CondOn.2) } - + ## return results MST } ## initialize graph for next vine tree (possible edges) buildNextGraph2 <- function(oldVineGraph, weights = NA) { - + d <- nrow(oldVineGraph$E$nums) - + ## initialize with full graph g <- makeFullGraph(d) g$V$names <- oldVineGraph$E$names g$V$conditionedSet <- oldVineGraph$E$conditionedSet g$V$conditioningSet <- oldVineGraph$E$conditioningSet - + ## get info for all edges out <- lapply(1:nrow(g$E$nums), getEdgeInfo2, g = g, oldVineGraph = oldVineGraph, weights = weights) - + ## annotate graph (same order as in old version of this function) g$E$weights <- sapply(out, function(x) x$tau) g$E$names <- sapply(out, function(x) x$name) g$E$conditionedSet <- lapply(out, function(x) x$nedSet) g$E$conditioningSet <- lapply(out, function(x) x$ningSet) g$E$todel <- sapply(out, function(x) x$todel) - + ## delete edges that are prohibited by the proximity condition deleteEdges(g) } ## function for obtaining edge information getEdgeInfo2 <- function(i, g, oldVineGraph, weights) { - + ## get edge con <- g$E$nums[i, ] temp <- oldVineGraph$E$nums[con, ] - + ## check for proximity condition ok <- FALSE if ((temp[1, 1] == temp[2, 1]) || (temp[1, 2] == temp[2, 1])) { @@ -382,11 +389,11 @@ same <- temp[2, 2] } } - + ## dummy output tau <- nedSet <- ningSet <- name <- NA todel <- TRUE - + # info if proximity condition is fulfilled ... if (ok) { ## get data @@ -407,15 +414,15 @@ zr1a <- zr1 zr2a <- zr2 } - + ## calculate Kendall's tau keine_nas <- !(is.na(zr1a) | is.na(zr2a)) tau <- fasttau(zr1a[keine_nas], zr2a[keine_nas], weights) - + ## get names name.node1 <- strsplit(g$V$names[con[1]], split = " *[,;] *")[[1]] name.node2 <- strsplit(g$V$names[con[2]], split = " *[,;] *")[[1]] - + ## infer conditioned set and conditioning set l1 <- c(g$V$conditionedSet[[con[1]]], g$V$conditioningSet[[con[1]]]) @@ -423,7 +430,7 @@ g$V$conditioningSet[[con[2]]]) nedSet <- c(setdiff(l1, l2), setdiff(l2, l1)) ningSet <- intersect(l1, l2) - + ## set edge name nmdiff <- c(setdiff(name.node1, name.node2), setdiff(name.node2, name.node1)) @@ -431,11 +438,11 @@ name <- paste(paste(nmdiff, collapse = ","), paste(nmsect, collapse = ","), sep = " ; ") - + ## mark as ok todel <- FALSE } - + ## return edge information list(tau = tau, nedSet = nedSet, @@ -455,7 +462,7 @@ ## bivariate copula selection fit.ACopula <- function(u1, u2, familyset = NA, selectioncrit = "AIC", indeptest = FALSE, level = 0.05, weights = NA) { - + ## select family and estimate parameter(s) for the pair copula out <- BiCopSelect(u1, u2, familyset, @@ -464,21 +471,21 @@ level, weights = weights, rotations = FALSE) - + ## change rotation if family is not symmetric wrt the main diagonal if (out$family %in% c(23, 24, 26:30, 124, 224)) { out$family <- out$family + 10 } else if (out$family %in% c(33, 34, 36:40, 134, 234)) { out$family <- out$family - 10 } - + ## tawn copulas also have to change type if (out$family%/%100 == 1) { out$family <- out$family + 100 } else if (out$family%/%200 == 1) { out$family <- out$family - 100 } - + ## store pseudo-observations for estimation in next tree out$CondOn.1 <- .C("Hfunc1", as.integer(out$family), @@ -498,14 +505,14 @@ as.double(out$par2), as.double(rep(0, length(u1))), PACKAGE = "VineCopula")[[7]] - + ## return results out } ## build R-Vine matrix object based on nested set of trees as.RVM2 <- function(RVine) { - + ## initialize objects n <- length(RVine$Tree) + 1 con <- list() @@ -513,7 +520,7 @@ nedSets <- list() crspParams <- list() crspTypes <- list() - + ## get selected pairs, families and estimated parameters for (k in 1:(n - 2)) { nedSets[[k]] <- RVine$Tree[[k]]$E$conditionedSet @@ -527,24 +534,24 @@ } else { nedSets[[n - 1]] <- list(RVine$Tree[[n - 1]]$E$conditionedSet) } - + ## initialize matrices for RVineMatrix object Param <- array(dim = c(n, n)) Params2 <- array(0, dim = c(n, n)) Type <- array(dim = c(n, n)) M <- matrix(NA, n, n) - + ## store structure, families and parameters in matrices for (k in 1:(n - 1)) { w <- nedSets[[n - k]][[1]][1] - + M[k, k] <- w M[(k + 1), k] <- nedSets[[n - k]][[1]][2] - + Param[(k + 1), k] <- crspParams[[n - k]][[1]][1] Params2[(k + 1), k] <- crspParams[[n - k]][[1]][2] Type[(k + 1), k] <- crspTypes[[n - k]][[1]] - + if (k == (n - 1)) { M[(k + 1), (k + 1)] <- nedSets[[n - k]][[1]][2] } else { @@ -582,11 +589,11 @@ } } } - + ## clean NAs M[is.na(M)] <- 0 Type[is.na(Type)] <- 0 - + ## return RVineMatrix object RVineMatrix(M, family = Type, par = Param, par2 = Params2, names = nam) } @@ -604,7 +611,7 @@ E.names <- apply(E, 1, function(x) paste(nms[x[1]], nms[x[2]], sep = ",")) # set weights w <- tau[upper.tri(tau)] - + ## return results list(V = list(names = nms, conditionedSet = NULL, @@ -621,7 +628,7 @@ E <- cbind(do.call(c, lapply(1:(d-1), function(i) rep(i, d-i))), do.call(c, lapply(1:(d-1), function(i) (i+1):d))) E <- matrix(E, ncol = 2) - + ## output dummy list with edges set list(V = list(names = NULL, conditionedSet = NULL, @@ -638,23 +645,23 @@ d <- length(g$V$names) v.all <- cbind(do.call(c, lapply(1:(d-1), function(i) seq.int(i))), do.call(c, lapply(1:(d-1), function(i) rep(i+1, i)))) - + ## fnd weight vals <- apply(v.all, 1, set_weight, E = g$E) - + ## create symmetric matrix of weights M <- matrix(0, d, d) M[upper.tri(M)] <- vals M <- M + t(M) diag(M) <- Inf - + ## return final matrix M } set_weight <- function(x, E) { is.edge <- (x[1] == E$nums[, 1]) & (x[2] == E$nums[, 2]) - if (!any(is.edge)) 1 else (1 - abs(E$weights[which(is.edge)])) + if (!any(is.edge)) Inf else (1 - abs(E$weights[which(is.edge)])) } From noreply at r-forge.r-project.org Fri Aug 21 13:40:31 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 21 Aug 2015 13:40:31 +0200 (CEST) Subject: [Vinecopula-commits] r121 - pkg/src Message-ID: <20150821114031.C5A9A18427F@r-forge.r-project.org> Author: etobi Date: 2015-08-21 13:40:31 +0200 (Fri, 21 Aug 2015) New Revision: 121 Modified: pkg/src/likelihood.c Log: Small bug fix in log-likelihood for families 3, 4, 7, 17 Modified: pkg/src/likelihood.c =================================================================== --- pkg/src/likelihood.c 2015-08-20 15:04:08 UTC (rev 120) +++ pkg/src/likelihood.c 2015-08-21 11:40:31 UTC (rev 121) @@ -896,7 +896,7 @@ { dat[0] = u[j]; dat[1] = v[j]; f=log1p(*theta)-(1.0+*theta)*log(dat[0]*dat[1])-(2.0+1.0/(*theta))*log(pow(dat[0],-*theta)+pow(dat[1],-*theta)-1.0); - if(f>XINFMAX) ll += XINFMAX; + if(f>XINFMAX) ll += log(XINFMAX); else if(fXINFMAX) ll += XINFMAX; + if(f>XINFMAX) ll += log(XINFMAX); else if(fXINFMAX) ll += XINFMAX; + if(f>XINFMAX) ll += log(XINFMAX); else if(fXINFMAX) ll += XINFMAX; + if(f>XINFMAX) ll += log(XINFMAX); else if(f Author: tnagler Date: 2015-08-24 12:50:15 +0200 (Mon, 24 Aug 2015) New Revision: 122 Modified: pkg/R/BiCopEst.r pkg/R/BiCopPar2Tau.r pkg/R/BiCopTau2Par.r Log: * faster implementation of par<->tau conversion for Frank copula * check input whether tau \in (-1,1) (BiCopTau2Par) Modified: pkg/R/BiCopEst.r =================================================================== --- pkg/R/BiCopEst.r 2015-08-21 11:40:31 UTC (rev 121) +++ pkg/R/BiCopEst.r 2015-08-24 10:50:15 UTC (rev 122) @@ -365,17 +365,10 @@ a <- -1 tau <- -tau } - f <- function(x) { - x/(exp(x) - 1) - } - tauF <- function(x) 1 - 4/x + 4/x^2 * integrate(f, - lower = 0 + .Machine$double.eps^0.5, - upper = x)$value - v <- uniroot(function(x) tau - tauF(x), - lower = 0, - upper = 500, + v <- uniroot(function(x) tau - (1 - 4/x + 4/x * debye1(x)), + lower = 0 + .Machine$double.eps^0.5, upper = 5e5, tol = .Machine$double.eps^0.5)$root - return(a * v) + return(a*v) } Modified: pkg/R/BiCopPar2Tau.r =================================================================== --- pkg/R/BiCopPar2Tau.r 2015-08-21 11:40:31 UTC (rev 121) +++ pkg/R/BiCopPar2Tau.r 2015-08-24 10:50:15 UTC (rev 122) @@ -58,14 +58,7 @@ } else if (family == 4 || family == 14) { tau <- 1 - 1/par } else if (family == 5) { - f <- function(x) x/(exp(x) - 1) - fu <- function(x) integrate(f, lower = 0, upper = x)$value - fl <- function(x) integrate(f, lower = x, upper = 0)$value - if (any(par > 0)) { - tau <- 1 - 4/par + 4/par^2 * sapply(par, fu) - } else { - tau <- 1 - 4/par - 4/par^2 * sapply(par, fl) - } + tau <- 1 - 4/par + 4/par * debye1(par) } else if (family == 6 || family == 16) { # tau = 1 + 4/par^2 * integrate(function(x) log(x)*x*(1-x)^(2*(1-par)/par), 0, # 1)$value Modified: pkg/R/BiCopTau2Par.r =================================================================== --- pkg/R/BiCopTau2Par.r 2015-08-21 11:40:31 UTC (rev 121) +++ pkg/R/BiCopTau2Par.r 2015-08-24 10:50:15 UTC (rev 122) @@ -1,4 +1,7 @@ BiCopTau2Par <- function(family, tau) { + ## sanity check + if (any(abs(tau) > 0.99999)) + stop("some tau is too close to -1 or 1") ## adjust length for input vectors; stop if not matching n <- max(length(family), length(tau)) From noreply at r-forge.r-project.org Mon Aug 24 18:46:34 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 24 Aug 2015 18:46:34 +0200 (CEST) Subject: [Vinecopula-commits] r123 - pkg/R Message-ID: <20150824164634.7F216186949@r-forge.r-project.org> Author: tnagler Date: 2015-08-24 18:46:34 +0200 (Mon, 24 Aug 2015) New Revision: 123 Modified: pkg/R/BiCopEst.r Log: * faster implementation of tau->par conversion for Joe copula Modified: pkg/R/BiCopEst.r =================================================================== --- pkg/R/BiCopEst.r 2015-08-24 10:50:15 UTC (rev 122) +++ pkg/R/BiCopEst.r 2015-08-24 16:46:34 UTC (rev 123) @@ -372,14 +372,16 @@ } - Joe.itau.JJ <- function(tau) { if (tau < 0) { return(1.000001) } else { - tauF <- function(a) { - # euler=0.5772156649015328606 1+((-2+2*euler+2*log(2)+digamma(1/a)+digamma(1/2*(2+a)/a)+a)/(-2+a)) - 1 + 4/a^2 * integrate(function(x) log(x) * x * (1 - x)^(2 * (1 - a)/a), 0, 1)$value + tauF <- function(par) { + param1 <- 2/par + 1 + tem <- digamma(2) - digamma(param1) + tau <- 1 + tem * 2/(2 - par) + tau[par == 2] <- 1 - trigamma(2) + tau } v <- uniroot(function(x) tau - tauF(x), From noreply at r-forge.r-project.org Mon Aug 24 18:47:02 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 24 Aug 2015 18:47:02 +0200 (CEST) Subject: [Vinecopula-commits] r124 - pkg/R Message-ID: <20150824164702.9D0AB184B29@r-forge.r-project.org> Author: tnagler Date: 2015-08-24 18:47:02 +0200 (Mon, 24 Aug 2015) New Revision: 124 Modified: pkg/R/BiCopName.r Log: * vectorized BiCopName Modified: pkg/R/BiCopName.r =================================================================== --- pkg/R/BiCopName.r 2015-08-24 16:46:34 UTC (rev 123) +++ pkg/R/BiCopName.r 2015-08-24 16:47:02 UTC (rev 124) @@ -1,7 +1,10 @@ BiCopName <- function(family, short = TRUE) { if (is.logical(short) == FALSE) stop("'short' has to be a logical variable.") - + sapply(family, fam_name, short = short) +} + +fam_name <- function(family, short) { fam <- NA if (is.numeric(family)) { @@ -284,5 +287,6 @@ } if (is.na(fam)) stop("Family not implemented.") - return(fam) + + fam } \ No newline at end of file From noreply at r-forge.r-project.org Mon Aug 24 21:58:54 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 24 Aug 2015 21:58:54 +0200 (CEST) Subject: [Vinecopula-commits] r125 - pkg/R Message-ID: <20150824195854.99AEE185F1C@r-forge.r-project.org> Author: tnagler Date: 2015-08-24 21:58:54 +0200 (Mon, 24 Aug 2015) New Revision: 125 Modified: pkg/R/BiCopName.r Log: * fix BicopName for numeric input; added english comments Modified: pkg/R/BiCopName.r =================================================================== --- pkg/R/BiCopName.r 2015-08-24 16:47:02 UTC (rev 124) +++ pkg/R/BiCopName.r 2015-08-24 19:58:54 UTC (rev 125) @@ -1,16 +1,14 @@ BiCopName <- function(family, short = TRUE) { - if (is.logical(short) == FALSE) - stop("'short' has to be a logical variable.") + stopifnot(is.logical(short)) sapply(family, fam_name, short = short) } fam_name <- function(family, short) { fam <- NA - + ## get family name given a number if (is.numeric(family)) { - # Zahl zu Name if (short == TRUE) { - # kurzer Name + ## short name if (family == 0) fam <- "I" if (family == 1) @@ -76,7 +74,7 @@ if (family == 40) fam <- "BB8_270" if (family == 100) - fam <- "NP" #changed Mathias + fam <- "NP" if (family == 41) fam <- "1-par AS" if (family == 51) @@ -102,7 +100,7 @@ if (family == 234) fam <- "Tawn2_270" } else { - # langer Name + ## long names if (family == 0) fam <- "Independence" if (family == 1) @@ -195,7 +193,7 @@ fam <- "Rotated Tawn type 2 270 degrees" } } else { - # Name zu Zahl + ## get family number given a name if (family == "I" || family == "Independence") fam <- 0 if (family == "N" || family == "Gaussian") @@ -259,7 +257,7 @@ if (family == "BB8_270" || family == "Rotated Joe-Frank 270 degrees") fam <- 40 if (family == "NP" || family == "Nonparametric") - fam <- 100 #changed Mathias + fam <- 100 if (family == "1-par AS" || family == "1-parametric asymmetric") fam <- 41 if (family == "1-par AS180" || family == "Rotated 1-parametric asymmetric 180 degree") @@ -289,4 +287,4 @@ stop("Family not implemented.") fam -} \ No newline at end of file +} From noreply at r-forge.r-project.org Mon Aug 24 22:03:27 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 24 Aug 2015 22:03:27 +0200 (CEST) Subject: [Vinecopula-commits] r126 - in pkg: . R man Message-ID: <20150824200327.68E3F185F1C@r-forge.r-project.org> Author: tnagler Date: 2015-08-24 22:03:25 +0200 (Mon, 24 Aug 2015) New Revision: 126 Added: pkg/R/plot.RVineMatrix.R pkg/man/plot.RVineMatrix.Rd Modified: pkg/DESCRIPTION pkg/NAMESPACE Log: * add 'network' package to imports * new generic for plot.RVineMatrix based on 'plot.network' (+ manual) Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2015-08-24 19:58:54 UTC (rev 125) +++ pkg/DESCRIPTION 2015-08-24 20:03:25 UTC (rev 126) @@ -1,13 +1,13 @@ -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 -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 +Depends: R (>= 2.11.0) +Imports: graphics, grDevices, stats, utils, MASS, mvtnorm, igraph (>= 1.0.0), network, 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/NAMESPACE =================================================================== --- pkg/NAMESPACE 2015-08-24 19:58:54 UTC (rev 125) +++ pkg/NAMESPACE 2015-08-24 20:03:25 UTC (rev 126) @@ -1,14 +1,19 @@ -import("graphics") -import("grDevices") -import("stats") -import("utils") import(MASS) import(mvtnorm) import(copula) import(methods) import(lattice) +import(network) -importFrom(ADGofTest, ad.test) +importFrom("grDevices", "colorRampPalette", "rgb", "terrain.colors") +importFrom("graphics", "abline", "box", "hist", "legend", "lines", + "pairs", "par", "points", "strwidth", "text") +importFrom("stats", "cor", "dexp", "dgamma", "dnorm", "dt", + "integrate", "ks.test", "optim", "optimize", "pbinom", + "pchisq", "pexp", "pgamma", "pnorm", "pt", "qexp", "qgamma", + "qnorm", "qt", "runif", "uniroot", "var") +importFrom("utils", "combn", "getFromNamespace", "modifyList") +importFrom("ADGofTest", "ad.test") importFrom("igraph", "E", "E<-", "V", "V<-", "as_adjacency_matrix", "as_edgelist", "delete_edges", "ends", "graph_from_adjacency_matrix", "graph_from_edgelist", "gsize", "layout_in_circle", "layout_with_graphopt", @@ -110,5 +115,6 @@ S3method(as.copuladata, list) S3method(pairs, copuladata) S3method(plot, BiCop) +S3method(plot, RVineMatrix) useDynLib("VineCopula") Added: pkg/R/plot.RVineMatrix.R =================================================================== --- pkg/R/plot.RVineMatrix.R (rev 0) +++ pkg/R/plot.RVineMatrix.R 2015-08-24 20:03:25 UTC (rev 126) @@ -0,0 +1,263 @@ +plot.RVineMatrix <- function(x, tree = "ALL", type = 0, edge.labels = NULL, interactive = FALSE, ...) { + M <- x$Matrix + d <- nrow(M) + + ## sanity checks + if (!inherits(x, "RVineMatrix")) + stop("'x' has to be an RVineMatrix object.") + if (tree != "ALL" && tree > d - 1) + stop("Selected tree does not exist.") + if (any(tree == "ALL") ) + tree <- 1:(d - 1) + if (!all(type %in% c(0, 1, 2))) + stop("type not implemented") + stopifnot(is.logical(interactive)) + + ## set names if empty + if (is.null(x$names)) + x$names <- paste("V", 1:d, sep = "") + + #### set up plotting options ---------------------------- + ## defaults (to be improved) + dflt <- list(interactive = interactive, + displaylabels = TRUE, + pad = 1e-1, + boxed.labels = TRUE, + label.pos = 7, + label.pad = 0.5) + + ## overwrite defaults with ... argument + lst <- list(...) + final.args <- modifyList(dflt, lst) + + #### loop through the trees ----------------------------- + for (i in tree) { + + ## create network object + g <- makeNetwork(x, i, !(type %in% c(0, 2))) + final.args$x = g$nw + + ## set edge labels + if (!is.null(edge.labels)) + final.args$edge.label <- set_edge_labels(tree = i, + RVM = x, + edge.labels = edge.labels, + type = type) + + ## plot tree + main <- paste("Tree ", i, sep = "") + do.call(plot, final.args) + + ## add legend + if (type == 2) { + legend("bottomleft", legend = paste(1:d, x$name, sep = "<->"), + bty = "n", xjust = 0) + } + + ## wait for key stroke + if (i != max(tree)) { + par(ask = TRUE) + } else { + par(ask = FALSE) + } + } +} + +## creates a network object for a tree in a given RVineMatrix ------------------ +makeNetwork <- function(RVM, tree, use.names = FALSE) { + M <- RVM$Matrix + d <- ncol(M) + + I <- matrix(0, d - tree + 1, d - tree + 1) + + ## extract node and edge labels as numbers + if (tree > 1) { + node.lab <- sapply(1:(d - tree + 1), + get_num, + tree = tree - 1, + RVM = RVM) + } else { + node.lab <- paste(diag(M)) + } + edge.lab <- sapply(seq.int(d - tree), + get_num, + tree = tree, + RVM = RVM) + + ## convert to numeric matrices V and E + V <- t(sapply(strsplit(node.lab, " *[,;] *"), as.numeric)) + V <- matrix(V, ncol = tree) + E <- t(sapply(strsplit(edge.lab, " *[,;] *"), as.numeric)) + + ## build incident matrix by matching V and E + for (i in 1:nrow(E)) { + ind.i <- which(apply(V, 1, function(x) all(x %in% E[i, ]))) + I[ind.i[1], ind.i[2]] <- I[ind.i[1], ind.i[2]] <- 1 + } + + ## convert to variable names (if asked for) + if (use.names) { + if (tree > 1) { + node.lab <- sapply(1:(d - tree + 1), + get_name, + tree = tree - 1, + RVM = RVM) + } else { + node.lab <- RVM$names + } + } + + ## create network + colnames(I) <- rownames(I) <- node.lab + nw <- network(I, directed = FALSE) + + ## return network and labels + list(nw = nw, vlabs = node.lab) +} + +## finds appropriate edge labels for the plot ---------------------------------- +set_edge_labels <- function(tree, RVM, edge.labels, type) { + d <- nrow(RVM$Matrix) + if (edge.labels[1] == "family") { + elabel <- sapply(1:(d - tree + 1), + get_family, + tree = tree, + RVM = RVM) + elabel <- BiCopName(as.numeric(elabel)) + } else if (edge.labels[1] == "par") { + elabel <- sapply(1:(d - tree + 1), + get_par, + tree = tree, + RVM = RVM) + } else if (edge.labels[1] == "tau") { + elabel <- sapply(1:(d - tree + 1), + get_tau, + tree = tree, + RVM = RVM) + } else if (edge.labels[1] == "family-par") { + elabel1 <- sapply(1:(d - tree + 1), + get_family, + tree = tree, + RVM = RVM) + elabel1 <- BiCopName(as.numeric(elabel1)) + elabel2 <- sapply(1:(d - tree + 1), + get_par, + tree = tree, + RVM = RVM) + elabel <- paste0(elabel1, "(", elabel2, ")") + elabel <- sapply(elabel, + function(x){ + tmp <- gsub("((", "(", x, fixed = TRUE) + gsub("))", ")", tmp, fixed = TRUE) + }) + } else if (edge.labels[1] == "family-tau") { + elabel1 <- sapply(1:(d - tree + 1), + get_family, + tree = tree, + RVM = RVM) + elabel1 <- BiCopName(as.numeric(elabel1)) + elabel2 <- sapply(1:(d - tree + 1), + get_tau, + tree = tree, + RVM = RVM) + elabel <- paste0(elabel1, "(", elabel2, ")") + } else if (length(edge.labels) > 1) { + # user may provide own labels + if (length(edge.labels) == d - tree) { + elabel <- as.character(edge.labels) + } else { + stop("length of edge.labels does not equal the number of edges in the tree") + } + } else if (edge.labels[1] == "pair"){ + if (type %in% c(0, 2)) { + elabel <- sapply(1:(d - tree + 1), + get_num, + tree = tree, + RVM = RVM) + } else { + elabel <- sapply(1:(d - tree + 1), + get_name, + tree = tree, + RVM = RVM) + } + } else { + stop("edge.labels not implemented") + } + + elabel +} + +get_num <- function(j, tree, RVM) { + M <- RVM$Matrix + d <- nrow(M) + # get numbers from structure matrix + nums <- as.character(M[c(j, (d - tree + 1):d), j]) + # conditioned set + bef <- paste(nums[2], + nums[1], + sep = ",", + collapse = "") + # conditioning set + aft <- if (length(nums) > 2) { + gsub(" ", + ",", + do.call(paste, as.list(as.character(nums[3:length(nums)])))) + } else "" + # paste together + sep <- if (length(nums) > 2) " ; " else "" + paste(bef, aft, sep = sep, collapse = "") +} + +get_name <- function(j, tree, RVM) { + M <- RVM$Matrix + d <- nrow(M) + # variable names + nams <- RVM$names[M[c(j, (d - tree + 1):d), j]] + # conditioned set + bef <- paste(nams[2], + nams[1], + sep = ",", + collapse = "") + # conditioning set + aft <- if (length(nams) > 2) { + gsub(" ", ",", do.call(paste, as.list(nams[3:length(nams)]))) + } else "" + # paste together + sep <- if (length(nams) > 2) " ; " else "" + paste(bef, aft, sep = sep, collapse = "") +} + +get_family <- function(j, tree, RVM) { + d <- nrow(RVM$family) + M <- RVM$Matrix + paste(RVM$family[M[d - tree + 1, j]]) +} + +get_par <- function(j, tree, RVM) { + d <- nrow(RVM$family) + M <- RVM$Matrix + # get parameters + par <- round(RVM$par[M[d - tree + 1, j]], digits = 2) + par2 <- round(RVM$par2[M[d - tree + 1, j]], digits = 2) + # add brackets if par2 != 0 + apply(cbind(par, par2), 1, join_par) +} + +join_par <- function(x) { + if (x[2] != 0) + return(paste0("(", x[1], ",", x[2], ")")) + x[1] +} + +get_tau <- function(j, tree, RVM) { + d <- nrow(RVM$family) + M <- RVM$Matrix + # get family and parameters + family <- RVM$family[M[d - tree + 1, j]] + par <- RVM$par[M[d - tree + 1, j]] + par2 <- RVM$par2[M[d - tree + 1, j]] + # convert to Kendall's tau + tau <- BiCopPar2Tau(family, par, par2, check.pars = FALSE) + round(tau, digits = 2) +} + Added: pkg/man/plot.RVineMatrix.Rd =================================================================== --- pkg/man/plot.RVineMatrix.Rd (rev 0) +++ pkg/man/plot.RVineMatrix.Rd 2015-08-24 20:03:25 UTC (rev 126) @@ -0,0 +1,75 @@ +\name{plot.RVineMatrix} +\alias{plot.RVineMatrix} +%- Also NEED an '\alias' for EACH other topic documented here. +\title{ +Plotting \code{RVineMatrix} objects. +} +\description{ +This function plots one or all trees of a given R-vine copula model. Edges can be labeld with information about the corresponding pair-copula. +} +\usage{ +\method{plot}{RVineMatrix}(x, tree = "ALL", type = 0, edge.labels = NULL, interactive = FALSE, ...) +} +%- maybe also 'usage' for other objects documented here. +\arguments{ + \item{x}{\code{RVineMatrix} object.} + \item{tree}{\code{"ALL"} or integer vector; specifies which trees are plotted.} + \item{type}{integer; specifies how to make use of variable names: \cr + \code{0} = variable names are ignored, \cr + \code{1} = variable names are used to annotate vertices, \cr + \code{2} = uses numbers in plot and adds a legend for variable names.} + \item{edge.labels}{character; either a vector of edge labels + or one of the following: \cr + \code{"family"} = pair-copula family abbreviation (see \code{\link[VineCopula:BiCopName]{BiCopName}}), \cr + \code{"par"} = pair-copula parameters, \cr + \code{"tau"} = pair-copula Kendall's tau (by conversion of parameters) \cr + \code{"family-par"} = pair-copula family and parameters \cr + \code{"family-tau"} = pair-copula family and Kendall's tau. + } + \item{interactive}{logical; if TRUE, the user is asked to adjust the positioning of + vertices with his mouse.} + \item{\dots}{ +Arguments passed to \code{\link[network:plot.network]{plot.network}}. +} +} +\author{ +Thomas Nagler +} + + +%% ~Make other sections like Warning with \section{Warning }{....} ~ + +\seealso{ +\code{\link[VineCopula:RVineMatrix]{RVineMatrix}}, +\code{\link[network:plot.network]{plot.network}} +\code{\link[VineCopula:BiCopName]{BiCopName}} +} +\examples{ +## build vine model +strucmat <- matrix(c(3,1,2,0,2,1,0,0,1),3,3) +fammat <- matrix(c(0,1,6,0,0,3,0,0,0),3,3) +parmat <- matrix(c(0,0.3,3,0,0,1,0,0,0),3,3) +par2mat <- matrix(c(0,0,0,0,0,0,0,0,0),3,3) +RVM <- RVineMatrix(Matrix=strucmat, family=fammat, par=parmat, par2=par2mat) + +# plot trees +plot(RVM) + +## build new model +# simulate from previous model +u <- RVineSim(500, RVM) +colnames(u) <- c("A", "B", "C") + +# estimate new model +RVM2 <- RVineStructureSelect(u) + +# plot new model with variable names ... +plot(RVM2, type = 1) + +# annotate edge with pair-copula family and parameter +plot(RVM2, type = 1, edge.labels = "family-par") + +} +% Add one or more standard keywords, see file 'KEYWORDS' in the +% R documentation directory. +\keyword{plot} \ No newline at end of file From noreply at r-forge.r-project.org Mon Aug 24 22:04:46 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 24 Aug 2015 22:04:46 +0200 (CEST) Subject: [Vinecopula-commits] r127 - in pkg: R man Message-ID: <20150824200446.A766F185F1C@r-forge.r-project.org> Author: tnagler Date: 2015-08-24 22:04:45 +0200 (Mon, 24 Aug 2015) New Revision: 127 Modified: pkg/R/RVineStructureSelect2.R pkg/man/RVineStructureSelect2.Rd Log: * fix bug in code and manual for RVineStructureSelect2 Modified: pkg/R/RVineStructureSelect2.R =================================================================== --- pkg/R/RVineStructureSelect2.R 2015-08-24 20:03:25 UTC (rev 126) +++ pkg/R/RVineStructureSelect2.R 2015-08-24 20:04:45 UTC (rev 127) @@ -115,10 +115,9 @@ # find edge with minimal weight m <- apply(as.matrix(A[, tree]), 2, min) - cnt <- sum(m == min(m)) # count ties a <- apply(as.matrix(A[, tree]), 2, function(x) order(rank(x)))[1, ] - b <- order(rank(m))[cnt] + b <- order(rank(m))[1] j <- tree[b] i <- a[b] Modified: pkg/man/RVineStructureSelect2.Rd =================================================================== --- pkg/man/RVineStructureSelect2.Rd 2015-08-24 20:03:25 UTC (rev 126) +++ pkg/man/RVineStructureSelect2.Rd 2015-08-24 20:04:45 UTC (rev 127) @@ -1,5 +1,5 @@ -\name{RVineStructureSelect} -\alias{RVineStructureSelect} +\name{RVineStructureSelect2} +\alias{RVineStructureSelect2} \title{Sequential Specification of R- and C-Vine Copula Models} From noreply at r-forge.r-project.org Mon Aug 24 22:10:56 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 24 Aug 2015 22:10:56 +0200 (CEST) Subject: [Vinecopula-commits] r128 - pkg/R Message-ID: <20150824201056.8D29618558F@r-forge.r-project.org> Author: tnagler Date: 2015-08-24 22:10:56 +0200 (Mon, 24 Aug 2015) New Revision: 128 Modified: pkg/R/BiCopEst.r Log: * increased upper limit for uniroot in Joe.itau.JJ Modified: pkg/R/BiCopEst.r =================================================================== --- pkg/R/BiCopEst.r 2015-08-24 20:04:45 UTC (rev 127) +++ pkg/R/BiCopEst.r 2015-08-24 20:10:56 UTC (rev 128) @@ -386,7 +386,7 @@ v <- uniroot(function(x) tau - tauF(x), lower = 1, - upper = 500, + upper = 5e5, tol = .Machine$double.eps^0.5)$root return(v) } From noreply at r-forge.r-project.org Fri Aug 28 19:01:08 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 28 Aug 2015 19:01:08 +0200 (CEST) Subject: [Vinecopula-commits] r129 - in pkg: . R man Message-ID: <20150828170108.7DCDD187A25@r-forge.r-project.org> Author: tnagler Date: 2015-08-28 19:01:07 +0200 (Fri, 28 Aug 2015) New Revision: 129 Modified: pkg/NAMESPACE pkg/R/plot.BiCop.R pkg/R/plot.RVineMatrix.R pkg/man/plot.RVineMatrix.Rd Log: * improved aesthetics of plot.RVineMatrix * new generic contour.RVineMatrix * minor adjustments to levels/xylim defaults in plot.BiCop Modified: pkg/NAMESPACE =================================================================== --- pkg/NAMESPACE 2015-08-24 20:10:56 UTC (rev 128) +++ pkg/NAMESPACE 2015-08-28 17:01:07 UTC (rev 129) @@ -5,9 +5,10 @@ import(lattice) import(network) -importFrom("grDevices", "colorRampPalette", "rgb", "terrain.colors") +importFrom("grDevices", "colorRampPalette", "rgb", "terrain.colors", "col2rgb") importFrom("graphics", "abline", "box", "hist", "legend", "lines", - "pairs", "par", "points", "strwidth", "text") + "pairs", "par", "points", "strwidth", "text", + "plot.new", "polygon", "strheight") importFrom("stats", "cor", "dexp", "dgamma", "dnorm", "dt", "integrate", "ks.test", "optim", "optimize", "pbinom", "pchisq", "pexp", "pgamma", "pnorm", "pt", "qexp", "qgamma", @@ -116,5 +117,6 @@ S3method(pairs, copuladata) S3method(plot, BiCop) S3method(plot, RVineMatrix) +S3method(contour, RVineMatrix) useDynLib("VineCopula") Modified: pkg/R/plot.BiCop.R =================================================================== --- pkg/R/plot.BiCop.R 2015-08-24 20:10:56 UTC (rev 128) +++ pkg/R/plot.BiCop.R 2015-08-28 17:01:07 UTC (rev 129) @@ -39,7 +39,7 @@ stop("'margins' has to be one of 'unif' or 'norm'") if (is.null(list(...)$xlim) & is.null(list(...)$ylim)) { xylim <- switch(margins, - "unif" = c(0, 1), + "unif" = c(1e-1, 1 - 1e-1), "norm" = c(-3, 3)) } else { xylim <- range(c(list(...)$xlim, list(...)$ylim)) @@ -60,15 +60,15 @@ adj <- 1 gu <- g[, 1L] gv <- g[, 2L] - levels <- c(0.1, 0.5, 1, 3, 5, 10, 20) + levels <- c(0.2, 0.6, 1, 1.5, 2, 3, 5, 10, 20) xlim <- ylim <- c(0, 1) at <- c(seq(0, 6, by = 0.05), seq(7, 100, by = 1)) } else if (margins == "norm") { points <- qnorm(g[1L:size, 1L]) adj <- tcrossprod(dnorm(points)) + levels <- c(0.01, 0.025, 0.05, 0.1, 0.15, 0.2, 0.3, 0.4, 0.5) gu <- qnorm(g[, 1L]) gv <- qnorm(g[, 2L]) - levels <- c(0.02, 0.05, 0.1, 0.15, 0.2, 0.3, 0.4, 0.5) xlim <- ylim <- c(-3, 3) at <- seq(0, 1, l = 100) } Modified: pkg/R/plot.RVineMatrix.R =================================================================== --- pkg/R/plot.RVineMatrix.R 2015-08-24 20:10:56 UTC (rev 128) +++ pkg/R/plot.RVineMatrix.R 2015-08-28 17:01:07 UTC (rev 129) @@ -1,4 +1,5 @@ -plot.RVineMatrix <- function(x, tree = "ALL", type = 0, edge.labels = NULL, interactive = FALSE, ...) { +plot.RVineMatrix <- function(x, tree = "ALL", type = 0, edge.labels = NULL, legend.pos = "bottomleft", interactive = FALSE, ...) { + M <- x$Matrix d <- nrow(M) @@ -18,21 +19,44 @@ x$names <- paste("V", 1:d, sep = "") #### set up plotting options ---------------------------- - ## defaults (to be improved) + # reduce default margins of plot range + usr <- par()$mar + par(mar = c(1.1,0.1,3.1,0.1)) + on.exit(par(mar = usr)) + + # set plot.network options + TUMlightblue <- rgb(red = 100, green = 160, blue = 200, maxColorValue = 255) dflt <- list(interactive = interactive, displaylabels = TRUE, - pad = 1e-1, + pad = 1.5e-1, + edge.lwd = 0.35, + edge.col = "gray43", boxed.labels = TRUE, + label.pad = 1.5, + label.bg = TUMlightblue, label.pos = 7, - label.pad = 0.5) + label.col = "gray97", + label.cex = 1.3, + vertex.cex = 0, + object.scale = 0.05) + # Same color for edges, edge labels and label borders + dflt <- append(dflt, list(label.border = dflt$edge.col, + edge.label.col = dflt$edge.col, + edge.label.cex = dflt$label.cex - 0.2)) ## overwrite defaults with ... argument lst <- list(...) - final.args <- modifyList(dflt, lst) + temp.args <- modifyList(dflt, lst) #### loop through the trees ----------------------------- for (i in tree) { + main <- list(main = paste("Tree ", i, sep = ""), + col.main = ifelse("col.main" %in% names(temp.args), + temp.args$col.main, + temp.args$edge.col)) + final.args <- append(temp.args, main) + ## create network object g <- makeNetwork(x, i, !(type %in% c(0, 2))) final.args$x = g$nw @@ -44,14 +68,16 @@ edge.labels = edge.labels, type = type) - ## plot tree - main <- paste("Tree ", i, sep = "") do.call(plot, final.args) ## add legend if (type == 2) { - legend("bottomleft", legend = paste(1:d, x$name, sep = "<->"), - bty = "n", xjust = 0) + legend(legend.pos, + legend = paste(1:d, x$name, sep = " \U002194 "), + bty = "n", + xjust = 0, + text.col = final.args$edge.col, + cex = final.args$label.cex) } ## wait for key stroke @@ -63,6 +89,161 @@ } } + +## ----------------------------------------------------------------------------- +## contour generic for RVineMatrix objects +contour.RVineMatrix <- function(x, tree = "ALL", xylim = NULL, cex.nums = 1, ...) { + + ## check input + d <- nrow(x$Matrix) + if (all(tree == "ALL")) + tree <- seq.int(d-1) + n.tree <- length(tree) + if (!is.null(list(...)$type)) + stop("Only contour plots allowed. Don't use the type argument!") + + ## set up for plotting windows + mfrow.usr <- par()$mfrow + mar.usr <- par()$mar + par(mfrow = c(n.tree, d - min(tree))) + par(mar = rep(0, 4)) + on.exit(par(mfrow = mfrow.usr, mar = mar.usr)) + + + ## default style -------------------------------------------------- + # headings: blue color scale from dichromat pacakge + cs <- 1 / 255 * t(col2rgb(c("#E6FFFF", + "#CCFBFF", + "#B2F2FF", + "#99E6FF", + "#80D4FF", + "#66BFFF", + "#4CA6FF", + "#3388FF", + "#1A66FF", + "#0040FF"))) + # contours: set limits for plots + if (!is.null(list(...)$margins)) { + margins <- list(...)$margins + if (!(margins %in% c("norm", "unif"))) + stop("margins not supported") + } else { + margins <- "norm" + } + if (is.null(xylim)) + xylim <- switch(margins, + "norm" = c(-3, 3), + "unif" = c(1e-1, 1 - 1e-1)) + xlim <- ylim <- xylim + + # contours: adjust limits for headings + offs <- 0.25 + mult <- 1.5 + ylim[2] <- ylim[2] + offs*diff(ylim) + + + ## run through trees ----------------------------------------------- + # initialize check variables + cnt <- 0 + k <- d + e <- numeric(0) + class(e) <- "try-error" + + while ("try-error" %in% class(e)) { + e <- try({ + maxnums <- get_num(1, tree = max(tree), RVM = x) + for (i in tree) { + for (j in 1:(d - min(tree))) { + if (d - i >= j) { + # set up list of contour arguments + args <- list(x = BiCop(family=x$family[d-i+1,j], + par=x$par[d-i+1,j], + par2=x$par2[d-i+1,j]), + drawlabels = FALSE, + xlab = "", + ylab = "", + xlim = xlim, + ylim = ylim, + xaxt = "n", + yaxt = "n") + + # call plot.BiCop with ... arguments + do.call(plot, modifyList(args, list(...))) + + # draw area for headings + abline(h = ylim[2] - diff(ylim)/mult*offs) + ci <- min(nrow(cs) + 1 - i, 10) + polygon(x = c(xlim[1] - diff(xlim), + xlim[1] - diff(xlim), + xlim[2] + diff(xlim), + xlim[2] + diff(xlim)), + y = c(2*ylim[2], + ylim[2] - diff(ylim)/mult*offs, + ylim[2] - diff(ylim)/mult*offs, + 2*ylim[2]), + col = rgb(cs[ci, 1], cs[ci, 2], cs[ci, 3], 0.3)) + + # add pair-copula ID + cx1 <- 0.95 * diff(xlim) / strwidth(maxnums) + cx1 <- cx1 + ty <- ylim[2] - diff(ylim)/mult*offs + cx2 <- 0.95 * (ylim[2] - ty) / strheight(maxnums) + cx2 <- cx2 + cx <- min(cx1, cx2) + text(x = sum(xlim)/2, + y = ty + 0.225 / cex.nums * (ylim[2] - ty), + cex = cex.nums * cx, + labels = get_num(j, tree = i, RVM = x), + pos = 3, + offset = 0) + } else { + plot.new() + } + } + } + } + , silent = TRUE) + + ## adjust to figure margins if necessary + if (length(tree) < 1) + stop("Error in plot.new() : figure margins too large") + if ("try-error" %in% class(e)) { + cnt <- cnt + 1 + tree <- tree[-which(tree == max(tree))] + par(mfrow = c(n.tree - cnt, d - min(tree))) + } + } + + ## message for the user if not all trees could be plotted ----------- + if (length(tree) != n.tree) { + nmbr.msg <- as.character(tree[1]) + if (length(tree) > 2) { + for (i in tree[-c(1, length(tree))]) { + nmbr.msg <- paste(nmbr.msg, i, sep=", ") + } + } + if (length(tree) > 1) { + s.msg <- "s " + nmbr.msg <- paste(nmbr.msg, + "and", + tree[length(tree)], + "were plotted. ") + } else { + s.msg <- " " + nmbr.msg <- paste(nmbr.msg, "was plotted. ", sep=" ") + } + msg.space <- "There is not enough space." + msg.tree <- paste("Only Tree", + s.msg, + nmbr.msg, + "Use the 'tree' argument or enlarge figure margins", + " to see the others.", + sep = "") + message(paste(msg.space, msg.tree)) + } +} + + ## creates a network object for a tree in a given RVineMatrix ------------------ makeNetwork <- function(RVM, tree, use.names = FALSE) { M <- RVM$Matrix @@ -115,6 +296,7 @@ list(nw = nw, vlabs = node.lab) } + ## finds appropriate edge labels for the plot ---------------------------------- set_edge_labels <- function(tree, RVM, edge.labels, type) { d <- nrow(RVM$Matrix) @@ -187,6 +369,8 @@ elabel } + +## get info for a pair-copula from RVineMatrix object -------------------------- get_num <- function(j, tree, RVM) { M <- RVM$Matrix d <- nrow(M) Modified: pkg/man/plot.RVineMatrix.Rd =================================================================== --- pkg/man/plot.RVineMatrix.Rd 2015-08-24 20:10:56 UTC (rev 128) +++ pkg/man/plot.RVineMatrix.Rd 2015-08-28 17:01:07 UTC (rev 129) @@ -1,16 +1,24 @@ \name{plot.RVineMatrix} \alias{plot.RVineMatrix} -%- Also NEED an '\alias' for EACH other topic documented here. +\alias{contour.RVineMatrix} + \title{ Plotting \code{RVineMatrix} objects. } + + \description{ -This function plots one or all trees of a given R-vine copula model. Edges can be labeld with information about the corresponding pair-copula. +There are two plotting generics for \code{RVineMatrix} objects. \code{plot.RVineMatrix} plots one or all trees of a given R-vine copula model. Edges can be labeld with information about the corresponding pair-copula. \code{contour.RVineMatrix} produces a matrix of contour plots (using \code{\link[VineCopula:plot.BiCop]{plot.BiCop}}). } + + \usage{ -\method{plot}{RVineMatrix}(x, tree = "ALL", type = 0, edge.labels = NULL, interactive = FALSE, ...) +\method{plot}{RVineMatrix}(x, tree = "ALL", type = 0, edge.labels = NULL, legend.pos = "bottomleft", + interactive = FALSE, ...) +\method{contour}{RVineMatrix}(x, tree = "ALL", xylim = NULL, cex.nums = 1, ...) } -%- maybe also 'usage' for other objects documented here. + + \arguments{ \item{x}{\code{RVineMatrix} object.} \item{tree}{\code{"ALL"} or integer vector; specifies which trees are plotted.} @@ -26,31 +34,42 @@ \code{"family-par"} = pair-copula family and parameters \cr \code{"family-tau"} = pair-copula family and Kendall's tau. } + \item{legend.pos}{the \code{x} argument for \code{\link[graphics:legend]{legend}}.} \item{interactive}{logical; if TRUE, the user is asked to adjust the positioning of vertices with his mouse.} + \item{xylim}{numeric vector of length 2; sets \code{xlim} and \code{ylim} for the contours} + \item{cex.nums}{numeric; expansion factor for font of the numbers.} \item{\dots}{ -Arguments passed to \code{\link[network:plot.network]{plot.network}}. +Arguments passed to \code{\link[network:plot.network]{plot.network}} or \code{\link[VineCopula:plot.BiCop]{plot.BiCop}} respectively.} } + + +\details{ +If you want the contour boxes to be perfect sqaures, the plot height should be \code{1.14/length(tree)*(d - min(tree))} times the plot width. } + + \author{ -Thomas Nagler +Thomas Nagler, Nicole Barthel } -%% ~Make other sections like Warning with \section{Warning }{....} ~ - \seealso{ \code{\link[VineCopula:RVineMatrix]{RVineMatrix}}, -\code{\link[network:plot.network]{plot.network}} -\code{\link[VineCopula:BiCopName]{BiCopName}} +\code{\link[network:plot.network]{plot.network}}, +\code{\link[VineCopula:plot.BiCop]{plot.BiCop}}, +\code{\link[VineCopula:BiCopName]{BiCopName}}, +\code{\link[graphics:legend]{legend}} } + + \examples{ ## build vine model -strucmat <- matrix(c(3,1,2,0,2,1,0,0,1),3,3) -fammat <- matrix(c(0,1,6,0,0,3,0,0,0),3,3) -parmat <- matrix(c(0,0.3,3,0,0,1,0,0,0),3,3) -par2mat <- matrix(c(0,0,0,0,0,0,0,0,0),3,3) -RVM <- RVineMatrix(Matrix=strucmat, family=fammat, par=parmat, par2=par2mat) +strucmat <- matrix(c(3, 1, 2, 0, 2, 1, 0, 0, 1), 3, 3) +fammat <- matrix(c(0, 1, 6, 0, 0, 3, 0, 0, 0), 3, 3) +parmat <- matrix(c(0, 0.3, 3, 0, 0, 1, 0, 0, 0), 3, 3) +par2mat <- matrix(c(0, 0, 0, 0, 0, 0, 0, 0, 0), 3, 3) +RVM <- RVineMatrix(strucmat, fammat, parmat, par2mat) # plot trees plot(RVM) @@ -58,18 +77,18 @@ ## build new model # simulate from previous model u <- RVineSim(500, RVM) -colnames(u) <- c("A", "B", "C") +colnames(u) <- c("X", "Y", "Z") # estimate new model RVM2 <- RVineStructureSelect(u) -# plot new model with variable names ... +\dontrun{ +# plot new model with legend plot(RVM2, type = 1) -# annotate edge with pair-copula family and parameter -plot(RVM2, type = 1, edge.labels = "family-par") +# show contour plots +contour(RVM2) +} +} -} -% Add one or more standard keywords, see file 'KEYWORDS' in the -% R documentation directory. \keyword{plot} \ No newline at end of file