From noreply at r-forge.r-project.org Thu Jan 9 13:42:24 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 9 Jan 2014 13:42:24 +0100 (CET) Subject: [Vinecopula-commits] r46 - in pkg: R man src src/include Message-ID: <20140109124224.47ABA184985@r-forge.r-project.org> Author: mhofert Date: 2014-01-09 13:42:23 +0100 (Thu, 09 Jan 2014) New Revision: 46 Modified: pkg/R/RVineSim.R pkg/man/RVineSim.Rd pkg/src/include/rvine.h pkg/src/rvine.c Log: extended RVineSim() to allow for matrix of U to be passed Modified: pkg/R/RVineSim.R =================================================================== --- pkg/R/RVineSim.R 2013-12-20 14:09:49 UTC (rev 45) +++ pkg/R/RVineSim.R 2014-01-09 12:42:23 UTC (rev 46) @@ -1,12 +1,19 @@ -RVineSim<-function(N,RVM) -{ - if(!is(RVM, "RVineMatrix")) stop("'RVM' has to be an RVineMatrix object.") - +RVineSim <- function(N, RVM, U=NULL) +{ + stopifnot(N >= 1) + if(!is(RVM, "RVineMatrix")) stop("'RVM' has to be an RVineMatrix object.") + n = dim(RVM) - + o = diag(RVM$Matrix) RVM = normalizeRVineMatrix(RVM) + takeU <- !is.null(U) + if(takeU) { + if(!is.matrix(U)) U <- rbind(U, deparse.level=0L) + if((d <- ncol(U)) < 2) stop("U should be at least bivariate") # should be an (N, n) matrix + } + matri=as.vector(RVM$Matrix) w1=as.vector(RVM$family) th=as.vector(RVM$par) @@ -32,24 +39,26 @@ as.double(th), as.double(th2), as.double(tmp), + as.double(U), + as.integer(takeU), PACKAGE = 'VineCopula')[[9]] out=matrix(tmp,ncol=n) if(!is.null(RVM$names)){ - colnames(out) = RVM$names + colnames(out) = RVM$names } out = out[,sort(o[length(o):1],index.return=TRUE)$ix] return(out) -} +} transform<-function(M) { n=dim(M)[1] - + M.new=matrix(rep(0,n*n),n,n) for(i in 1:n) { Modified: pkg/man/RVineSim.Rd =================================================================== --- pkg/man/RVineSim.Rd 2013-12-20 14:09:49 UTC (rev 45) +++ pkg/man/RVineSim.Rd 2014-01-09 12:42:23 UTC (rev 46) @@ -1,5 +1,5 @@ -\name{RVineSim} -\alias{RVineSim} +\name{RVineSim} +\alias{RVineSim} \title{Simulation from an R-vine copula model} @@ -8,12 +8,15 @@ } \usage{ -RVineSim(N, RVM) +RVineSim(N, RVM, U=NULL) } \arguments{ \item{N}{Number of d-dimensional observations to simulate.} - \item{RVM}{An \code{\link{RVineMatrix}} object containing the information of the R-vine copula model.} + \item{RVM}{An \code{\link{RVineMatrix}} object containing the + information of the R-vine copula model.} + \item{U}{If not \code{\link{NULL}}, an (N,d)-matrix of U[0,1] random variates + to be transformed to the copula sample.} } \value{ Modified: pkg/src/include/rvine.h =================================================================== --- pkg/src/include/rvine.h 2013-12-20 14:09:49 UTC (rev 45) +++ pkg/src/include/rvine.h 2014-01-09 12:42:23 UTC (rev 46) @@ -5,7 +5,7 @@ // PCC for R-vine //////////////////////////////////////////// -void SimulateRVine(int* T, int* d, int* family, int* maxmat, int* matrix, int* conindirect, double* par, double* par2, double* out); +void SimulateRVine(int* T, int* d, int* family, int* maxmat, int* matrix, int* conindirect, double* par, double* par2, double* out, double* U, int* takeU); ////////////////////////////////////////////////////////////// @@ -20,7 +20,7 @@ // par2 second set of parameter values (f.e. for student copulas) // data data set for which to compute log-likelihood // matrix an RVineMatrix in vector form -// condirect, conindirect Matrizes which tell us where we find the right values +// condirect, conindirect Matrizes which tell us where we find the right values // seperate Control Parameter, do we want to seperate the likelihoods for each data point? // calcupdate matrix which tells us for which parameters we need to redo the calculations, not newly computed values are taken from ll, vv, vv2 // seperate Control Parameter, do we want to seperate the likelihoods for each data point? @@ -28,10 +28,10 @@ // Output: // out Loglikelihood // ll array with the contribution to LL (for each copula) -// vv,vv2 array for the transformation operated (Hfunc) +// vv,vv2 array for the transformation operated (Hfunc) ///////////////////////////////////////////////////////////// -void VineLogLikRvine(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, +void VineLogLikRvine(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, double* out, double* ll, double* vv, double* vv2, int* calcupdate, int* seperate); @@ -47,17 +47,17 @@ // par2 second set of parameter values (f.e. for student copulas) // data data set for which to compute log-likelihood // matrix an RVineMatrix in vector form -// condirect, conindirect Matrizes which tell us where we find the right values +// condirect, conindirect Matrizes which tell us where we find the right values // seperate Control Parameter, do we want to seperate the likelihoods for each data point? // calcupdate matrix which tells us for which parameters we need to redo the calculations, not newly computed values are taken from ll, vv, vv2 // // Output: // out Loglikelihood // ll array with the contribution to LL (for each copula) -// vv,vv2 array for the transformation operated (Hfunc) +// vv,vv2 array for the transformation operated (Hfunc) ///////////////////////////////////////////////////////////// -void VineLikRvine(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, +void VineLikRvine(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, double* out, double* ll, double* vv, double* vv2, int* calcupdate, int* seperate); #endif Modified: pkg/src/rvine.c =================================================================== --- pkg/src/rvine.c 2013-12-20 14:09:49 UTC (rev 45) +++ pkg/src/rvine.c 2014-01-09 12:42:23 UTC (rev 46) @@ -1,12 +1,12 @@ /* -** rvine.c - C code of the package CDRVine -** -** with contributions from Carlos Almeida, Aleksey Min, +** rvine.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. +** provided by personal communication. ** */ @@ -31,38 +31,38 @@ // par2 second set of parameter values (f.e. for student copulas) // data data set for which to compute log-likelihood // matrix an RVineMatrix in vector form -// condirect, conindirect Matrizes which tell us where we find the right values +// condirect, conindirect Matrizes which tell us where we find the right values // seperate Control Parameter, do we want to seperate the likelihoods for each data point? // calcupdate matrix which tells us for which parameters we need to redo the calculations, not newly computed values are taken from ll, vv, vv2 // Output: // out Loglikelihood // ll array with the contribution to LL (for each copula) -// vv,vv2 array for the transformation operated (Hfunc) +// vv,vv2 array for the transformation operated (Hfunc) ///////////////////////////////////////////////////////////// -void VineLogLikRvine(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, +void VineLogLikRvine(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, double* out, double* ll, double* vv, double* vv2, int* calcupdate, int* seperate) { int i, j, k, t, m, **fam; int kk=1; double loglik=1.0, sumloglik=0.0, **x, **theta, **nu, ***vdirect, ***vindirect; - + double *sumsplitlog; sumsplitlog=(double*) Calloc(*T,double); - - for (t=0;t<*T;t++ ) + + for (t=0;t<*T;t++ ) { sumsplitlog[t] = 0; } - - - + + + double ***value2; value2=create_3darray(*d,*d,*T); double **value; value=create_matrix(*d,*d); - + //Allocate memory x = create_matrix(*d,*T); vdirect = create_3darray(*d,*d,*T); @@ -75,24 +75,24 @@ //cindirect=create_intmatrix(*d,*d); //mat=create_intmatrix(*d,*d); //calc=create_intmatrix(*d,*d); - - + + /* m=*d; Rprintf("%d\n\n",m); m=*T; Rprintf("%d\n\n",m); */ - + //Initialize k=0; for(i=0;i<(*d);i++) { - for (t=0;t<*T;t++ ) + for (t=0;t<*T;t++ ) { x[i][t] = data[k]; k++; } } - + k=0; for(i=0;i<(*d);i++) { @@ -111,67 +111,67 @@ } //calc[i][j]=calcupdate[(i+1)+(*d)*j-1] ; } - } - + } + for(i=0;i<(*d);i++) { for(j=0;j<(*d);j++) - { - for(t=0;t<*T;t++ ) + { + for(t=0;t<*T;t++ ) { vdirect[i][j][t]=vv[(i+1)+(*d)*j+(*d)*(*d)*t-1]; vindirect[i][j][t]=vv2[(i+1)+(*d)*j+(*d)*(*d)*t-1]; if(*seperate==1) - { + { value2[i][j][t]=ll[(i+1)+(*d)*j+(*d)*(*d)*t-1]; } } } } - - - + + + for(i=0;i<(*d);i++) { - for(t=0;t<*T;t++ ) + for(t=0;t<*T;t++ ) { vdirect[*d-1][i][t]=x[*d-1-i][t]; } } - - + + for(i=*d-2; i>-1; i--) { for(k=*d-1;k>i;k--) - { + { //if(calc[k][i]==1) if(calcupdate[(k+1)+(*d)*i-1]==1) { //m=mmat[k][i]; m=maxmat[(k+1)+(*d)*i-1]; - + //if(m == mat[k][i]) if(m == matrix[(k+1)+(*d)*i-1]) - { + { if(*seperate==1) { kk = 1; - for(t=0;t<*T;t++ ) + for(t=0;t<*T;t++ ) { - LL_mod(&fam[k][i],&kk,&vdirect[k][i][t],&vdirect[k][(*d-m)][t],&theta[k][i],&nu[k][i],&loglik); + LL_mod(&fam[k][i],&kk,&vdirect[k][i][t],&vdirect[k][(*d-m)][t],&theta[k][i],&nu[k][i],&loglik); /* sumloglik += loglik; */ value2[k][i][t]=loglik; } } else { - - LL_mod(&fam[k][i],T,vdirect[k][i],vdirect[k][(*d-m)],&theta[k][i],&nu[k][i],&loglik); + + LL_mod(&fam[k][i],T,vdirect[k][i],vdirect[k][(*d-m)],&theta[k][i],&nu[k][i],&loglik); /* sumloglik += loglik; */ value[k][i]=loglik; } - //if(cdirect[k-1][i]==1) + //if(cdirect[k-1][i]==1) if(condirect[k+(*d)*i-1]==1) { Hfunc1(&fam[k][i],T,vdirect[k][i],vdirect[k][*d-m],&theta[k][i],&nu[k][i],vdirect[k-1][i]); @@ -179,29 +179,29 @@ //if(cindirect[k-1][i]==1) if(conindirect[k+(*d)*i-1]==1) { - Hfunc2(&fam[k][i],T,vdirect[k][(*d-m)],vdirect[k][i],&theta[k][i],&nu[k][i],vindirect[k-1][i]); + Hfunc2(&fam[k][i],T,vdirect[k][(*d-m)],vdirect[k][i],&theta[k][i],&nu[k][i],vindirect[k-1][i]); } - + } else { if(*seperate==1) { kk = 1; - for(t=0;t<*T;t++ ) + for(t=0;t<*T;t++ ) { - LL_mod(&fam[k][i],&kk,&vdirect[k][i][t],&vindirect[k][(*d-m)][t],&theta[k][i],&nu[k][i],&loglik); + LL_mod(&fam[k][i],&kk,&vdirect[k][i][t],&vindirect[k][(*d-m)][t],&theta[k][i],&nu[k][i],&loglik); /* sumloglik += loglik; */ - value2[k][i][t]=loglik; + value2[k][i][t]=loglik; } } else { - LL_mod(&fam[k][i],T,vdirect[k][i],vindirect[k][(*d-m)],&theta[k][i],&nu[k][i],&loglik); + LL_mod(&fam[k][i],T,vdirect[k][i],vindirect[k][(*d-m)],&theta[k][i],&nu[k][i],&loglik); /* sumloglik += loglik; */ value[k][i]=loglik; } - //if(cdirect[k-1][i]==1) + //if(cdirect[k-1][i]==1) if(condirect[k+(*d)*i-1]==1) { Hfunc1(&fam[k][i],T,vdirect[k][i],vindirect[k][(*d-m)],&theta[k][i],&nu[k][i],vdirect[k-1][i]); @@ -209,7 +209,7 @@ //if(cindirect[k-1][i]==1) if(conindirect[k+(*d)*i-1]==1) { - Hfunc2(&fam[k][i],T,vindirect[k][(*d-m)],vdirect[k][i],&theta[k][i],&nu[k][i],vindirect[k-1][i]); + Hfunc2(&fam[k][i],T,vindirect[k][(*d-m)],vdirect[k][i],&theta[k][i],&nu[k][i],vindirect[k-1][i]); } } } @@ -218,24 +218,24 @@ sumloglik += value[k][i]; } else - { - for(t=0;t<*T;t++ ) - { + { + for(t=0;t<*T;t++ ) + { sumsplitlog[t] += value2[k][i][t]; - } + } } - } + } } - + if(*seperate==0) - { + { *out = sumloglik; } else { - for(t=0;t<*T;t++ ) + for(t=0;t<*T;t++ ) { out[t] = sumsplitlog[t]; } @@ -243,8 +243,8 @@ for(i=0;i<(*d);i++) { for(j=0;j<(*d);j++) - { - for(t=0;t<*T;t++ ) + { + for(t=0;t<*T;t++ ) { vv[(i+1)+(*d)*j+(*d)*(*d)*t-1]=vdirect[i][j][t]; vv2[(i+1)+(*d)*j+(*d)*(*d)*t-1]=vindirect[i][j][t]; @@ -269,18 +269,18 @@ //Free memory: - free_matrix(x,*d); - free_3darray(vdirect,*d,*d); - free_matrix(theta,*d); - free_matrix(nu,*d); - free_intmatrix(fam,*d); + free_matrix(x,*d); + free_3darray(vdirect,*d,*d); + free_matrix(theta,*d); + free_matrix(nu,*d); + free_intmatrix(fam,*d); free_matrix(value,*d); free_3darray(value2,*d,*d); - //free_intmatrix(mmat,*d); - //free_intmatrix(cdirect,*d); - //free_intmatrix(cindirect,*d); - free_3darray(vindirect,*d,*d); - //free_intmatrix(calc, *d); + //free_intmatrix(mmat,*d); + //free_intmatrix(cdirect,*d); + //free_intmatrix(cindirect,*d); + free_3darray(vindirect,*d,*d); + //free_intmatrix(calc, *d); //free_intmatrix(mat, *d); Free(sumsplitlog); } @@ -296,41 +296,41 @@ // par2 second set of parameter values (f.e. for student copulas) // data data set for which to compute log-likelihood // matrix an RVineMatrix in vector form -// condirect, conindirect Matrizes which tell us where we find the right values +// condirect, conindirect Matrizes which tell us where we find the right values // seperate Control Parameter, do we want to seperate the likelihoods for each data point? // calcupdate matrix which tells us for which parameters we need to redo the calculations, not newly computed values are taken from ll, vv, vv2 // Output: // out Loglikelihood // ll array with the contribution to LL (for each copula) -// vv,vv2 array for the transformation operated (Hfunc) +// vv,vv2 array for the transformation operated (Hfunc) ///////////////////////////////////////////////////////////// /// seperate = 1 not implemented, highly experimental -void VineLikRvine(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, +void VineLikRvine(int* T, int* d, int* family, int* maxmat, int* matrix, int* condirect, int* conindirect, double* par, double* par2, double* data, double* out, double* ll, double* vv, double* vv2, int* calcupdate, int* seperate) { int i, j, k, t, m, **fam, **cdirect, **cindirect, **mat, **mmat, **calc; int kk=1; double loglik=1.0, sumloglik=1.0, **x, **theta, **nu, ***vdirect, ***vindirect; - + double *sumsplitlog; sumsplitlog=(double*) Calloc(*T,double); - - for (t=0;t<*T;t++ ) + + for (t=0;t<*T;t++ ) { sumsplitlog[t] = 0; } - - - + + + double ***value2; value2=create_3darray(*d,*d,*T); double **value; value=create_matrix(*d,*d); - - - + + + //Allocate memory x = create_matrix(*d,*T); vdirect = create_3darray(*d,*d,*T); @@ -343,24 +343,24 @@ cindirect=create_intmatrix(*d,*d); mat=create_intmatrix(*d,*d); calc=create_intmatrix(*d,*d); - - + + /* m=*d; Rprintf("%d\n\n",m); m=*T; Rprintf("%d\n\n",m); */ - + //Initialize k=0; for(i=0;i<(*d);i++) { - for (t=0;t<*T;t++ ) + for (t=0;t<*T;t++ ) { x[i][t] = data[k]; k++; } } - + k=0; for(i=0;i<(*d);i++) { @@ -369,7 +369,7 @@ theta[i][j]=par[(i+1)+(*d)*j-1] ; nu[i][j]=par2[(i+1)+(*d)*j-1] ; mmat[i][j]=maxmat[(i+1)+(*d)*j-1] ; - /* m=maxmat[(i+1)+(*d)*j-1]; + /* m=maxmat[(i+1)+(*d)*j-1]; Rprintf("%d\n",m); */ mat[i][j]=matrix[(i+1)+(*d)*j-1] ; cdirect[i][j]=condirect[(i+1)+(*d)*j-1]; @@ -378,96 +378,96 @@ if(*seperate==0){value[i][j]=ll[(i+1)+(*d)*j-1] ;} calc[i][j]=calcupdate[(i+1)+(*d)*j-1] ; } - } - - + } + + for(i=0;i<(*d);i++) { - for(j=0;j<(*d);j++){ + for(j=0;j<(*d);j++){ for(t=0;t<*T;t++ ) { vdirect[i][j][t]=vv[(i+1)+(*d)*j+(*d)*(*d)*t-1]; vindirect[i][j][t]=vv2[(i+1)+(*d)*j+(*d)*(*d)*t-1]; if(*seperate==1){ value2[i][j][t]=ll[(i+1)+(*d)*j+(*d)*(*d)*t-1];} }}} - - - + + + for(i=0;i<(*d);i++) { - for(t=0;t<*T;t++ ) + for(t=0;t<*T;t++ ) { vdirect[*d-1][i][t]=x[*d-1-i][t]; } } - - + + for(i=*d-2; i>-1; i--) { for(k=*d-1;k>i;k--) - { - + { + if(calc[k][i]==1){ m=mmat[k][i]; - - + + /* Rprintf("%d\n",m);*/ - + if(m == mat[k][i]) - { + { if(*seperate==1){kk = 1; for(t=0;t<*T;t++ ) { - - copLik_mod(&fam[k][i],&kk,&vdirect[k][i][t],&vdirect[k][(*d-m)][t],&theta[k][i],&nu[k][i],&loglik); + + copLik_mod(&fam[k][i],&kk,&vdirect[k][i][t],&vdirect[k][(*d-m)][t],&theta[k][i],&nu[k][i],&loglik); /* sumloglik += loglik; */ value2[k][i][t]=loglik; - + }}else{ - - copLik_mod(&fam[k][i],T,vdirect[k][i],vdirect[k][(*d-m)],&theta[k][i],&nu[k][i],&loglik); + + copLik_mod(&fam[k][i],T,vdirect[k][i],vdirect[k][(*d-m)],&theta[k][i],&nu[k][i],&loglik); /* sumloglik += loglik; */ value[k][i]=loglik;} if(cdirect[k-1][i]==1) { Hfunc1(&fam[k][i],T,vdirect[k][i],vdirect[k][*d-m],&theta[k][i],&nu[k][i],vdirect[k-1][i]); } if(cindirect[k-1][i]==1) { - Hfunc2(&fam[k][i],T,vdirect[k][(*d-m)],vdirect[k][i],&theta[k][i],&nu[k][i],vindirect[k-1][i]); + Hfunc2(&fam[k][i],T,vdirect[k][(*d-m)],vdirect[k][i],&theta[k][i],&nu[k][i],vindirect[k-1][i]); } - - - + + + }else{ if(*seperate==1){kk = 1; for(t=0;t<*T;t++ ) { - copLik_mod(&fam[k][i],&kk,&vdirect[k][i][t],&vindirect[k][(*d-m)][t],&theta[k][i],&nu[k][i],&loglik); + copLik_mod(&fam[k][i],&kk,&vdirect[k][i][t],&vindirect[k][(*d-m)][t],&theta[k][i],&nu[k][i],&loglik); /* sumloglik += loglik; */ value2[k][i][t]=loglik; - + }}else{ - - copLik_mod(&fam[k][i],T,vdirect[k][i],vindirect[k][(*d-m)],&theta[k][i],&nu[k][i],&loglik); + + copLik_mod(&fam[k][i],T,vdirect[k][i],vindirect[k][(*d-m)],&theta[k][i],&nu[k][i],&loglik); /* sumloglik += loglik; */ value[k][i]=loglik;} if(cdirect[k-1][i]==1) { Hfunc1(&fam[k][i],T,vdirect[k][i],vindirect[k][(*d-m)],&theta[k][i],&nu[k][i],vdirect[k-1][i]); } if(cindirect[k-1][i]==1) { - Hfunc2(&fam[k][i],T,vindirect[k][(*d-m)],vdirect[k][i],&theta[k][i],&nu[k][i],vindirect[k-1][i]); + Hfunc2(&fam[k][i],T,vindirect[k][(*d-m)],vdirect[k][i],&theta[k][i],&nu[k][i],vindirect[k-1][i]); } - + } } if(*seperate==0){sumloglik = sumloglik*value[k][i];}else{ for(t=0;t<*T;t++ ) { sumsplitlog[t] += value2[k][i][t];} }; - } + } } - - - - - + + + + + if(*seperate==0){ *out = sumloglik;}else{for(t=0;t<*T;t++ ) {out[t] = sumsplitlog[t];}}; for(i=0;i<(*d);i++) { - for(j=0;j<(*d);j++){ + for(j=0;j<(*d);j++){ for(t=0;t<*T;t++ ) { vv[(i+1)+(*d)*j+(*d)*(*d)*t-1]=vdirect[i][j][t]; vv2[(i+1)+(*d)*j+(*d)*(*d)*t-1]=vindirect[i][j][t]; @@ -478,8 +478,8 @@ for(j=0;j<(*d);j++) { if(*seperate==0){ll[(i+1)+(*d)*j-1]=value[i][j];}}} - - + + //Free memory: free_matrix(x,*d); free_3darray(vdirect,*d,*d); free_matrix(theta,*d); free_matrix(nu,*d); free_intmatrix(fam,*d); free_matrix(value,*d);free_3darray(value2,*d,*d); free_intmatrix(mmat,*d); free_intmatrix(cdirect,*d); free_intmatrix(cindirect,*d); free_3darray(vindirect,*d,*d); free_intmatrix(calc, *d); free_intmatrix(mat, *d); @@ -494,11 +494,11 @@ // PCC for R-vine //////////////////////////////////////////// -void SimulateRVine(int* T, int* d, int* family, int* maxmat, int* matrix, int* conindirect, double* par, double* par2, double* out) +void SimulateRVine(int* T, int* d, int* family, int* maxmat, int* matrix, int* conindirect, double* par, double* par2, double* out, double* U, int* takeU) { int i, j, k, m, **fam, **cindirect, **mat, **mmat, **fam2, **cindirect2, **mat2, **mmat2; - double **theta, **nu, **theta2, **nu2, ***vdirect, ***vindirect; - + double **theta, **nu, **theta2, **nu2, ***vdirect, ***vindirect, **U2; + //Allocate memory theta=create_matrix(*d,*d); nu=create_matrix(*d,*d); @@ -514,6 +514,7 @@ mat2=create_intmatrix(*d,*d); vdirect = create_3darray(*d,*d,*T); vindirect = create_3darray(*d,*d,*T); + U2 = create_matrix(*T, *d); //Initialize random number generator: GetRNGstate(); @@ -521,18 +522,19 @@ //Initialize k=0; for(i=0;i<(*d);i++) - { - for(j=0;j<(*d);j++) - { - theta2[i][j]=par[(i+1)+(*d)*j-1] ; - nu2[i][j]=par2[(i+1)+(*d)*j-1] ; - mmat2[i][j]=maxmat[(i+1)+(*d)*j-1] ; - mat2[i][j]=matrix[(i+1)+(*d)*j-1] ; - cindirect2[i][j]=conindirect[(i+1)+(*d)*j-1] ; - fam2[i][j]=family[(i+1)+(*d)*j-1] ; + { + for(j=0;j<(*d);j++) + { + theta2[i][j]=par[(i+1)+(*d)*j-1] ; + nu2[i][j]=par2[(i+1)+(*d)*j-1] ; + mmat2[i][j]=maxmat[(i+1)+(*d)*j-1] ; + mat2[i][j]=matrix[(i+1)+(*d)*j-1] ; + cindirect2[i][j]=conindirect[(i+1)+(*d)*j-1] ; + fam2[i][j]=family[(i+1)+(*d)*j-1] ; } - } - + } + for(j=0;j<(*d);j++) for(i=0;i<(*T);i++) U2[i][j]=U[(*T)*j+i]; // (T [=N], d)-matrix + // Matrizen rotieren für den Algo for(i=0;i<(*d);i++) { @@ -548,12 +550,12 @@ } free_matrix(theta2,*d); - free_matrix(nu2,*d); + free_matrix(nu2,*d); free_intmatrix(fam2,*d); - free_intmatrix(mmat2,*d); - free_intmatrix(cindirect2,*d); + free_intmatrix(mmat2,*d); + free_intmatrix(cindirect2,*d); free_intmatrix(mat2, *d); - + /* Declare variable to hold seconds on clock. */ @@ -571,9 +573,10 @@ // Der eigentliche Algo - for(j=0;j<*T;j++) - { - for(i=0;i<*d;i++) vdirect[i][i][j] = runif(0,1); + for(j=0;j<*T;j++) // sample size + { + if(*takeU == 1) for(i=0;i<*d;i++) vdirect[i][i][j] = U2[j][i]; // j = 'sample size'; i = 'copula dimension' + else for(i=0;i<*d;i++) vdirect[i][i][j] = runif(0,1); vindirect[0][0][j] = vdirect[0][0][j]; } @@ -607,8 +610,8 @@ } } } - + k=0; for(i=0;i<(*d);i++) { @@ -621,12 +624,13 @@ //Free memory: free_matrix(theta,*d); - free_matrix(nu,*d); + free_matrix(nu,*d); free_intmatrix(fam,*d); - free_intmatrix(mmat,*d); - free_intmatrix(cindirect,*d); + free_intmatrix(mmat,*d); + free_intmatrix(cindirect,*d); free_intmatrix(mat, *d); free_3darray(vdirect,*d,*d); free_3darray(vindirect,*d,*d); + free_matrix(U2,*T); PutRNGstate(); } From noreply at r-forge.r-project.org Fri Jan 24 10:33:10 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 24 Jan 2014 10:33:10 +0100 (CET) Subject: [Vinecopula-commits] r47 - pkg/src Message-ID: <20140124093310.72B41186B15@r-forge.r-project.org> Author: ulf Date: 2014-01-24 10:33:09 +0100 (Fri, 24 Jan 2014) New Revision: 47 Modified: pkg/src/gof.c pkg/src/rvine.c Log: Fehler in gofECP behoben, der durch die Aenderung von Marius aufgetreten ist in der RVineSimulate Modified: pkg/src/gof.c =================================================================== --- pkg/src/gof.c 2014-01-09 12:42:23 UTC (rev 46) +++ pkg/src/gof.c 2014-01-24 09:33:09 UTC (rev 47) @@ -465,8 +465,8 @@ void gofECP(int* T, int* d, int* family, int* maxmat, int* matrix, int* conindirect, double* par, double* par2, double* data, double* statistic, int* statisticName) { - double *znull, *Chat1, *Chat2; - int T2=1000, i=0, t=0; + double *znull, *Chat1, *Chat2, U=0; + int T2=1000, i=0, t=0, takeU=0; znull = malloc(*d*1000*sizeof(double)); Chat1 = malloc(*T*sizeof(double)); Chat2 = malloc(*T*sizeof(double)); @@ -479,7 +479,7 @@ } } - SimulateRVine(&T2, d, family, maxmat, matrix, conindirect, par, par2, znull); + SimulateRVine(&T2, d, family, maxmat, matrix, conindirect, par, par2, znull, &U, &takeU); ChatZj(data, data, T, d, T, Chat1); Modified: pkg/src/rvine.c =================================================================== --- pkg/src/rvine.c 2014-01-09 12:42:23 UTC (rev 46) +++ pkg/src/rvine.c 2014-01-24 09:33:09 UTC (rev 47) @@ -533,7 +533,10 @@ fam2[i][j]=family[(i+1)+(*d)*j-1] ; } } - for(j=0;j<(*d);j++) for(i=0;i<(*T);i++) U2[i][j]=U[(*T)*j+i]; // (T [=N], d)-matrix + if(*takeU == 1) + { + for(j=0;j<(*d);j++) for(i=0;i<(*T);i++) U2[i][j]=U[(*T)*j+i]; // (T [=N], d)-matrix + } // Matrizen rotieren für den Algo for(i=0;i<(*d);i++) From noreply at r-forge.r-project.org Fri Jan 24 10:49:25 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 24 Jan 2014 10:49:25 +0100 (CET) Subject: [Vinecopula-commits] r48 - pkg/inst Message-ID: <20140124094926.091011865B7@r-forge.r-project.org> Author: ulf Date: 2014-01-24 10:49:25 +0100 (Fri, 24 Jan 2014) New Revision: 48 Modified: pkg/inst/ChangeLog Log: ChangeLog aktualisiert Modified: pkg/inst/ChangeLog =================================================================== --- pkg/inst/ChangeLog 2014-01-24 09:33:09 UTC (rev 47) +++ pkg/inst/ChangeLog 2014-01-24 09:49:25 UTC (rev 48) @@ -1,15 +1,25 @@ Changes for R-package VineCopula -Ulf Schepsmeier, Jakob Stoeber, Eike Christian Brechmann and Benedikt Graeler +Current authors: Ulf Schepsmeier, Tobias Erhardt and Benedikt Graeler +Former authors: Eike Brechmann and Jakob Stöber +Version 1.2-1 (January 24, 2014) +New functionality: + * RVineSim allows to commit a (N,d)-matrix of U[0,1] random variates to be transformed to the copula sample. + For example if you want to use quasi random variables instead of the pseudo random variables implemented in R (Thanks to Marius Hofert) + +- Bug fix: + * RVineMLE: the optim argument "parscale" was not correctly defined for all cases. + + Version 1.2 (October 09, 2013) - New functionality: * RVinePIT Calculation of the probability integral transform (PIT) for R-vines * RVineGofTest 15 different goodness-of-fit tests for R-vine copulas (Schepsmeier 2013). * print.RVM A more detailed summary is printed if print(RVM, detail=TRUE) is set. - * BetaMatrix Matrix of empirical Blomqvist's beta values + * BetaMatrix Matrix of empirical Blomqvist's beta values * BiCopPar2Beta Blomqvist's beta value of a bivariate copula * RVinePar2Beta Blomqvist's beta values of an R-vine copula model * New copula familes for most of the BiCop as well as for the RVine-functions: As an asymmetric extension of the Gumbel copula, the Tawn copula with three parameters is now also included in the package. From noreply at r-forge.r-project.org Sat Jan 25 14:16:25 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 25 Jan 2014 14:16:25 +0100 (CET) Subject: [Vinecopula-commits] r49 - in pkg: R inst Message-ID: <20140125131626.1209B1865B4@r-forge.r-project.org> Author: ulf Date: 2014-01-25 14:16:25 +0100 (Sat, 25 Jan 2014) New Revision: 49 Modified: pkg/R/RVineAIC.r pkg/inst/ChangeLog Log: Gemeldeten Fehler behoben. In RVineAIC/BIC wurde gar nicht auf die Argumente par und par2 zugegriffen. + Sicherheitsabfragen Modified: pkg/R/RVineAIC.r =================================================================== --- pkg/R/RVineAIC.r 2014-01-24 09:49:25 UTC (rev 48) +++ pkg/R/RVineAIC.r 2014-01-25 13:16:25 UTC (rev 49) @@ -11,12 +11,65 @@ n<-d N<-T if(n != dim(RVM)) stop("Dimensions of 'data' and 'RVM' do not match.") - if(!is(RVM,"RVineMatrix")) stop("'RVM' has to be an RVineMatrix object.") + if(!is(RVM,"RVineMatrix")) stop("'RVM' has to be an RVineMatrix object.") + par[is.na(par)]=0 + par[upper.tri(par,diag=T)]=0 + par2[is.na(par2)]=0 + par2[upper.tri(par2,diag=T)]=0 + + if(any(par!=NA) & dim(par)[1]!=dim(par)[2]) stop("Parameter matrix has to be quadratic.") + if(any(par2!=NA) & dim(par2)[1]!=dim(par2)[2]) stop("Second parameter matrix has to be quadratic.") + + family=RVM$family + + if(!all(par %in% c(0,NA))) + { + for(i in 2:dim(RVM$Matrix)[1]) + { + for(j in 1:(i-1)) + { + if((family[i,j]==1 || family[i,j]==2) && abs(par[i,j])>=1) stop("The parameter of the Gaussian and t-copula has to be in the interval (-1,1).") + if(family[i,j]==2 && par2[i,j]<=2) stop("The degrees of freedom parameter of the t-copula has to be larger than 2.") + if((family[i,j]==3 || family[i,j]==13) && par[i,j]<=0) stop("The parameter of the Clayton copula has to be positive.") + if((family[i,j]==4 || family[i,j]==14) && par[i,j]<1) stop("The parameter of the Gumbel copula has to be in the interval [1,oo).") + if((family[i,j]==6 || family[i,j]==16) && par[i,j]<=1) stop("The parameter of the Joe copula has to be in the interval (1,oo).") + if(family[i,j]==5 && par[i,j]==0) stop("The parameter of the Frank copula has to be unequal to 0.") + if((family[i,j]==7 || family[i,j]==17) && par[i,j]<=0) stop("The first parameter of the BB1 copula has to be positive.") + if((family[i,j]==7 || family[i,j]==17) && par2[i,j]<1) stop("The second parameter of the BB1 copula has to be in the interval [1,oo).") + if((family[i,j]==8 || family[i,j]==18) && par[i,j]<=0) stop("The first parameter of the BB6 copula has to be in the interval [1,oo).") + if((family[i,j]==8 || family[i,j]==18) && par2[i,j]<1) stop("The second parameter of the BB6 copula has to be in the interval [1,oo).") + if((family[i,j]==9 || family[i,j]==19) && par[i,j]<1) stop("The first parameter of the BB7 copula has to be in the interval [1,oo).") + if((family[i,j]==9 || family[i,j]==19) && par2[i,j]<=0) stop("The second parameter of the BB7 copula has to be positive.") + if((family[i,j]==10 || family[i,j]==20) && par[i,j]<1) stop("The first parameter of the BB8 copula has to be in the interval [1,oo).") + if((family[i,j]==10 || family[i,j]==20) && (par2[i,j]<=0 || par2[i,j]>1)) stop("The second parameter of the BB8 copula has to be in the interval (0,1].") + if((family[i,j]==23 || family[i,j]==33) && par[i,j]>=0) stop("The parameter of the rotated Clayton copula has to be negative.") + if((family[i,j]==24 || family[i,j]==34) && par[i,j]>-1) stop("The parameter of the rotated Gumbel copula has to be in the interval (-oo,-1].") + if((family[i,j]==26 || family[i,j]==36) && par[i,j]>=-1) stop("The parameter of the rotated Joe copula has to be in the interval (-oo,-1).") + if((family[i,j]==27 || family[i,j]==37) && par[i,j]>=0) stop("The first parameter of the rotated BB1 copula has to be negative.") + if((family[i,j]==27 || family[i,j]==37) && par2[i,j]>-1) stop("The second parameter of the rotated BB1 copula has to be in the interval (-oo,-1].") + if((family[i,j]==28 || family[i,j]==38) && par[i,j]>=0) stop("The first parameter of the rotated BB6 copula has to be in the interval (-oo,-1].") + if((family[i,j]==28 || family[i,j]==38) && par2[i,j]>-1) stop("The second parameter of the rotated BB6 copula has to be in the interval (-oo,-1].") + if((family[i,j]==29 || family[i,j]==39) && par[i,j]>-1) stop("The first parameter of the rotated BB7 copula has to be in the interval (-oo,-1].") + if((family[i,j]==29 || family[i,j]==39) && par2[i,j]>=0) stop("The second parameter of the rotated BB7 copula has to be negative.") + if((family[i,j]==30 || family[i,j]==40) && par[i,j]>-1) stop("The first parameter of the rotated BB8 copula has to be in the interval (-oo,-1].") + if((family[i,j]==30 || family[i,j]==40) && (par2[i,j]>=0 || par2[i,j]<(-1))) stop("The second parameter of the rotated BB8 copula has to be in the interval [-1,0).") + if ((family[i,j]==104 || family[i,j]==114 || family[i,j]==204 || family[i,j]==214) && par[i,j]<1) stop("Please choose 'par' of the Tawn copula in [1,oo).") + if ((family[i,j]==104 || family[i,j]==114 || family[i,j]==204 || family[i,j]==214) && (par2[i,j]<0 || par2[i,j]>1)) stop("Please choose 'par2' of the Tawn copula in [0,1].") + if ((family[i,j]==124 || family[i,j]==134 || family[i,j]==224 || family[i,j]==234) && par[i,j]>-1) stop("Please choose 'par' of the Tawn copula in (-oo,-1].") + if ((family[i,j]==124 || family[i,j]==134 || family[i,j]==224 || family[i,j]==234) && (par2[i,j]<0 || par2[i,j]>1)) stop("Please choose 'par2' of the Tawn copula in [0,1].") + } + } + } + npar = sum(RVM$family >= 1, na.rm=TRUE) + sum(RVM$family %in% c(2,7:10,17:20,27:30,37:40,104,114,124,134,204,214,224,234),na.rm=TRUE) npar_pair = (RVM$family>=1)+(RVM$family%in%c(2,7:10,17:20,27:30,37:40,104,114,124,134,204,214,224,234)) - like = RVineLogLik(data,RVM) + RVM2=RVM + RVM2$par=par + RVM2$par2=par2 + + like = RVineLogLik(data,RVM2) AIC = -2*like$loglik + 2*npar pair.AIC = -2*like$V$value + 2*npar_pair @@ -38,10 +91,63 @@ if(n != dim(RVM)) stop("Dimensions of 'data' and 'RVM' do not match.") if(is(RVM) != "RVineMatrix") stop("'RVM' has to be an RVineMatrix object.") + par[is.na(par)]=0 + par[upper.tri(par,diag=T)]=0 + par2[is.na(par2)]=0 + par2[upper.tri(par2,diag=T)]=0 + + if(any(par!=NA) & dim(par)[1]!=dim(par)[2]) stop("Parameter matrix has to be quadratic.") + if(any(par2!=NA) & dim(par2)[1]!=dim(par2)[2]) stop("Second parameter matrix has to be quadratic.") + + family=RVM$family + + if(!all(par %in% c(0,NA))) + { + for(i in 2:dim(RVM$Matrix)[1]) + { + for(j in 1:(i-1)) + { + if((family[i,j]==1 || family[i,j]==2) && abs(par[i,j])>=1) stop("The parameter of the Gaussian and t-copula has to be in the interval (-1,1).") + if(family[i,j]==2 && par2[i,j]<=2) stop("The degrees of freedom parameter of the t-copula has to be larger than 2.") + if((family[i,j]==3 || family[i,j]==13) && par[i,j]<=0) stop("The parameter of the Clayton copula has to be positive.") + if((family[i,j]==4 || family[i,j]==14) && par[i,j]<1) stop("The parameter of the Gumbel copula has to be in the interval [1,oo).") + if((family[i,j]==6 || family[i,j]==16) && par[i,j]<=1) stop("The parameter of the Joe copula has to be in the interval (1,oo).") + if(family[i,j]==5 && par[i,j]==0) stop("The parameter of the Frank copula has to be unequal to 0.") + if((family[i,j]==7 || family[i,j]==17) && par[i,j]<=0) stop("The first parameter of the BB1 copula has to be positive.") + if((family[i,j]==7 || family[i,j]==17) && par2[i,j]<1) stop("The second parameter of the BB1 copula has to be in the interval [1,oo).") + if((family[i,j]==8 || family[i,j]==18) && par[i,j]<=0) stop("The first parameter of the BB6 copula has to be in the interval [1,oo).") + if((family[i,j]==8 || family[i,j]==18) && par2[i,j]<1) stop("The second parameter of the BB6 copula has to be in the interval [1,oo).") + if((family[i,j]==9 || family[i,j]==19) && par[i,j]<1) stop("The first parameter of the BB7 copula has to be in the interval [1,oo).") + if((family[i,j]==9 || family[i,j]==19) && par2[i,j]<=0) stop("The second parameter of the BB7 copula has to be positive.") + if((family[i,j]==10 || family[i,j]==20) && par[i,j]<1) stop("The first parameter of the BB8 copula has to be in the interval [1,oo).") + if((family[i,j]==10 || family[i,j]==20) && (par2[i,j]<=0 || par2[i,j]>1)) stop("The second parameter of the BB8 copula has to be in the interval (0,1].") + if((family[i,j]==23 || family[i,j]==33) && par[i,j]>=0) stop("The parameter of the rotated Clayton copula has to be negative.") + if((family[i,j]==24 || family[i,j]==34) && par[i,j]>-1) stop("The parameter of the rotated Gumbel copula has to be in the interval (-oo,-1].") + if((family[i,j]==26 || family[i,j]==36) && par[i,j]>=-1) stop("The parameter of the rotated Joe copula has to be in the interval (-oo,-1).") + if((family[i,j]==27 || family[i,j]==37) && par[i,j]>=0) stop("The first parameter of the rotated BB1 copula has to be negative.") + if((family[i,j]==27 || family[i,j]==37) && par2[i,j]>-1) stop("The second parameter of the rotated BB1 copula has to be in the interval (-oo,-1].") + if((family[i,j]==28 || family[i,j]==38) && par[i,j]>=0) stop("The first parameter of the rotated BB6 copula has to be in the interval (-oo,-1].") + if((family[i,j]==28 || family[i,j]==38) && par2[i,j]>-1) stop("The second parameter of the rotated BB6 copula has to be in the interval (-oo,-1].") + if((family[i,j]==29 || family[i,j]==39) && par[i,j]>-1) stop("The first parameter of the rotated BB7 copula has to be in the interval (-oo,-1].") + if((family[i,j]==29 || family[i,j]==39) && par2[i,j]>=0) stop("The second parameter of the rotated BB7 copula has to be negative.") + if((family[i,j]==30 || family[i,j]==40) && par[i,j]>-1) stop("The first parameter of the rotated BB8 copula has to be in the interval (-oo,-1].") + if((family[i,j]==30 || family[i,j]==40) && (par2[i,j]>=0 || par2[i,j]<(-1))) stop("The second parameter of the rotated BB8 copula has to be in the interval [-1,0).") + if ((family[i,j]==104 || family[i,j]==114 || family[i,j]==204 || family[i,j]==214) && par[i,j]<1) stop("Please choose 'par' of the Tawn copula in [1,oo).") + if ((family[i,j]==104 || family[i,j]==114 || family[i,j]==204 || family[i,j]==214) && (par2[i,j]<0 || par2[i,j]>1)) stop("Please choose 'par2' of the Tawn copula in [0,1].") + if ((family[i,j]==124 || family[i,j]==134 || family[i,j]==224 || family[i,j]==234) && par[i,j]>-1) stop("Please choose 'par' of the Tawn copula in (-oo,-1].") + if ((family[i,j]==124 || family[i,j]==134 || family[i,j]==224 || family[i,j]==234) && (par2[i,j]<0 || par2[i,j]>1)) stop("Please choose 'par2' of the Tawn copula in [0,1].") + } + } + } + npar = sum(RVM$family >= 1, na.rm=TRUE) + sum(RVM$family %in% c(2,7:10,17:20,27:30,37:40,104,114,124,134,204,214,224,234),na.rm=TRUE) npar_pair = (RVM$family>=1)+(RVM$family%in%c(2,7:10,17:20,27:30,37:40,104,114,124,134,204,214,224,234)) - like = RVineLogLik(data,RVM) + RVM2=RVM + RVM2$par=par + RVM2$par2=par2 + + like = RVineLogLik(data,RVM2) BIC = -2*like$loglik + log(T)*npar pair.BIC = -2*like$V$value + log(T)*npar_pair Modified: pkg/inst/ChangeLog =================================================================== --- pkg/inst/ChangeLog 2014-01-24 09:49:25 UTC (rev 48) +++ pkg/inst/ChangeLog 2014-01-25 13:16:25 UTC (rev 49) @@ -3,14 +3,16 @@ Current authors: Ulf Schepsmeier, Tobias Erhardt and Benedikt Graeler Former authors: Eike Brechmann and Jakob Stöber -Version 1.2-1 (January 24, 2014) +Version 1.2-1 (January 25, 2014) -New functionality: +- New functionality: * RVineSim allows to commit a (N,d)-matrix of U[0,1] random variates to be transformed to the copula sample. For example if you want to use quasi random variables instead of the pseudo random variables implemented in R (Thanks to Marius Hofert) - Bug fix: * RVineMLE: the optim argument "parscale" was not correctly defined for all cases. + * RVineAIC/BIC: Instead of the function arguments "par" and "par2" the calculation was based on RVM$par and RVM$par2. + This is corrected now. (reported by Marcel Duellmann; thanks) Version 1.2 (October 09, 2013) From noreply at r-forge.r-project.org Mon Jan 27 17:40:01 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 27 Jan 2014 17:40:01 +0100 (CET) Subject: [Vinecopula-commits] r50 - in pkg: . src Message-ID: <20140127164001.AD88A1812C1@r-forge.r-project.org> Author: ben_graeler Date: 2014-01-27 17:40:00 +0100 (Mon, 27 Jan 2014) New Revision: 50 Modified: pkg/DESCRIPTION pkg/src/likelihood.c pkg/src/rvine.c pkg/src/rvinederiv2.c Log: - Rotation of Tawn Copula in LL_mod2 corrected - replaced occurences of LL_mod by LL_mod2 and swaped the arguments for u and v Modified: pkg/DESCRIPTION =================================================================== --- pkg/DESCRIPTION 2014-01-25 13:16:25 UTC (rev 49) +++ pkg/DESCRIPTION 2014-01-27 16:40:00 UTC (rev 50) @@ -2,7 +2,7 @@ Type: Package Title: Statistical inference of vine copulas Version: 1.2-1 -Date: 2013-11-27 +Date: 2014-01-27 Author: Ulf Schepsmeier, Jakob Stoeber, Eike Christian Brechmann, Benedikt Graeler Maintainer: Ulf Schepsmeier Depends: R (>= 2.11.0), MASS, mvtnorm, igraph Modified: pkg/src/likelihood.c =================================================================== --- pkg/src/likelihood.c 2014-01-25 13:16:25 UTC (rev 49) +++ pkg/src/likelihood.c 2014-01-27 16:40:00 UTC (rev 50) @@ -1,1827 +1,1829 @@ -/* -** likelihood.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/memoryhandling.h" -#include "include/tools.h" -#include "include/likelihood.h" -#include "include/evCopula.h" -#include - -#define UMAX 1-1e-10 - -#define UMIN 1e-10 - -#define XEPS 1e-4 - - -////////////////////////////////////////////////////////////// -// Generatorfunction of BB1, BB6, BB7 and BB8 -// Input: -// u variable -// n number of iterations -// param vector of parameter (theta, delta) -// copula copula family (7=BB1, 8=BB6, 9=BB7, 10=BB10) -// out outout -////////////////////////////////////////////////////////////// -/* -void gen(double* u, int* n, double* param, int* copula, double* out) -{ - int j; - double *h; - h = Calloc(*n,double); - - for(j=0;j<*n;j++) - { - if(u[j]==0) h[j] = 0; - else if (u[j]==1) h[j] = u[j]; - else - { - if(*copula==3) //Clayton - { - h[j] = 1/param[0]*(pow(u[j],(-param[0]))-1); - } - if(*copula==4) //Gumbel - { - h[j] = pow((-log(u[j])),param[0]); - } - if(*copula==5) //Frank - { - h[j] = -log((exp(-param[0]*u[j])-1)/(exp(-param[0])-1)); - } - if(*copula==6) //Joe - { - h[j] = -log(1-pow((1-u[j]),param[0])); - } - if(*copula==7) //BB1 - { - h[j] = pow((pow(u[j],(-param[0]))-1),param[1]); - } - else if(*copula==8) //BB6 - { - h[j] = pow((-log(-pow(1-u[j],param[0])+1)),param[1]); - } - else if(*copula==9) //BB7 - { - h[j] = pow(1-pow(1-u[j],param[0]),-param[1])-1; - } - else if(*copula==10) //BB8 - { - h[j] = -log( (1-pow(1-param[1]*u[j],param[0])) / (1-pow(1-param[1],param[0])) ); - } - } - out[j]=h[j]; - } - Free(h); -} -*/ - -////////////////////////////////////////////////////////////// -// Inverse generator of BB1, BB6, BB7 and BB8 -// Input: -// u variable -// n number of iterations -// param vector of parameter (theta, delta) -// copula copula family (7=BB1, 8=BB6, 9=BB7, 10=BB8) -// out outout -////////////////////////////////////////////////////////////// -/* -void genInv(double* u, int* n, double* param, int* copula, double* out) -{ - int j; - double *h; - h = Calloc(*n,double); - - for(j=0;j<*n;j++) - { - if(u[j]==0) h[j] = 0; - else if (u[j]==1) h[j] = u[j]; - else - { - if(*copula==3) //Clayton - { - h[j] = pow((1+param[0]*u[j]),(-1/param[0])); - } - if(*copula==4) //Gumbel - { - h[j] = exp(-pow(u[j],1/param[0])); - } - if(*copula==5) //Frank - { - h[j] = -1/param[0]*log(1-exp(-u[j])*(1-exp(-param[0]))); - } - if(*copula==6) //Joe - { - h[j] = 1-pow((1-exp(-u[j])),1/param[0]); - } - if(*copula==7) //BB1 - { - h[j] = pow(1+pow(u[j],1/param[1]),(-1/param[0])); - } - else if(*copula==8) //BB6 - { - h[j] = 1-pow(1-exp(-pow(u[j],1/param[1])),1/param[0]); - } - else if(*copula==9) //BB7 - { - h[j] = 1-pow(1-pow(1+u[j],-1/param[1]),(1/param[0])); - } - else if(*copula==10) //BB8 - { - h[j] = 1/param[1] * ( 1-pow(1-(1-pow(1-param[1],param[0]))*exp(-u[j]),1/param[0]) ); - } - } - out[j]=h[j]; - } - Free(h); -} -*/ - -////////////////////////////////////////////////////////////// -// First derivative of the generator of BB1, BB2 and BB7 -// Input: -// u variable -// n number of iterations -// param vector of parameter (theta, delta) -// copula copula family (7=BB1, 8=BB6, 9=BB7) -// out outout -////////////////////////////////////////////////////////////// -/* -void genDrv(double* u, int* n, double* param, int* copula, double* out) -{ - int j; - double *h; - h = Calloc(*n,double); - - for(j=0;j<*n;j++) - { - if(u[j]==0) h[j] = 0; - else if (u[j]==1) h[j] = u[j]; - else - { - if(*copula==7) //BB1 - { - h[j] = -(param[0]*param[1])*pow(pow(u[j],-param[0])-1,param[1]-1)*pow(u[j],-1-param[0]); - } - else if(*copula==8) //BB6 - { - h[j] = pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * param[1] * pow(1-u[j],param[0]-1) * param[0] / (pow(1-u[j],param[0])-1); - } - else if(*copula==9) //BB7 - { - h[j] = -(param[0]*param[1])*pow(1-u[j],param[0]-1)*pow(1-pow(1-u[j],param[0]),-1-param[1]); - } - else if(*copula==10) //BB8 - { - h[j] = -param[0] * param[1] * ( pow(1-param[1]*u[j],param[0]-1) ) / ( 1-pow(1-param[1]*u[j],param[0]) ); - } - } - out[j]=h[j]; - } - Free(h); -} -*/ - -////////////////////////////////////////////////////////////// -// Second derivative of the generator of BB1, BB6, BB7 and BB8 -// Input: -// u variable -// n number of iterations -// param vector of parameter (theta, delta) -// copula copula family (7=BB1, 8=BB6, 9=BB7, 10=BB8) -// out outout -////////////////////////////////////////////////////////////// -/* -void genDrv2(double* u, int* n, double* param, int* copula, double* out) -{ - int j; - double *h; - h = Calloc(*n,double); - - for(j=0;j<*n;j++) - { - if(u[j]==0) h[j] = 0; - else if (u[j]==1) h[j] = u[j]; - else - { - if(*copula==7) //BB1 - { - h[j] = param[0]*param[1]*pow(u[j],-2-param[0])*pow(pow(u[j],-param[0])-1,param[1]-2)*((1+param[0]*param[1])*pow(u[j],-param[0])-param[0]-1); - } - else if(*copula==8) //BB6 - { - h[j] = ( param[0]*param[1] * ( - pow(-log(-pow(1-u[j],param[0])+1),param[1]-2) * pow(1-u[j],2*param[0]-2) * param[0]*param[1] - - pow(-log(-pow(1-u[j],param[0])+1),param[1]-2) * pow(1-u[j],2*param[0]-2) * param[0] - - pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * pow(1-u[j],param[0]-2) * param[0] - - pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * pow(1-u[j],2*param[0]-2) + - pow(-log(-pow(1-u[j],param[0])+1),param[1]-1) * pow(1-u[j],param[0]-2) ) ) / pow(pow(1-u[j],param[0])-1,2); - } - else if(*copula==9) //BB7 - { - h[j] = param[0]*param[1]*pow(1-u[j],param[0]-2)*pow(1-pow(1-u[j],param[0]),-2-param[1])*((1+param[0]*param[1])*pow(1-u[j],param[0])+param[0]-1); - } - else if(*copula==10) //BB8 - { - h[j] = ( pow(param[1],2) * param[0] * - (pow(1-u[j]*param[1],param[0]-2) * param[0] + pow(1-u[j]*param[1],2*param[0]-2) - pow(1-u[j]*param[1],param[0]-2)) ) / - ( pow(pow(1-u[j]*param[1],param[0])-1,2) ); - } - } - out[j]=h[j]; - } - Free(h); -} -*/ - -////////////////////////////////////////////////////////////// -// Copula of BB1, BB6, BB7 and BB8 -// Input: -// u variable 1 -// v variable 2 -// n number of iterations -// param vector of parameter (theta, delta) -// copula copula family (7=BB1, 8=BB6, 9=BB7, 1=BB8) -// out outout -////////////////////////////////////////////////////////////// -/* -void copCdf(double* u, double* v, int* n, double* param, int* copula, double* out) -{ - int j; - double *out1; - double *out2; - double *out3; - out1 = Calloc(*n,double); - out2 = Calloc(*n,double); - out3 = Calloc(*n,double); - gen(u, n, param, copula, out1); - gen(v, n, param, copula, out2); - for(j=0;j<*n;j++) - { - out3[j]=out1[j]+out2[j]; - } - genInv(out3 , n, param, copula, out); - Free(out1); - Free(out2); - Free(out3); -} -*/ - -////////////////////////////////////////////////////////////// -// Copula density of BB1, BB6, BB7 and BB8 -// Input: -// u variable 1 -// v variable 2 -// n number of iterations -// param vector of parameter (theta, delta) -// copula copula family (7=BB1, 8=BB6, 9=BB7, 10=BB8) -// out outout -////////////////////////////////////////////////////////////// -/* -void copPdf(double* u, double* v, int* n, double* param, int* copula, double* out) -{ - int j; - double *out1, *out2, *out3, *out4, *out5; - out1 = Calloc(*n,double); - out2 = Calloc(*n,double); - out3 = Calloc(*n,double); - out4 = Calloc(*n,double); - out5 = Calloc(*n,double); - copCdf(u,v,n,param,copula,out1); - genDrv2(out1,n,param,copula,out2); - genDrv(u,n,param,copula,out3); - genDrv(v,n,param,copula,out4); - genDrv(out1,n,param,copula,out5); - for(j=0;j<*n;j++) - { - out[j]=-(out2[j]*out3[j]*out4[j])/pow(out5[j],3); - } - Free(out1); - Free(out2); - Free(out3); - Free(out4); - Free(out5); -} -*/ - -/////////////////////////////////////////////////////// -// New - -double log1mexp(double a) -{ - double result; -if (aUMAX && v[j]>UMAX){ out[j]=1;} - else if(u[j]>UMAX){ out[j]=v[j];} - else if(v[j]>UMAX){ out[j]=u[j];} - else if(u[j]0) { - t1=-log1p(exp(-param[0]) * expm1(param[0]-u[j]*param[0])/expm1(-param[0])); - t2=-log1p(exp(-param[0]) * expm1(param[0]-v[j]*param[0])/expm1(-param[0])); - out[j] = -log1mexp(t1+t2-log1mexp(param[0]))/param[0]; - } else { - out[j] =-1/param[0] * log(1 + exp(-(-log((exp(-param[0] * u[j]) - 1)/(exp(-param[0]) - 1)) + -log((exp(-param[0] * v[j]) - 1)/(exp(-param[0]) - 1)))) * (exp(-param[0]) - 1)); - } - } - else if(*copula==6) //Joe - { - t1 = 1-u[j]; - t2 = 1-v[j]; - t3 = pow(t1,param[0]); - t4 = pow(t2,param[0]); - t5 = t3*t4; - out[j] = 1-pow(t3+t4-t5,1/param[0]); - } - else if(*copula==7) //BB1 - { - t1 = pow(u[j],-param[0]); - t2 = pow(v[j],-param[0]); - t3 = t1-1; - t4 = t2-1; - t5 = pow(t3,param[1]); - t6 = pow(t4,param[1]); - t7 = t5+t6; - t8 = pow(t7,1/param[1]); - out[j] = pow(1+t8,-1/param[0]); - } - else if(*copula==8) //BB6 - { - t1 = 1-u[j]; - t2 = 1-v[j]; - t3 = pow(t1,param[0]); - t4 = pow(t2,param[0]); - t5 = 1-t3; - t6 = 1-t4; - t7 = -log(t5); - t8 = -log(t6); - t9 = pow(t7,param[1]); - t10 = pow(t8,param[1]); - t11 = t9+t10; - t12 = pow(t11,1/param[1]); - t13 = exp(-t12); - t14 = 1-t13; - out[j] = 1-pow(t14,1/param[0]); - } - else if(*copula==9) //BB7 - { - t1 = 1-u[j]; - t2 = 1-v[j]; - t3 = pow(t1,param[0]); - t4 = pow(t2,param[0]); - t5 = 1-t3; - t6 = 1-t4; - t7 = pow(t5,-param[1]); - t8 = pow(t6,-param[1]); - t9 = t7+t8-1; - t10 = pow(t9,-1/param[1]); - t11 = 1-t10; - t12 = pow(t11,1/param[0]); - out[j] = 1-t12; - } - else if(*copula==10) //BB8 - { - double nu; - t1 = param[1]*u[j]; - t2 = param[1]*v[j]; - t3 = 1-t1; - t4 = 1-t2; - t5 = pow(t3,param[0]); - t6 = pow(t4,param[0]); - t7 = 1-t5; - t8 = 1-t6; - nu = 1-param[1]; - nu = pow(nu,param[0]); - nu = 1-nu; - nu = 1/nu; - t9 = 1-nu*t7*t8; - t10 = pow(t9,1/param[0]); - out[j] = 1/param[1]*(1-t10); - } - else if(*copula==41) - { - t1=qgamma(1.0-u[j],param[0],1,1,0); - t2=qgamma(1.0-v[j],param[0],1,1,0); - t3=pow(pow(t1,param[0])+pow(t2,param[0]),(1.0/param[0])); - out[j]=1.0-pgamma(t3,param[0],1,1,0); - } - } - } - -} - - - - - -void dbb1(double* u, double* v, int* n, double* param, double* out) -{ - int i; - double th, de; - double t1, t2, t3, t16, t17, t38, t39, t4, t5, t6, t7, t9, t10, t12, t13, t20, t24, t25, t27, t29, t32, t33, t34, t36, t43, t59; - - th = param[0]; - de = param[1]; - - for(i=0;i<*n;i++) - { - t1 = pow(u[i],(-th)); - t2 = t1-1.0; - t3 = pow(t2,de); - t16 = 1./u[i]; - t17 = 1./t2; - t38 = t1*t16; - t39 = t38*t17; - t4 = pow(v[i],(-th)); - t5 = t4-1.0; - 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; - t24 = t9*t9; - t25 = t12*t24; - t27 = 1./v[i]; - t29 = 1./t5; - t32 = t7*t7; - t33 = 1./t32; - t34 = t10*t10; - t36 = t33/t34; - t43 = t4*th; - t59 = t43*t27*t29; - - out[i] = t25*t6*t27*t4*t29*t36*t3*t39-t13*t6*t43*t27*t29*t33*t3*t38*t17*t20+ - t13*t3*t38*t17*t33*t20*t6*de*t59+t25*t3*t39*t36*t6*t59; - } - -} - - -void dbb6(double* u, double* v, int* n, double* param, double* out) -{ - int i; - double th, de; - double t1, t2, t3, t4, t5, t12, t16, t32, t38, t39, t40, t47, t50, t61, t90, t6, t7, t8, t9, t10, t11, t13, t14, t35, t36, t37, t42, t48, t53, t56, t57, t59, t78, t80, t87, t93; - - 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; - t32 = de-1.0; - t38 = 2.0*de; - t39 = -1.0+t38; - t40 = pow(-t4,t39); - t47 = 3.0*de-1.0; - t50 = pow(-t4,t32); - t61 = pow(-t4,t47); - t90 = pow(-t4,t38); - 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); - t35 = pow(t11,-2.0*t32*t12); - t36 = t35*th; - t37 = exp(t13); - t42 = pow(-t9,t39); - t48 = pow(-t9,t47); - t53 = t13*de; - t56 = pow(-t9,t32); - t57 = t37*t50*t56; - t59 = t13*th; - t78 = t37-1.0; - t80 = pow(t78*t14,t16); - t87 = t78*t78; - t93 = pow(-t9,t38); - - out[i] = (2.0*t36*t37*t40*t42+t36*t37*t48*t50+t53*th*t57-t59*t57+ - t36*t37*t61*t56-2.0*t35*t40*t42-t35*t61*t56-t53*th*t50*t56+t59*t50*t56- - t35*t48*t50) *t80*t7*t2/t3/t8/t87/(t90+2.0*t5*t10+t93)/t1/t6; - } - -} - - -void dbb7(double* u, double* v, int* n, double* param, double* out) -{ - int i; - double th, de; - double t1, t2, t3, t4, t5, t6, t7, t8, t9, t11, t12, t14, t15, t16, t18, t20, t23, t24, t25, t27, t30, t31, t32, t35, t37, t42, t54; - - 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 = pow(t3,-de); - t5 = 1.0-v[i]; - t6 = pow(t5,th); - t7 = 1.0-t6; - t8 = pow(t7,-de); - t9 = t4+t8-1.0; - t11 = pow(t9,-1.0/de); - t12 = 1.0-t11; - t14 = pow(t12,1.0/th); - t15 = t11*t11; - t16 = t14*t15; - t18 = 1./t5; - t20 = 1./t7; - t23 = t9*t9; - t24 = 1./t23; - t25 = t12*t12; - t27 = t24/t25; - t30 = t2/t1; - t31 = 1./t3; - t32 = t30*t31; - t35 = t14*t11; - t37 = t6*th; - t42 = 1./t12; - t54 = t37*t18*t20; - - out[i] = -t16*t8*t6*t18*t20*t27*t4*t32 + t35*t8*t37*t18*t20*t24*t4*t30*t31*t42+ - t35*t4*t30*t31*t24*t42*t8*de*t54+t16*t4*t32*t27*t8*t54; - } - -} - - -void dbb8(double* u, double* v, int* n, double* param, double* out) -{ - int i; - double th, de; - double t2, t3, t12, t16, t6, t7, t10, t11, t33, t38, t39, t49, t59, t69, t25, t26, t29, t44, t45, t50, t54, t62, t67; - - th = param[0]; - de = param[1]; - - for(i=0;i<*n;i++) - { - t2 = 1.0-de*u[i]; - t3 = pow(t2,th); - //t4 = 1.0-t3; - t10 = 1.0-de; - t11 = pow(t10,th); - t12 = 1.0-t11; - //t13 = 1/t12; - t16 = 1/th; - t33 = th*t3; - t38 = 2.0*th; - t39 = pow(t10,t38); - t49 = pow(t2,t38); - t59 = pow(t10,3.0*th); - t69 = t12*t12; - 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); - t25 = t3*t7; - t26 = t11-t7-t3+t25; - t29 = pow(-t26/t12,t16); - t44 = pow(t6,t38); - t45 = t3*t44; - t50 = t49*t7; - t54 = t49*t44; - t62 = -2.0*t25*t11+t25-t33*t7+3.0*t33*t7*t11-3.0*t33*t7*t39+t25*t39+ - 2.0* t45*t11-t45*t39+2.0*t50*t11-t50*t39-2.0*t54*t11+t54*t39+t54- - t50-t45+t33*t7*t59; - t67 = t26*t26; - out[i] = -de*t29*t62/t6/t2/t67/t69; - } - -} - - - -////////////////////////////////////////////////////////////// -// New function to compute log-likelihood for bivariate copula (for the rotated copulas -// Input: -// family copula family (0=independent, 1=gaussian, 2=student, 3=clayton, 4=gumbel, 5=frank) -// n sample size -// u first variable of data set -// v second variable of data set -// theta dependency parameter -// nu degrees-of-freedom for students copula -// loglik output -////////////////////////////////////////////////////////////// - -void LL_mod(int* family, int* n, double* u, double* v, double* theta, double* nu, double* loglik) -{ - double* negv; - double* 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); - LL(&nfamily, n, u, v, &ntheta, nu, loglik); - }else{ - ntheta=-2*(*theta)/(1+*theta); - for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} - LL(&nfamily, n, u, negv, &ntheta, &nnu, loglik); - } - }else if((*family==44)) - { - nfamily=4; - if(*theta > 0){ - ntheta=1/(1-*theta); - LL(&nfamily, n, u, v, &ntheta, nu, loglik); - }else{ - ntheta=1/(1+*theta); - for (int i = 0; i < *n; ++i) {negv[i]=1 - v[i];} - LL(&nfamily, n, u, negv, &ntheta, &nnu, loglik); - } - }else{ - if((*family==23) | (*family==24) | (*family==26) | (*family==27) | (*family==28) | (*family==29) | (*family==30) | (*family==61)) // 90° rotated copulas - { - nfamily = (*family)-20; - for (int i = 0; i < *n; ++i) {negv[i] = 1 - v[i];} - LL(&nfamily, n, u, negv, &ntheta, &nnu, loglik); - } - else if((*family==33) | (*family==34) | (*family==36) | (*family==37) | (*family==38) | (*family==39) | (*family==40) | (*family==71)) // 270° rotated copulas - { - nfamily = (*family)-30; - for (int i = 0; i < *n; ++i) {negu[i] = 1 - u[i];} - LL(&nfamily, n, negu, v, &ntheta, &nnu, loglik); - } - else if((*family==124) | (*family==224)) - { - nfamily = (*family)-20; - for (int i = 0; i < *n; ++i) {negu[i] = 1 - u[i];} - LL(&nfamily, n, u, negv, &ntheta, nu, loglik); - } - else if((*family==134) | (*family==234)) - { - nfamily = (*family)-30; - for (int i = 0; i < *n; ++i) {negv[i] = 1 - v[i];} - LL(&nfamily, n, negu, v, &ntheta, nu, loglik); - } - else { - LL(family, n, u, v, theta, nu, loglik); - } - } - free(negv); - free(negu); -} - -void LL_mod2(int* family, int* n, double* u, double* v, double* theta, double* nu, double* loglik) -{ - double* negv; - double* 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); - LL(&nfamily, n, u, v, &ntheta, nu, loglik); - }else{ - ntheta=-2*(*theta)/(1+*theta); - for (int i = 0; i < *n; ++i) {negu[i] = 1 - u[i];} - LL(&nfamily, n, negu, v, &ntheta, &nnu, loglik); - } - }else if((*family==44)) - { - nfamily=4; - if(*theta > 0){ - ntheta=1/(1-*theta); - LL(&nfamily, n, u, v, &ntheta, nu, loglik); - }else{ - ntheta=1/(1+*theta); - for (int i = 0; i < *n; ++i) {negu[i] = 1 - u[i];} - LL(&nfamily, n, negu, v, &ntheta, &nnu, loglik); - } - }else{ - - if((*family==23) | (*family==24) | (*family==26) | (*family==27) | (*family==28) | (*family==29) | (*family==30) | (*family==61)) // 90° rotated copulas - { - nfamily = (*family)-20; - for (int i = 0; i < *n; ++i) {negu[i] = 1 - u[i];} - LL(&nfamily, n, negu, v, &ntheta, &nnu, loglik); - } - else if((*family==33) | (*family==34) | (*family==36) | (*family==37) | (*family==38) | (*family==39) | (*family==40) | (*family==71)) // 270° rotated copulas - { - nfamily = (*family)-30; - for (int i = 0; i < *n; ++i) {negv[i] = 1 - v[i];} - LL(&nfamily, n, u, negv, &ntheta, &nnu, loglik); - } - else if((*family==124) | (*family==224)) - { - nfamily = (*family)-20; - for (int i = 0; i < *n; ++i) {negu[i] = 1 - u[i];} - LL(&nfamily, n, negu, v, &ntheta, nu, loglik); - } - else if((*family==134) | (*family==234)) - { - nfamily = (*family)-30; - for (int i = 0; i < *n; ++i) {negv[i] = 1 - v[i];} - LL(&nfamily, n, u, negv, &ntheta, nu, loglik); - } - else { - LL(family, n, u, v, theta, nu, loglik); - } - } - free(negv); - free(negu); -} - - -////////////////////////////////////////////////////////////// -// Function to compute log-likelihood for bivariate copula -// Input: -// family copula family (0=independent, 1=gaussian, 2=student, 3=clayton, 4=gumbel, 5=frank) -// n sample size -// u first variable of data set -// v second variable of data set -// theta dependency parameter -// nu degrees-of-freedom for students copula -// loglik output -////////////////////////////////////////////////////////////// -void LL(int* family, int* n, double* u, double* v, double* theta, double* nu, double* loglik) -{ - int j; - double *dat, rho, ll=0.0, t1=0.0, t2=0.0, f; - //Allocate memory: - dat = Calloc(2,double); - - for(int i=0;i<*n;i++) - { - if(u[i]UMAX) u[i]=UMAX; - if(v[i]UMAX) v[i]=UMAX; - } - - //Compute log-likelihood: - if(*family==0) //independent - ll = 0; - else if(*family==1) //Gaussian - { - rho=*theta; - for(j=0;j<*n;j++) - { - dat[0]=u[j]; dat[1]=v[j]; - 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 ll += log(f); - } - } - else if(*family==2) //Student - { - rho=*theta; - for(j=0;j<*n;j++) - { - dat[0] = u[j]; dat[1] = v[j]; - 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 ll += log(f); - } - } - else if(*family==3) //Clayton - { - if(*theta == 0) ll = 0; - else if(*theta < XEPS) ll = 0; - else - { - for(j=0;j<*n;j++) - { - 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; - } - } - } - else if(*family==4) //Gumbel - { - for(j=0;j<*n;j++) - { - dat[0] = u[j]; dat[1] = v[j]; - t1 = pow(-log(dat[0]),*theta)+pow(-log(dat[1]),*theta); - f= -pow(t1,1.0/(*theta))+(2.0/(*theta)-2.0)*log(t1)+(*theta-1.0)*log(log(dat[0])*log(dat[1]))-log(dat[0]*dat[1])+log1p((*theta-1.0)*pow(t1,-1.0/(*theta))); - - ll += f; - } - } - else if(*family==5) // Frank - { - for(j=0;j<*n;j++) - { - dat[0] = u[j]; dat[1] = v[j]; - f = (*theta*(exp(*theta)-1.0)*exp(*theta*dat[1]+*theta*dat[0]+*theta))/pow(exp(*theta*dat[1]+*theta*dat[0])-exp(*theta*dat[1]+*theta)-exp(*theta*dat[0]+*theta)+exp(*theta),2.0); - if(log(f)>XINFMAX) ll += log(XINFMAX); - else ll += log(f); - } - } - else if(*family==6) //Joe - { - for(j=0;j<*n;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 ll += log(f); - } - } - else if(*family==7) //BB1 - { - if(*theta == 0){ - for(j=0;j<*n;j++) - { - 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; - } - }else{ - /* - double part1, part2, part3, part4; - - for(j=0;j<*n;j++) - { - part1=pow(1+pow(pow(pow(u[j],-*theta)-1,*nu)+pow(pow(v[j],-*theta)-1,*nu),1/(*nu)),-1/(*theta)-2); - part2=pow(pow(pow(u[j],-*theta)-1,*nu)+pow(pow(v[j],-*theta)-1,*nu),2/(*nu)-2); - part3=(*theta)*(*nu)+1+(*theta)*(*nu-1)*pow(pow(pow(u[j],-*theta)-1,*nu)+pow(pow(v[j],-*theta)-1,*nu),-1/(*nu)); - part4=pow(pow(u[j],-*theta)-1,*nu-1)*pow(u[j],-*theta-1)*pow(pow(v[j],-*theta)-1,*nu-1)*pow(v[j],-*theta-1); - if(!isfinite(part1) || isnan(part1)) - { - part1=1; - } - if(!isfinite(part2) || isnan(part2)) - { - part2=1; - } - if(!isfinite(part3) || isnan(part3)) - { - part3=1; - } - if(!isfinite(part4) || isnan(part4)) - { - part4=1; - } - ll+=log(part1)+log(part2)+log(part3)+log(part4); - } - */ - double *param, *fuc; - param=Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - fuc = Calloc(*n,double); - dbb1(u, v, n, param, fuc); - for(j=0;j<*n;j++) - { - if(!isfinite(fuc[j]) || isnan(fuc[j])) - { - fuc[j]=1; - } - - if(log(fuc[j])>XINFMAX) ll += log(XINFMAX); - else ll += log(fuc[j]); - } - Free(fuc); Free(param); - } - } - else if(*family==8) //BB6 - { - double *param, *fuc; - param=Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - fuc = Calloc(*n,double); - dbb6(u, v, n, param, fuc); - for(j=0;j<*n;j++) - { - if(!isfinite(fuc[j]) || isnan(fuc[j])) - { - fuc[j]=1; - } - - if(log(fuc[j])>XINFMAX) ll += log(XINFMAX); - else ll += log(fuc[j]); - } - Free(fuc); Free(param); - } - else if(*family==9) //BB7 - { - if(*nu==0) - { - for(j=0;j<*n;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 ll += log(f); - } - } - else - { - double *param, *fuc; - param=Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - fuc = Calloc(*n,double); - dbb7(u, v, n, param, fuc); - for(j=0;j<*n;j++) - { - if(!isfinite(fuc[j]) || isnan(fuc[j])) - { - fuc[j]=1; - } - - if(log(fuc[j])>XINFMAX) ll += log(XINFMAX); - else ll += log(fuc[j]); - } - Free(fuc); Free(param); - } - } - else if(*family==10) //BB8 - { - double *param, *fuc; - param=Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - fuc = Calloc(*n,double); - dbb8(u, v, n, param, fuc); - for(j=0;j<*n;j++) - { - if(!isfinite(fuc[j]) || isnan(fuc[j])) - { - fuc[j]=1; - } - - if(log(fuc[j])>XINFMAX) ll += log(XINFMAX); - else ll += log(fuc[j]); - } - Free(fuc); Free(param); - - } - else if(*family==13) //rotated Clayton (180°) - { - if(*theta == 0) ll = 0; - else if(*theta < XEPS) ll = 0; - else - { - for(j=0;j<*n;j++) - { - dat[0] = 1-u[j]; dat[1] = 1-v[j]; - f = (1.0+*theta)*pow(dat[0]*dat[1],-1.0-*theta)*pow(pow(dat[0],-*theta)+pow(dat[1],-*theta)-1.0,-2.0-1.0/(*theta)); - f = MAX(f,0); - if(log(f)>XINFMAX) ll += log(XINFMAX); - else ll += log(f); - } - } - } - else if(*family==14) //rotated Gumbel (180°) - { - for(j=0;j<*n;j++) - { - dat[0] = 1-u[j]; dat[1] = 1-v[j]; - t1 = pow(-log(dat[0]),*theta)+pow(-log(dat[1]),*theta); - 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 ll += log(f); - } - } - else if(*family==16) //rotated Joe (180°) - { - for(j=0;j<*n;j++) - { - 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 ll += log(f); - u[j]=1-u[j]; v[j]=1-v[j]; - } - } - else if(*family==17) //rotated BB1 - { - if(*theta == 0){ - for(j=0;j<*n;j++) - { - 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; - } - }else{ - /* - double part1, part2, part3, part4; - - for(j=0;j<*n;j++) - { - u[j]=1-u[j]; v[j]=1-v[j]; - part1=pow(1+pow(pow(pow(u[j],-*theta)-1,*nu)+pow(pow(v[j],-*theta)-1,*nu),1/(*nu)),-1/(*theta)-2); - part2=pow(pow(pow(u[j],-*theta)-1,*nu)+pow(pow(v[j],-*theta)-1,*nu),2/(*nu)-2); - part3=(*theta)*(*nu)+1+(*theta)*(*nu-1)*pow(pow(pow(u[j],-*theta)-1,*nu)+pow(pow(v[j],-*theta)-1,*nu),-1/(*nu)); - part4=pow(pow(u[j],-*theta)-1,*nu-1)*pow(u[j],-*theta-1)*pow(pow(v[j],-*theta)-1,*nu-1)*pow(v[j],-*theta-1); - if(!isfinite(part1) || isnan(part1)) - { - part1=1; - } - if(!isfinite(part2) || isnan(part2)) - { - part2=1; - } - if(!isfinite(part3) || isnan(part3)) - { - part3=1; - } - if(!isfinite(part4) || isnan(part4)) - { - part4=1; - } - ll+=log(part1)+log(part2)+log(part3)+log(part4); - - u[j]=1-u[j]; v[j]=1-v[j]; - } - */ - double *param, *fuc; - param=Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - fuc = Calloc(*n,double); - int k=1; - for(j=0;j<*n;j++) - { - dat[0] = 1-u[j]; dat[1] = 1-v[j]; - - dbb1(&dat[0], &dat[1], &k, param, &fuc[j]); - - if(!isfinite(fuc[j]) || isnan(fuc[j])) - { - fuc[j]=1; - } - - if(log(fuc[j])>XINFMAX) ll += log(XINFMAX); - else ll += log(fuc[j]); - } - Free(fuc); Free(param); - } - } - else if(*family==18) //rotated BB6 - { - double *param, *fuc; - param=Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - fuc = Calloc(*n,double); - int k=1; - for(j=0;j<*n;j++) - { - dat[0] = 1-u[j]; dat[1] = 1-v[j]; - - dbb6(&dat[0], &dat[1], &k, param, &fuc[j]); - - if(!isfinite(fuc[j]) || isnan(fuc[j])) - { - fuc[j]=1; - } - - if(log(fuc[j])>XINFMAX) ll += log(XINFMAX); - else ll += log(fuc[j]); - } - Free(fuc); Free(param); - } - else if(*family==19) //rotated BB7 - { - if(*nu==0){ - for(j=0;j<*n;j++) - { - f = pow(pow(u[j],*theta)+pow(v[j],*theta)-pow(u[j],*theta)*pow(v[j],*theta),1/(*theta)-2)*pow(u[j],*theta-1)*pow(v[j],*theta-1)*(*theta-1+pow(u[j],*theta)+pow(v[j],*theta)-pow(u[j],*theta)*pow(v[j],*theta)); - if(log(f)>XINFMAX) ll += log(XINFMAX); - else ll += log(f); - } - }else{ - double *param, *fuc; - param=Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - fuc = Calloc(*n,double); - int k=1; - - for(j=0;j<*n;j++) - { - dat[0] = 1-u[j]; dat[1] = 1-v[j]; - dbb7(&dat[0], &dat[1], &k, param, &fuc[j]); - - if(!isfinite(fuc[j]) || isnan(fuc[j])) - { - fuc[j]=1; - } - - if(log(fuc[j])>XINFMAX) ll += log(XINFMAX); - else ll += log(fuc[j]); - } - Free(fuc); Free(param); - } - } - else if(*family==20) //rotated BB8 - { - double *param, *fuc; - param=Calloc(2,double); - param[0]=*theta; - param[1]=*nu; - fuc = Calloc(*n,double); - int k=1; - - for(j=0;j<*n;j++) - { - dat[0] = 1-u[j]; dat[1] = 1-v[j]; - dbb8(&dat[0], &dat[1], &k, param, &fuc[j]); - - if(!isfinite(fuc[j]) || isnan(fuc[j])) - { - fuc[j]=1; - } - - if(log(fuc[j])>XINFMAX) ll += log(XINFMAX); - else ll += log(fuc[j]); - } - Free(fuc); Free(param); - } - else if(*family==41) // New: 1-parametric asymmetric copula (from Harry Joe) - { - double tem1, tem2, con, sm, tem; - - for(j=0;j<*n;j++) - { - dat[0] = 1-u[j]; dat[1] = 1-v[j]; - tem1=qgamma(1.0-dat[0],*theta,1,1,0); - tem2=qgamma(1.0-dat[1],*theta,1,1,0); - con=gammafn(1.0+(*theta))/(*theta); - sm=pow(tem1,*theta)+pow(tem2,*theta); - tem=pow(sm,(1.0/(*theta))); - f=con*tem*exp(-tem+tem1+tem2)/sm; - - if(log(f)>XINFMAX) ll += log(XINFMAX); - else ll += log(f); - } - } - else if(*family==51) // New: rotated 1-parametric asymmetric copula (from Harry Joe) - { - double tem1, tem2, con, sm, tem; - - for(j=0;j<*n;j++) - { - tem1=qgamma(1.0-u[j],*theta,1,1,0); - tem2=qgamma(1.0-v[j],*theta,1,1,0); - con=gammafn(1.0+(*theta))/(*theta); - sm=pow(tem1,*theta)+pow(tem2,*theta); - tem=pow(sm,(1.0/(*theta))); - f=con*tem*exp(-tem+tem1+tem2)/sm; - - if(log(f)>XINFMAX) ll += log(XINFMAX); - else ll += log(f); - } - } - else if(*family==104) //New: Tawn - { - int T=1; - double par3=1.0; - for(j=0;j<*n;j++) - { - TawnPDF(&u[j], &v[j], &T, theta, nu, &par3, &f); [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/vinecopula -r 50