fCopulae/0000755000176000001440000000000012121533602012033 5ustar ripleyusersfCopulae/MD50000644000176000001440000001106012121533602012341 0ustar ripleyusers9d173aabd3c9a5b3b14d8051501b9d55 *ChangeLog 0cb2347fb3b973f3f16fde501d07ce79 *DESCRIPTION daab216d538e4c9336831f1ee102c3a2 *NAMESPACE 317854aead560ef94f8b4cb2a1abed73 *R/ArchimedeanCopulae.R c98e1779a373dccd0f27a7495077e085 *R/ArchimedeanDependency.R 3f59d5dd6cdbe1e20510a7f5b41288b6 *R/ArchimedeanGenerator.R 2cc59fdb0ac70c087a9479c67266663d *R/ArchimedeanModelling.R b57e3a4ba376494500eb9595c10759ba *R/ArchimedeanSlider.R 5f2f765cd2f3c4fbdfcbf5c8e26815a2 *R/CopulaeClass.R dedaf13b8f984b564f39abefd457900d *R/EllipticalCopulae.R fb0f99f2e97a6a465dfb9482ce3ecb46 *R/EllipticalDependency.R bfd64a34350c04bee38fd854f210ecc2 *R/EllipticalGenerator.R b0fc69379afdc4b6d176bc82ae3a5e18 *R/EllipticalModelling.R 15a11ec18b0d27cb022c75f2fb5c0e0b *R/EmpiricalCopulae.R f39b740a34936a6f0b52d390e303aa2a *R/ExtremeValueCopulae.R 7ef870e4ca4f1e2725e6ea89c72d6a98 *R/ExtremeValueDependency.R 14f45c305d55afa493917d91481543a2 *R/ExtremeValueGenerator.R 634f04b1af41577ba43cd59d9fe1f151 *R/ExtremeValueModelling.R 28904ec67ad108b7d933bed2d9602b65 *R/biv-binning.R 33ebc9f0c61e57bf206752e2ab08a84d *R/biv-density.R bf80eda2207641e1486de2649263b1cb *R/biv-gridding.R fc4cd13b043e75b73ab522de6f8a54c3 *R/builtin-adapt.R fc65d1675df34e46e66a4588990ee940 *R/bv-dcauchy.R dc89d7904bfd40ff3c1ef5c0fa96b2c0 *R/bv-delliptical.R c0ae6dd505d87ba282fc4415ae929df6 *R/bv-dnorm.R 0b956cf8e243e6b48402b9db69f034fe *R/bv-dt.R f2ce612df0bd13ab2999242cfe7e4268 *R/fCopulaeEnv.R 6728cc8658694dfd46b671e3e4c8c27b *R/mv-distributions.R 4c3f51acecd49217a4fe9d51392f3bf4 *R/mv-dsnorm.R e6fe483c6db38c6eba55b045fa52df39 *R/mv-dst.R 7e35ec452cf8d30889ad1d70e97322e4 *R/zzz.R 6042b9c5e5bec3ecc1b6959cd2858b64 *inst/COPYRIGHT.html bbb359058801e2c11c6fe242deadbbf0 *inst/unitTests/Makefile b3dfb205136831d39e558c232cdb025a *inst/unitTests/runTests.R 7b2fb68b07b1bcb3031af0bbaae9401d *inst/unitTests/runit.ArchimedeanCopulae.R c621d826877c3bfa872a49a1065d47f1 *inst/unitTests/runit.ArchimedeanDependency.R c88b95efbb2d4bc75b1ebd9df8aeb8a3 *inst/unitTests/runit.ArchimedeanGenerator.R d38397d2fc0dc6eb89002fefaf079088 *inst/unitTests/runit.ArchimedeanModelling.R 91dc804dc9dced96868be30c047d1d02 *inst/unitTests/runit.BivariateBinning.R f50aa6546fbb8a99e0cc1baf2bb5cbed *inst/unitTests/runit.BivariateDistributions.R 575bdb4f18b49212508b510479b0b631 *inst/unitTests/runit.BivariateGridding.R b44e13a7da9d597cfc4f38c512281376 *inst/unitTests/runit.CopulaClass.R 5bcf426962aa0887b0414babaede2578 *inst/unitTests/runit.EllipticalCopulae.R dcedc8a4dd5069a1d7688659a649e145 *inst/unitTests/runit.EllipticalDependency.R 834e8e6696af797bdccb1331efdd1832 *inst/unitTests/runit.EllipticalGenerator.R 1aee6b7872ea7a914870564aa07ecb27 *inst/unitTests/runit.EllipticalModelling.R 2ec7439e6cca7f30bb1ee18b4d55102d *inst/unitTests/runit.EmpiricalCopulae.R 5438f55742a20e12ad93e2cd03ca794e *inst/unitTests/runit.ExtremeValueCopulae.R a6345f50524edc1f8b467a0bc554ee84 *inst/unitTests/runit.ExtremeValueDependency.R 9a51f166fa789c12d60982413ab8dd4a *inst/unitTests/runit.ExtremeValueModelling.R df81a4997de286f18c9b699b90f462a3 *inst/unitTests/runit.ExtrmeValueGenerator.R f1531de66cb087e3ea1db8f38eb0790b *inst/unitTests/runit.MultivariateDistributions.R 90072dc7563f14dcea9fd5efa62d06f1 *man/ArchimedeanCopulae.Rd 0ed0a793f6c4f19edffd48e634de74f2 *man/ArchimedeanDependency.Rd 923c3a8f72dd5aadf567ae500042d0e2 *man/ArchimedeanGenerator.Rd 24e3120bde46175dd44cec2bec363f13 *man/ArchimedeanModelling.Rd dfb29584baeb5a8ed5365fd729473794 *man/CopulaeClass.Rd 1b6a583d76fcd8c5ebcf7ff6168d9353 *man/EllipticalCopulae.Rd d9fb7752c489e484f8e13fc9924f69c7 *man/EllipticalDependency.Rd b2331d84829d91c7c3e68985ab9ec6be *man/EllipticalGenerator.Rd cf903cfb7383427e3f13e86d8b2d63f6 *man/EllipticalModelling.Rd ab3c21c844982a45425329cbc5a72c36 *man/EmpiricalCopulae.Rd 54e45904b1fa7f404e759aa322480ae1 *man/ExtremeValueCopulae.Rd cccc2b3f0ad86c8543363bb8e2090124 *man/ExtremeValueDependency.Rd 2ea1194c235abe71dc137daf6b5beab5 *man/ExtremeValueGenerator.Rd 6f0df4139b2f7087a3cf09fd38888d2a *man/ExtremeValueModelling.Rd 357305b2bcd554f2796c353e4b1fb6b9 *man/builtin-adapt.Rd 3490377df824bbe911bdc939d19ab7d5 *man/cauchy2d.Rd 9954a6d5a30f84329924b91ea3f69a8d *man/density2.Rd 8942a58e8d7ee1fd47c93711b0be6ce2 *man/elliptical2d.Rd ecf09626afc1fdaadc23da25ce75d243 *man/gridData.Rd 4615455f3b1563a3f3cbcd4205793a27 *man/mvdist.Rd 6372c404cde30ad821a4135f0532efad *man/norm2d.Rd 488a639ab11340b0d82c8b01f6c5d341 *man/squareBinning.Rd 12fec7a4c2f41f4dcab5b24fe46d955a *man/t2d.Rd 0ae32d48faf982f676ee2721b1ea4e02 *src/adapt2.f bf0cc4d5a94a7545fdb9d6dcd73306af *src/adapt_callback.c ca566e590ec30abd0718c5375e1a446f *tests/doRUnit.R fCopulae/tests/0000755000176000001440000000000011720123747013206 5ustar ripleyusersfCopulae/tests/doRUnit.R0000644000176000001440000000151611370220745014715 0ustar ripleyusers#### doRUnit.R --- Run RUnit tests ####------------------------------------------------------------------------ ### Origianlly follows Gregor Gojanc's example in CRAN package 'gdata' ### and the corresponding section in the R Wiki: ### http://wiki.r-project.org/rwiki/doku.php?id=developers:runit ### MM: Vastly changed: This should also be "runnable" for *installed* ## package which has no ./tests/ ## ----> put the bulk of the code e.g. in ../inst/unitTests/runTests.R : if(require("RUnit", quietly = TRUE)) { ## --- Setup --- wd <- getwd() pkg <- sub("\\.Rcheck$", '', basename(dirname(wd))) library(package=pkg, character.only = TRUE) path <- system.file("unitTests", package = pkg) stopifnot(file.exists(path), file.info(path.expand(path))$isdir) source(file.path(path, "runTests.R"), echo = TRUE) } fCopulae/src/0000755000176000001440000000000012121521575012630 5ustar ripleyusersfCopulae/src/adapt_callback.c0000644000176000001440000000303312121521576015701 0ustar ripleyusers#include "S.h" #include "Rinternals.h" /* Added declaration of FORTRAN by Yohan Chalabi */ void F77_NAME(adapt)(int*, /* ndim */ double*, /* lower */ double*, /* upper */ int*, /* minpts */ int*, /* maxpts */ double*, /* eps */ double*, /* relerr */ int*, /* lenwrk */ double*, /* wrkstr */ double*, /* finest */ int*); /* ifail */ static SEXP rho; static SEXP f; /* All this routine does is call the approriate fortran function. We need this so as to properly pass the S function */ /* changed to doubles for R by Thomas Lumley */ void cadapt(int *ndim, double *lower, double *upper, int *minpts, int *maxpts, void *functn, void *env, double *eps, double *relerr, int *lenwrk, double *finest, int *ifail) { double *wrkstr; wrkstr = (double *) S_alloc(*lenwrk, sizeof(double)); /* store the R function and its environment */ rho=env; f=functn; F77_CALL(adapt)(ndim,lower,upper,minpts,maxpts,eps,relerr,lenwrk, wrkstr,finest,ifail); } /* This is the fixed routine called by adapt */ /* changed to double for R, also rewritten to use eval() */ double F77_NAME(adphlp)(int *ndim, double *z) { SEXP args,resultsxp,callsxp; double result; int i; PROTECT(args=allocVector(REALSXP,*ndim)); for (i=0;i<*ndim;i++){ REAL(args)[i]=z[i]; } PROTECT(callsxp=lang2( f,args)); PROTECT(resultsxp=eval(callsxp,rho)); result=REAL(resultsxp)[0]; UNPROTECT(3); return(result); } fCopulae/src/adapt2.f0000644000176000001440000005111712121521576014160 0ustar ripleyusersCDW The multivariate integration package adapt was added to for use in the CDW Rmetrics package fCopula. Thanks to Prof. Alan Genz who put his code CDW for the use in fCopulae under the GPL-2 License. CDW Message-ID: <4AD7A74B.3020108@math.wsu.edu> CDW Date: Thu, 15 Oct 2009 15:50:51 -0700 CDW From: Alan Genz CDW User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.21) CDW Gecko/20090402 SeaMonkey/1.1.16 CDW MIME-Version: 1.0 CDW To: Diethelm Wuertz CDW CC: Alan C Genz CDW Subject: Re: adapt CDW References: <4AD3032B.4090801@itp.phys.ethz.ch> CDW In-Reply-To: <4AD3032B.4090801@itp.phys.ethz.ch> CDW Content-Type: text/plain; charset=ISO-8859-1; format=flowed CDW Content-Transfer-Encoding: 7bit CDW Status: O CDW Dear Prof. Wuertz, CDW Thank you for your message and your interest in my adaptive integration CDW Fortran code. I would be pleased if you included my code in your open CDW source R fCopulae package under the Gnu GPL2 license. You have my CDW permission to do this. CDW Sincerely, CDW Alan Genz cMM this is the original adapt code with one modification. cMM instead of calling the external function "functn", a fixed cMM external routine adphlp is always called, and passed a pointer cMM to the external s function. cMM Michael Meyer, October 1989. subroutine adapt(ndim,a,b,minpts,maxpts,eps,relerr, * lenwrk,wrkstr,finest,ifail) c***begin prologue adapt c adaptive multidimensional integration subroutine c author: A. C. Genz, Washington State University c 19 March 1984 c************** parameters for adapt ******************************** c***** input parameters c ndim number of variables, must exceed 1, but not exceed 20 c a real array of lower limits, with dimension ndim c b real array of upper limits, with dimension ndim c minpts minimum number of function evaluations to be allowed. c on the first call to adapt minpts should be set to a c non negative value (caution... minpts is altered by adapt). c It is possible to continue a calculation to greater accuracy c by calling adapt again by decreasing eps (described below) c and resetting minpts to any negative value. c minpts must not exceed maxpts. c maxpts maximum number of function evaluations to be allowed, c which must be at least rulcls, where c rulcls = 2**ndim+2*ndim**2+6*ndim+1 c c for ndim = 2 3 4 5 6 7 8 9 10 12 15 20 c maxpts >= rulcls = 25 45 73 113 173 269 433 729 1285 4457 33309 1049497 c c a SUGGESTED value for maxpts is 100 times the above values. c c functn externally declared user defined function to be integrated. c it must have parameters (ndim,z), where z is a real array c of dimension ndim. cTSL this function has been replaced by the fixed function adhlp c eps required relative accuracy c lenwrk length of array wrkstr of working storage, the routine c needs (2*ndim+3)*(1+maxpts/rulcls)/2 for lenwrk if c maxpts function calls are used. c for guidance, if you set maxpts to 100*rulcls (see table c above) then acceptable values for lenwrk are c c for ndim = 2 3 4 5 6 7 8 9 c lenwrk = 357 561 1785 3417 6681 13209 26265 52377 c c***** OUTPUT parameters c c minpts actual number of function evaluations used by adapt c wrkstr real array of working storage of dimension (lenwrk). c relerr estimated relative accuracy of finest c finest estimated value of integral ["FINal ESTimate"] c ifail : return code c c ifail=0 for normal exit, when estimated relative accuracy c relerr is less than eps with maxpts or less function c calls made. c ifail=1 if maxpts was too small for adapt to obtain the c required relative accuracy eps. c In this case adapt returns a value of finest c with estimated relative accuracy relerr. c ifail=2 if lenwrk too small for maxpts function calls. c In this case adapt returns a value of finest with c estimated accuracy relerr using the working storage c available, but relerr will be greater than eps. c ifail=3 if ndim < 2, ndim > 20, c ifail=4 if minpts > maxpts, c ifail=5 if maxpts < rulcls or other memory problems c (which will only be found later) c*********************************************************************** c***end prologue adapt implicit none C-- Arguments: C double precision functn C external functn integer ndim, minpts,maxpts, lenwrk, ifail double precision a(ndim), b(ndim), eps, relerr, wrkstr(lenwrk), & finest C-- Local Variables: double precision center(20), width(20) double precision errmin, rgnerr, rgnval, half, zero,one,two integer divaxo, divaxn, divflg, funcls, index1, index2, * j, k, maxcls, rgnstr, rulcls, sbrgns, sbtmpp, subrgn, subtmp data zero/0d0/, one/1d0/, two/2d0/ c Check arguments; fail w/ code '3' or '4' relerr=one funcls=0 ifail=3 if(ndim.lt.2.or.ndim.gt.20) goto 990 ifail=4 if(minpts.gt.maxpts) goto 990 ifail=5 c c***** initialisation of subroutine c half=one/two rgnstr =2*ndim+3 errmin = zero maxcls = 2**ndim + 2*ndim**2 + 6*ndim+1 maxcls = min0(maxcls,maxpts) divaxo=0 c c***** end subroutine initialisation if(minpts.lt.0) then sbrgns=wrkstr(lenwrk-1) goto 280 endif do 30 j=1,ndim width(j)=(b(j)-a(j))*half 30 center(j)=a(j)+width(j) finest=zero wrkstr(lenwrk)=zero divflg=1 subrgn=rgnstr sbrgns=rgnstr C-- REPEAT --- (outermost loop) ------- 40 call bsrl(ndim,center,width,maxcls,rulcls, * errmin,rgnerr,rgnval,divaxo,divaxn) finest=finest+rgnval wrkstr(lenwrk)=wrkstr(lenwrk)+rgnerr funcls = funcls + rulcls c c***** place results of basic rule into partially ordered list c***** according to subregion error if(divflg .eq. 0) then c c***** when divflg=0 start at top of list and move down list tree to c find correct position for results from first half of recently c divided subregion 200 subtmp=2*subrgn if(subtmp.le.sbrgns) then if(subtmp.ne.sbrgns) then sbtmpp=subtmp+rgnstr if(wrkstr(subtmp).lt.wrkstr(sbtmpp)) subtmp=sbtmpp endif 210 if(rgnerr.lt.wrkstr(subtmp)) then do 220 k=1,rgnstr index1=subrgn-k+1 index2=subtmp-k+1 wrkstr(index1)=wrkstr(index2) 220 continue subrgn=subtmp goto 200 endif endif else c c*****when divflg=1 start at bottom right branch and move up list c tree to find correct position for results from second half of c recently divided subregion 230 subtmp=(subrgn/(rgnstr*2))*rgnstr if(subtmp.ge.rgnstr) then if(rgnerr.gt.wrkstr(subtmp)) then do 240 k=1,rgnstr index1=subrgn-k+1 index2=subtmp-k+1 wrkstr(index1)=wrkstr(index2) 240 continue subrgn=subtmp goto 230 endif endif endif c***** store results of basic rule in correct position in list 250 wrkstr(subrgn)=rgnerr wrkstr(subrgn-1)=rgnval wrkstr(subrgn-2)=divaxn do 260 j=1,ndim subtmp=subrgn-2*(j+1) wrkstr(subtmp+1)=center(j) wrkstr(subtmp)=width(j) 260 continue if(divflg .eq. 0) then c*** when divflg=0 prepare for second application of basic rule center(divaxo)=center(divaxo)+two*width(divaxo) sbrgns=sbrgns+rgnstr subrgn=sbrgns divflg=1 c*** loop back to apply basic rule to other half of subregion go to 40 endif c c***** end ordering and storage of basic rule results c***** make checks for possible termination of routine c 270 relerr=one if(wrkstr(lenwrk).le.zero) wrkstr(lenwrk)=zero if(dabs(finest).ne.zero) relerr=wrkstr(lenwrk)/dabs(finest) if(relerr.gt.one) relerr=one if(sbrgns+rgnstr.gt.lenwrk-2) ifail=2 if(funcls+funcls*rgnstr/sbrgns.gt.maxpts) ifail=1 if(relerr.lt.eps.and.funcls.ge.minpts) ifail=0 if(ifail.lt.3) goto 990 c c***** prepare to use basic rule on each half of subregion with largest c error 280 divflg=0 subrgn=rgnstr subtmp = 2*sbrgns/rgnstr maxcls = maxpts/subtmp errmin = dabs(finest)*eps/dfloat(subtmp) wrkstr(lenwrk)=wrkstr(lenwrk)-wrkstr(subrgn) finest=finest-wrkstr(subrgn-1) divaxo=wrkstr(subrgn-2) do 290 j=1,ndim subtmp=subrgn-2*(j+1) center(j)=wrkstr(subtmp+1) 290 width(j)=wrkstr(subtmp) width(divaxo)=width(divaxo)*half center(divaxo)=center(divaxo)-width(divaxo) c c***** loop back to apply basic rule c goto 40 c c***** termination point c 990 minpts=funcls wrkstr(lenwrk-1)=sbrgns return end subroutine bsrl(s, center,hwidth, maxvls,funcls, * errmin,errest,basest,divaxo,divaxn) implicit none C-- Arguments: integer s double precision center(s), hwidth(s) integer maxvls,funcls, divaxo,divaxn double precision errmin, errest, basest C EXTERNAL adphlp double precision adphlp C-- Local Variables: double precision intvls(20), z(20), fulsms(200), weghts(200) integer intcls, i, mindeg, maxdeg, maxord, minord integer ifail double precision zero, one, two, ten, dif, errorm, * sum0, sum1, sum2, difmax, x1, x2 data zero/0d0/, one/1d0/, two/2d0/, ten/10d0/ maxdeg = 12 mindeg = 4 minord = 0 do 10 maxord = mindeg,maxdeg call symrl(s, center, hwidth, minord, maxord, intvls, * intcls, 200, weghts, fulsms, ifail) if (ifail.eq.2) goto 20 errest = dabs(intvls(maxord) -intvls(maxord-1)) errorm = dabs(intvls(maxord-1)-intvls(maxord-2)) if (errest.ne.zero) & errest = errest* & dmax1(one/ten,errest/dmax1(errest/two,errorm)) if (errorm.le. 5.*errest) goto 20 if (2*intcls.gt.maxvls) goto 20 if (errest.lt.errmin) goto 20 10 continue 20 difmax = -1 x1 = one/two**2 x2 = 3.*x1 do 30 i = 1,s z(i) = center(i) 30 continue cmmm sum0 = adphlp(s,z) do 40 i = 1,s z(i) = center(i) - x1*hwidth(i) cmmm sum1 = adphlp(s,z) z(i) = center(i) + x1*hwidth(i) sum1 = sum1 + adphlp(s,z) z(i) = center(i) - x2*hwidth(i) sum2 = adphlp(s,z) z(i) = center(i) + x2*hwidth(i) sum2 = sum2 + adphlp(s,z) z(i) = center(i) dif = dabs((sum1-two*sum0) - (x1/x2)**2*(sum2-two*sum0)) if (dif.ge.difmax) then difmax = dif divaxn = i endif 40 continue if (sum0.eq.sum0+difmax/two) divaxn = mod(divaxo,s) + 1 basest = intvls(minord) funcls = intcls + 4*s return end double precision function flsm(s,center,hwidth,x,m,mp,maxord, * g,sumcls) c c*** function to compute fully symmetric basic rule sum c integer s, m(s), mp(s), maxord, sumcls, ixchng, lxchng, i, l, * ihalf, mpi, mpl double precision g(maxord), x(s), intwgt, zero, one,two, intsum, * center(s), hwidth(s) double precision adphlp zero = 0 one = 1 two = 2 intwgt = one do 10 i=1,s mp(i) = m(i) if (m(i).ne.0) intwgt = intwgt/two intwgt = intwgt*hwidth(i) 10 continue sumcls = 0 flsm = zero c c******* compute centrally symmetric sum for permutation mp 20 intsum = zero do 30 i=1,s mpi = mp(i) + 1 x(i) = center(i) + g(mpi)*hwidth(i) 30 continue 40 sumcls = sumcls + 1 cmmm intsum = intsum + adphlp(s,x) do 50 i=1,s mpi = mp(i) + 1 if(g(mpi).ne.zero) hwidth(i) = -hwidth(i) x(i) = center(i) + g(mpi)*hwidth(i) if (x(i).lt.center(i)) go to 40 50 continue c******* end integration loop for mp c flsm = flsm + intwgt*intsum if (s.eq.1) return c c******* find next distinct permutation of m and loop back c to compute next centrally symmetric sum do 80 i=2,s if (mp(i-1).le.mp(i)) go to 80 mpi = mp(i) ixchng = i - 1 if (i.eq.2) go to 70 ihalf = ixchng/2 do 60 l=1,ihalf mpl = mp(l) imnusl = i - l mp(l) = mp(imnusl) mp(imnusl) = mpl if (mpl.le.mpi) ixchng = ixchng - 1 if (mp(l).gt.mpi) lxchng = l 60 continue if (mp(ixchng).le.mpi) ixchng = lxchng 70 mp(i) = mp(ixchng) mp(ixchng) = mpi go to 20 80 continue c***** end loop for permutations of m and associated sums c return end subroutine nxprt(prtcnt, s, m) c c*** subroutine to compute the next s partition c implicit none integer s, m(s), prtcnt integer i,k, msum if (prtcnt.gt.0) go to 20 do 10 i=1,s m(i) = 0 10 continue prtcnt = 1 return 20 prtcnt = prtcnt + 1 msum = m(1) if (s.eq.1) go to 60 do 50 i=2,s msum = msum + m(i) if (m(1).le.m(i)+1) go to 40 m(1) = msum - (i-1)*(m(i)+1) do 30 k=2,i m(k) = m(i) + 1 30 continue return 40 m(i) = 0 50 continue 60 m(1) = msum + 1 return end subroutine symrl(s, center, hwidth, minord, maxord, intvls, * intcls, numsms, weghts, fulsms, fail) c multidimensional fully symmetric rule integration subroutine c c this subroutine computes a sequence of fully symmetric rule c approximations to a fully symmetric multiple integral. c written by a. genz, mathematical institute, university of kent, c canterbury, kent ct2 7nf, england c c************** parameters for symrl ******************************** c*****input parameters c s integer number of variables, must exceed 0 but not exceed 20 c f externally declared user defined real function integrand. c it must have parameters (s,x), where x is a real array c with dimension s. c minord integer minimum order parameter. on entry minord specifies c the current highest order approximation to the integral, c available in the array intvls. for the first call of symrl c minord should be set to 0. otherwise a previous call is c assumed that computed intvls(1), ... , intvls(minord). c on exit minord is set to maxord. c maxord integer maximum order parameter, must be greater than minord c and not exceed 20. the subroutine computes intvls(minord+1), c intvls(minord+2),..., intvls(maxord). c g real array of dimension(maxord) of generators. c all generators must be distinct and nonnegative. c numsms integer length of array fulsms, must be at least the sum of c the number of distinct partitions of length at most s c of the integers 0,1,...,maxord-1. an upper bound for numsms c when s+maxord is less than 19 is 200 c******output parameters c intvls real array of dimension(maxord). upon successful exit c intvls(1), intvls(2),..., intvls(maxord) are approximations c to the integral. intvls(d+1) will be an approximation of c polynomial degree 2d+1. c intcls integer total number of f values needed for intvls(maxord) c weghts real working storage array with dimension (numsms). on exit c weghts(j) contains the weight for fulsms(j). c fulsms real working storage array with dimension (numsms). on exit c fulsms(j) contains the fully symmetric basic rule sum c indexed by the jth s-partition of the integers c 0,1,...,maxord-1. c fail integer failure output parameter c fail=0 for successful termination of the subroutine c fail=1 when numsms is too small for the subroutine to c continue. in this case weghts(1), weghts(2), ..., c weghts(numsms), fulsms(1), fulsms(2), ..., c fulsms(numsms) and intvls(1), intvls(2),..., c intvls(j) are returned, where j is maximum value of c maxord compatible with the given value of numsms. c fail=2 when parameters s,minord, maxord or g are out of c range c*********************************************************************** cmmm external f ctsl real f ctsl double precision f c*** for double precision change real to double precision c in the next statement integer d, i, fail, k(20), intcls, prtcnt, l, m(20), maxord, * minord, modofm, numsms, s, sumcls double precision intvls(maxord), center(s), hwidth(s), gisqrd, * glsqrd, * intmpa, intmpb, intval, one, fulsms(numsms), weghts(numsms), * two, momtol, momnkn, momprd(20,20), moment(20), zero, g(20) double precision flsm, wht c patterson generators data g(1), g(2) /0.0000000000000000,0.7745966692414833/ data g(3), g(4) /0.9604912687080202,0.4342437493468025/ data g(5), g(6) /0.9938319632127549,0.8884592328722569/ data g(7), g(8) /0.6211029467372263,0.2233866864289668/ data g(9), g(10), g(11), g(12) /0.1, 0.2, 0.3, 0.4/ c c*** parameter checking and initialisation fail = 2 maxrdm = 20 maxs = 20 if (s.gt.maxs .or. s.lt.1) return if (minord.lt.0 .or. minord.ge.maxord) return if (maxord.gt.maxrdm) return zero = 0 one = 1 two = 2 momtol = one 10 momtol = momtol/two if (momtol+one.gt.one) go to 10 hundrd = 100 momtol = hundrd*two*momtol d = minord if (d.eq.0) intcls = 0 c*** calculate moments and modified moments do 20 l=1,maxord floatl = l + l - 1 moment(l) = two/floatl 20 continue if (maxord.ne.1) then do 40 l=2,maxord intmpa = moment(l-1) glsqrd = g(l-1)**2 do 30 i=l,maxord intmpb = moment(i) moment(i) = moment(i) - glsqrd*intmpa intmpa = intmpb 30 continue if (moment(l)**2.lt.(momtol*moment(1))**2) moment(l) = zero 40 continue endif do 70 l=1,maxord if (g(l).lt.zero) return momnkn = one momprd(l,1) = moment(1) if (maxord.eq.1) go to 70 glsqrd = g(l)**2 do 60 i=2,maxord if (i.le.l) gisqrd = g(i-1)**2 if (i.gt.l) gisqrd = g(i)**2 if (glsqrd.eq.gisqrd) return momnkn = momnkn/(glsqrd-gisqrd) momprd(l,i) = momnkn*moment(i) 60 continue 70 continue fail = 1 c c*** begin LOOP c for each d find all distinct partitions m with mod(m))=d c 80 prtcnt = 0 intval = zero modofm = 0 call nxprt(prtcnt, s, m) 90 if (prtcnt.gt.numsms) return c c*** calculate weight for partition m and fully symmetric sums c*** when necessary c if (d.eq.modofm) weghts(prtcnt) = zero if (d.eq.modofm) fulsms(prtcnt) = zero fulwgt = wht(s,moment,m,k,modofm,d,maxrdm,momprd) sumcls = 0 if (weghts(prtcnt).eq.zero .and. fulwgt.ne.zero) fulsms(prtcnt) = * flsm(s, center, hwidth, moment, m, k, maxord, g, sumcls) intcls = intcls + sumcls intval = intval + fulwgt*fulsms(prtcnt) weghts(prtcnt) = weghts(prtcnt) + fulwgt call nxprt(prtcnt, s, m) if (m(1).gt.modofm) modofm = modofm + 1 if (modofm.le.d) go to 90 c c*** end loop for each d if (d.gt.0) intval = intvls(d) + intval intvls(d+1) = intval d = d + 1 if (d.lt.maxord) go to 80 c c*** set failure parameter and return fail = 0 minord = maxord return end double precision function wht(s, intrps, m, k, modofm, d, * maxrdm, momprd) c*** subroutine to calculate weight for partition m c integer s, m(s), k(s), d, maxrdm, mi, ki, m1, k1, modofm double precision intrps(s), zero, momprd(maxrdm,maxrdm) zero = 0 do 10 i=1,s intrps(i) = zero k(i) = 0 10 continue m1 = m(1) + 1 k1 = d - modofm + m1 20 intrps(1) = momprd(m1,k1) if (s.eq.1) go to 40 do 30 i=2,s mi = m(i) + 1 ki = k(i) + mi intrps(i) = intrps(i) + momprd(mi,ki)*intrps(i-1) intrps(i-1) = zero k1 = k1 - 1 k(i) = k(i) + 1 if (k1.ge.m1) go to 20 k1 = k1 + k(i) k(i) = 0 30 continue 40 wht = intrps(s) return end fCopulae/man/0000755000176000001440000000000011720123747012617 5ustar ripleyusersfCopulae/man/t2d.Rd0000644000176000001440000000357411370220745013605 0ustar ripleyusers\name{t2d} \alias{t2d} \alias{pt2d} \alias{dt2d} \alias{rt2d} \title{Bivariate Student-t Distribution} \description{ Density, distribution function, and random generation for the bivariate Student-t distribution. } \usage{ pt2d(x, y = x, rho = 0, nu = 4) dt2d(x, y = x, rho = 0, nu = 4) rt2d(n, rho = 0, nu = 4) } \arguments{ \item{n}{ the number of random deviates to be generated, an integer value. } \item{nu}{ the number of degrees of freedom, a numeric value ranging between two and infinity, by default four. } \item{rho}{ the correlation parameter, a numeric value ranging between minus one and one, by default zero. } \item{x, y}{ two numeric vectors defining the x and y coordinates. } } \value{ \code{pt2d} \cr returns a two column matrix of probabilities for the bivariate Student-t distribution function.\cr \code{dt2d} \cr returns a two column matrix of densities for the bivariate Student-t distribution function.\cr \code{rt2d} \cr returns a two column matrix of random deviates generated from the bivariate Student-t distribution function. } \references{ Azzalini A., (2004); \emph{The sn Package}; R Reference Guide available from www.r-project.org. Venables W.N., Ripley B.D., (2002); \emph{Modern Applied Statistics with S}, Fourth Edition, Springer. } \author{ Adelchi Azzalini for the underlying pnorm2d function, \cr Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## Bivariate Student-t Density: x = (-40:40)/10 X = grid2d(x) z = dt2d(X$x, X$y, rho = 0.5, nu =6) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) persp(Z, theta = -40, phi = 30, col = "steelblue") } \keyword{math} fCopulae/man/squareBinning.Rd0000644000176000001440000000446411370220745015720 0ustar ripleyusers\name{BivariateBinning} \alias{BivariateBinning} \alias{squareBinning} \alias{hexBinning} \alias{plot.squareBinning} \alias{plot.hexBinning} \title{Square and Hexagonal Data Binning} \description{ A collection and description of functions which allow to create histograms due to sqaure and hexagonal binning. \cr Bivariate Binning Functions: \tabular{ll}{ \code{squareBinning} \tab does a square binning of data points, \cr \code{hexBinning} \tab does a hexagonal binning of data points} } \usage{ squareBinning(x, y = NULL, bins = 30) hexBinning(x, y = NULL, bins = 30) \method{plot}{squareBinning}(x, col = heat.colors(12), addPoints = TRUE, addRug = TRUE, \dots) \method{plot}{hexBinning}(x, col = heat.colors(12), addPoints = TRUE, addRug = TRUE, \dots) } \arguments{ \item{addPoints}{ a logical flag, should the center of mass points added to the plot? } \item{addRug}{ a logical flag, should a rug representation be added to the plot, for details see the function \code{rug}. } \item{bins}{ an integer specifying the number of bins. } \item{col}{ color map like for the \code{image} function. } \item{x, y}{ [squareBinning][hexBinning] - \cr either two numeric vectors of equal length or if \code{y} is NULL, a list with entries \code{x}, \code{y}, or named data frame with \code{x} in the first and \code{y} in the second column. Note, \code{timeSeries} objects are also allowed as input.\cr [plot] - \cr an object of class \code{squareBinning} or \code{hexBinning}. } \item{\dots}{ arguments to be passed. } } \value{ A list with three entries, \code{x}, \code{y} and \code{z}, specified by an oject of class \code{squareBinning} or \code{hexBinning}. Note, the returned value, can be directly used by the \code{persp()} and \code{contour} 3D plotting functions. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## squareBinning - sB = squareBinning(x = rnorm(1000), y = rnorm(1000)) plot(sB) ## hexBinning - hB = hexBinning(x = rnorm(1000), y = rnorm(1000)) plot(hB) } \keyword{programming} fCopulae/man/norm2d.Rd0000644000176000001440000000333311370220745014306 0ustar ripleyusers\name{norm2d} \alias{norm2d} \alias{pnorm2d} \alias{dnorm2d} \alias{rnorm2d} \title{Bivariate Normal Distribution} \description{ Density, distribution function, and random generation for the bivariate normal distribution. } \usage{ pnorm2d(x, y = x, rho = 0) dnorm2d(x, y = x, rho = 0) rnorm2d(n, rho = 0) } \arguments{ \item{n}{ the number of random deviates to be generated, an integer value. } \item{rho}{ the correlation parameter, a numeric value ranging between minus one and one, by default zero. } \item{x, y}{ two numeric vectors defining the x and y coordinates. } } \value{ \code{pnorm2d} \cr returns a two column matrix of probabilities for the bivariate normal distribution function.\cr \code{dnorm2d} \cr returns a two column matrix of densities for the bivariate normal distribution function.\cr \code{rnorm2d} \cr returns a two column matrix of random deviates generated from the bivariate normal distribution function. } \references{ Azzalini A., (2004); \emph{The sn Package}; R Reference Guide available from www.r-project.org. Venables W.N., Ripley B.D., (2002); \emph{Modern Applied Statistics with S}, Fourth Edition, Springer. } \author{ Adelchi Azzalini for the underlying pnorm2d function, \cr Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## Bivariate Normal Density: x = (-40:40)/10 X = grid2d(x) z = dnorm2d(X$x, X$y, rho = 0.5) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) persp(Z, theta = -40, phi = 30, col = "steelblue") } \keyword{math} fCopulae/man/mvdist.Rd0000644000176000001440000003332311370220745014415 0ustar ripleyusers\name{MultivariateDistribution} \alias{MultivariateDistribution} \alias{show,fMV-method} \alias{fMV} \alias{fMV-class} \alias{dmvsnorm} \alias{pmvsnorm} \alias{rmvsnorm} \alias{dmvst} \alias{pmvst} \alias{rmvst} \alias{mvFit} \alias{print.fMV} \alias{plot.fMV} \alias{summary.fMV} \title{Multivariate Skew Normal and Student-t Distributions} \description{ A collection and description of functions to compute multivariate densities and probabilities from skew normal and skew Student-t distribution functions. Furthermore, multivariate random daviates can be generated, and for multivariate data, the parameters of the underlying distribution can be estimated by the maximum log-likelihood estimation. \cr The functions are: \tabular{ll}{ \code{dmvsnorm} \tab Multivariate Skew Normal Density, \cr \code{pmvsnorm} \tab Multivariate Skew Normal Probability, \cr \code{rmvsnorm} \tab Random Deviates from MV Skew Normal Distribution, \cr \code{dmvst} \tab Multivariate Skew Student Density, \cr \code{pmvst} \tab Multivariate Skew Student Probability, \cr \code{rmvst} \tab Random Deviates from MV Skew Student Distribution, \cr \code{mvFit} \tab Fits a MV Skew Normal or Student-t Distribution, \cr \code{print} \tab S3 print method for an object of class 'fMV', \cr \code{plot} \tab S3 Plot method for an object of class 'fMV', \cr \code{summary} \tab S3 summary method for an object of class 'fMV'. } These functions are useful for portfolio selection and optimization if one likes to model the data by multivariate normal, skew normal, or skew Student-t distribution functions. } \usage{ dmvsnorm(x, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim)) pmvsnorm(q, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim)) rmvsnorm(n, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim)) dmvst(x, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim), df = 4) pmvst(q, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim), df = 4) rmvst(n, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim), df = 4) mvFit(x, method = c("snorm", "st"), fixed.df = NA, title = NULL, description = NULL, trace = FALSE, \dots) \S4method{show}{fMV}(object) \method{plot}{fMV}(x, which = "ask", \dots) \method{summary}{fMV}(object, which = "ask", doplot = TRUE, \dots) } \arguments{ \item{description}{ [mvFit] - \cr a character string, assigning a brief description to an \code{"fMV"} object. } \item{doplot}{ a logical value, by default TRUE. Should a plot be generated and displayed? } \item{dim}{ [*mvsnorm][*mvst] - \cr the colum dimension of the matrix \code{x}. If \code{x} is specified as a vector, \code{dim=1} must be set to one. } \item{fixed.df}{ either \code{NA}, the default, or a numeric value assigning the number of degrees of freedom to the model. In the case that \code{fixed.df=NA} the value of \code{df} will be included in the optimization process, otherwise not. } \item{method}{ [mvFit] - \cr a string value specifying the method applied in the optimizing process. This can be either \code{method="snorm"} or \code{method="st"}, in the first case the parameters for a skew normal distribution will be fitted and in the second case the parameters for a skew Student-t distribution. } \item{mu, Omega, alpha, df}{ [*mvsnorm][*mvst] - \cr the model parameters: \cr \code{mu} a vector of mean values, one for each column, \cr \code{Omega} the covariance matrix, \cr \code{alpha} the skewness vector, and \cr \code{df} the number of degrees of freedom which is a measure for the fatness of the tails (excess kurtosis). \cr For a symmetric distribution \code{alpha} is a vector of zeros. For the normal distributions \code{df} is not used and set to infinity, \code{Inf}. Note that all columns assume the same value for \code{df}. } \item{n}{ [rmvsnorm][rmvst] - \cr number of data records to be simulated, an integer value. } \item{object}{ [summary] - \cr an object of class \code{fMV}. } \item{title}{ [mvFit] - \cr a character string, assigning a title to an \code{"fMV"} object. } \item{trace}{ a logical, if set to \code{TRUE} the optimization process will be traced, otherwise not. The default setting is \code{FALSE}. } \item{which}{ which of the five plots should be displayed? \code{which} can be either a character string, \code{"all"} (displays all plots) or \code{"ask"} (interactively asks which one to display), or a vector of 5 logical values, for those elements which are set \code{TRUE} the correponding plot will be displayed. } \item{x, q}{ [*mvsnorm][*mvst][mvFit] - \cr a numeric matrix of quantiles (returns) or any other rectangular object like a data.frame or a multivariate time series objects which can be transformed by the function \code{as.matrix} to an object of class \code{matrix}. If \code{x} is a vector, it will be transformed into a matrix object with one column. \cr [plot][print] - \cr An object of class \code{fMV}. } \item{\dots}{ optional arguments to be passed to the optimization or plotting functions. } } \details{ These are "easy-to-use" functions which allow quickly to simulate multivariate data sets and to fit their parameters assuming a multivariate skew normal or skew Student-t distribution. The functions make use of the contributed R packages \code{sn} and \code{mtvnorm}. For an extended functionality in modelling multivariate skew normal and Student-t distributions we recommend to download and use the functions from the original package \code{sn} which requires also the package \code{mtvnorm}. The algorithm for the computation of the normal and Student-t distribution functions is described by Genz (1992) and (1993), and its implementation by Hothorn, Bretz, and Genz (2001). The parameter estimation is done by the maximum log-likelihood estimation. The algorithm and the implemantation was done by Azzalini (1985-2003). The multivariate skew-normal distribution is discussed in detail by Azzalini and Dalla Valle (1996); the \code{(Omega,alpha)} parametrization adopted here is the one of Azzalini and Capitanio (1999). The family of multivariate skew-t distributions is an extension of the multivariate Student's t family, via the introduction of a shape parameter which regulates skewness; for a zero shape parameter the skew Student-t distribution reduces to the usual t distribution. When \code{df = Inf} the distribution reduces to the multivariate skew-normal one. The plot facilities have been completely reimplemented. The S3 plot method allows for selective batch and interactive plots. The argument \code{which} takes care for the desired operation. The contributed R package \code{mvtnorm} is required, the contributed R package \code{sn} is builtin, since it is not available on the Debian Software Server. } \value{ \code{[dp]mvsnorm} \cr \code{[dp]mvst} \cr return a vector of density and probability values computed from the matrix \code{x}. \cr \code{mvFit} \cr returns a S4 object class of class \code{"fASSETS"}, with the following slots: \item{@call}{ the matched function call. } \item{@data}{ the input data in form of a data.frame. } \item{@description}{ allows for a brief project description. } \item{@fit}{ the results as a list returned from the underlying fitting function. } \item{@method}{ the selected method to fit the distribution, either \code{"snorm"}, or \code{"st"}. } \item{@model}{ the model parameters describing the fitted parameters in form of a list, \code{model=list(mu, Omega, alpha, df}. } \item{@title}{ a title string.} The \code{@fit} slot is a list with the following compontents: (Note, not all are documented here). \item{@fit$dp}{ a list containing the direct parameters beta, Omega, alpha. Here, beta is a matrix of regression coefficients with \code{dim(beta)=c(nrow(X), ncol(y))}, \code{Omega} is a covariance matrix of order \code{dim}, \code{alpha} is a vector of shape parameters of length \code{dim}. } \item{@fit$se}{ a list containing the components beta, alpha, info. Here, beta and alpha are the standard errors for the corresponding point estimates; info is the observed information matrix for the working parameter, as explained below. } \item{@fit$optim}{ the list returned by the optimizer \code{optim}; see the documentation of this function for explanation of its components. } \code{print} \cr is the S3 print method for objects of class \code{"fMV"} returned from the function \code{mvFit}. If shows a summary report of the parameter fit. \code{plot} \cr is the S3 plot method for objects of class \code{"fMV"} returned from the function \code{mvFit}. Five plots are produced. The first plot produces a scatterplot and in one dimension an histogram plot with the fitted distribution superimposed. The second and third plot represent a QQ-plots of Mahalanobis distances. The first of these refers to the fitting of a multivariate normal distribution, a standard statistical procedure; the second gives the corresponding QQ-plot of suitable Mahalanobis distances for the multivariate skew-normal fit. The fourth and fivth plots are similar to the previous ones, except that PP-plots are produced. The plots can be displayed in several ways, depending an the argument \code{which}, for details we refer to the arguments list above. \code{summary} \cr is the S3 summary method for objects of class \code{"fMV"} returned from the function \code{mvFit}. The summary method prints and plots in one step the results as done by the \code{print} and \code{plot} methods. } \references{ Azzalini A. (1985); \emph{A Class of Distributions Which Includes the Normal Ones}, Scandinavian Journal of Statistics 12, 171--178. Azzalini A. (1986); \emph{Further Results on a Class of Distributions Which Includes the Normal Ones}, Statistica 46, 199--208. Azzalini A., Dalla Valle A. (1996); \emph{The Multivariate Skew-normal Distribution}, Biometrika 83, 715--726. Azzalini A., Capitanio A. (1999); \emph{Statistical Applications of the Multivariate Skew-normal Distribution}, Journal Roy. Statist. Soc. B61, 579--602. Azzalini A., Capitanio A. (2003); \emph{Distributions Generated by Perturbation of Symmetry with Emphasis on a Multivariate Skew-t Distribution}, Journal Roy. Statist. Soc. B65, 367--389. Genz A., Bretz F. (1999); \emph{Numerical Computation of Multivariate t-Probabilities with Application to Power Calculation of Multiple Contrasts}, Journal of Statistical Computation and Simulation 63, 361--378. Genz A. (1992); \emph{Numerical Computation of Multivariate Normal Probabilities}, Journal of Computational and Graphical Statistics 1, 141--149. Genz A. (1993); \emph{Comparison of Methods for the Computation of Multivariate Normal Probabilities}, Computing Science and Statistics 25, 400--405. Hothorn T., Bretz F., Genz A. (2001); \emph{On Multivariate t and Gauss Probabilities in R}, R News 1/2, 27--29. } \author{ Torsten Hothorn for R's \code{mvtnorm} package, \cr Alan Ganz and Frank Bretz for the underlying Fortran Code, \cr Adelchi Azzalini for R's \code{sn} package, \cr Diethelm Wuertz for the Rmetrics port. } \examples{ ## rmvst - par(mfcol = c(3, 1), cex = 0.7) r1 = rmvst(200, dim = 1) ts.plot(as.ts(r1), xlab = "r", main = "Student-t 1d") r2 = rmvst(200, dim = 2, Omega = matrix(c(1, 0.5, 0.5, 1), 2)) ts.plot(as.ts(r2), xlab = "r", col = 2:3, main = "Student-t 2d") r3 = rmvst(200, dim = 3, mu = c(-1, 0, 1), alpha = c(1, -1, 1), df = 5) ts.plot(as.ts(r3), xlab = "r", col = 2:4, main = "Skew Student-t 3d") ## mvFit - # Generate Grid Points: n = 51 x = seq(-3, 3, length = n) xoy = cbind(rep(x, n), as.vector(matrix(x, n, n, byrow = TRUE))) X = matrix(xoy, n * n, 2, byrow = FALSE) head(X) # The Bivariate Normal Case: Z = matrix(dmvsnorm(X, dim = 2), length(x)) par (mfrow = c(2, 2), cex = 0.7) persp(x, x, Z, theta = -40, phi = 30, col = "steelblue") title(main = "Bivariate Normal Plot") image(x, x, Z) title(main = "Bivariate Normal Contours") contour(x, x, Z, add = TRUE) # The Bivariate Skew-Student-t Case: mu = c(-0.1, 0.1) Omega = matrix(c(1, 0.5, 0.5, 1), 2) alpha = c(-1, 1) Z = matrix(dmvst(X, 2, mu, Omega, alpha, df = 3), length(x)) persp(x, x, Z, theta = -40, phi = 30, col = "steelblue") title(main = "Bivariate Student-t Plot") image(x, x, Z) contour(x, x, Z, add = TRUE) title(main = "Bivariate Student-t Contours") } \keyword{distribution} fCopulae/man/gridData.Rd0000644000176000001440000000413311370220745014623 0ustar ripleyusers\name{BivariateGridding} \alias{BivariateGridding} \alias{gridData} \alias{persp.gridData} \alias{contour.gridData} \title{Bivariate Gridded Data Sets} \description{ A collection and description of functions which allow to generate bivariate gridded data sets. \cr Grid Data Functions: \tabular{ll}{ \code{gridData} \tab generates a grid data set of class 'gridData', \cr \code{persp} \tab generates a perspective plot from a grid data set, \cr \code{contour} \tab generates a contour plot from a grid data set.} } \usage{ gridData(x = (-10:10)/10, y = x, z = outer(x, y, function(x, y) (x^2+y^2) ) ) \method{persp}{gridData}(x, theta = -40, phi = 30, col = "steelblue", ticktype = "detailed", \dots) \method{contour}{gridData}(x, addImage = TRUE, \dots) } \arguments{ \item{addImage}{ [contour] - \cr a logical flag indicating if an image plot should be underlayed to the contour level plot. } \item{x, y, z}{ [gridData] - \cr \code{x} and \code{y} are two numeric vectors of grid pounts and \code{z} is a numeric matrix or any other rectangular object which can be transformed by the function \code{as.matrix} into a matrix object. } \item{theta, phi, col, ticktype}{ [persp] - \cr tailored parameters passed the perspective plot function \code{persp}. } \item{\dots}{ [contour][persp] - \cr additional arguments to be passed to the perspectice and countour plot functions. } } \value{ \code{gridData} - \cr A list with at least three entries, \code{x}, \code{y} and \code{z}. The returned values, can be directly used by the \code{persp.gridData()} and \code{contour.gridData} 3D plotting methods. } \author{ Diethelm Wuertz for the Rmetrics \R-port,\cr H. Akima for the Fortran Code of the Akima spline interpolation routine.\cr } \examples{ ## gridData - # Grid Data Set gD = gridData() persp(gD) contour(gD) } \keyword{programming} fCopulae/man/elliptical2d.Rd0000644000176000001440000000475511370220745015466 0ustar ripleyusers\name{elliptical2d} \alias{elliptical2d} \alias{delliptical2d} \title{Bivariate Elliptical Densities} \description{ Density function for bivariate elliptical distributions. } \usage{ delliptical2d(x, y = x, rho = 0, param = NULL, type = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower"), output = c("vector", "list")) } \arguments{ \item{output}{ output - a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v}. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{$x}, \code{y}, and \code{z} which can be directly used for example by 2D plotting functions. } \item{param}{ additional parameters to specify the bivariate density function. Only effective for the Kotz and Exponential Power distribution. For the Kotz distribution we can specify a numeric value, by default defined as \code{param=c(r=sqrt(2))}, and for the Exponential Power distribution a numeric vector, by default defined as \code{param=c(r=sqrt(2)),s=1/2}. } \item{rho}{ the correlation parameter, a numeric value ranging between minus one and one, by default zero. } \item{type}{ the type of the elliptical copula. A character string selected from: \code{"norm"}, \code{"cauchy"}, \code{"t"}, \code{"laplace"}, \code{"kotz"}, or \code{"epower"}. } \item{x, y}{ two numeric vectors defining the x and y coordinates. \cr } } \value{ \code{delliptical2d} \cr returns a two column matrix of densities for the selected bivariate elliptical distribution function. } \references{ Azzalini A., (2004); \emph{The sn Package}; R Reference Guide available from www.r-project.org. Venables W.N., Ripley B.D., (2002); \emph{Modern Applied Statistics with S}, Fourth Edition, Springer. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## Kotz' Elliptical Density: x = (-40:40)/10 X = grid2d(x) z = delliptical2d(X$x, X$y, rho = 0.5, type = "kotz") Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) persp(Z, theta = -40, phi = 30, col = "steelblue") } \keyword{math} fCopulae/man/density2.Rd0000644000176000001440000000636411370220745014655 0ustar ripleyusers\name{density2d} \alias{density2d} \alias{grid2d} \alias{density2d} \alias{hist2d} \alias{integrate2d} \title{Bivariate Density Tools} \description{ Grid generator, kernel density estimator, histogram counter, and integrator for bivariate distributions } \usage{ grid2d(x = (0:10)/10, y = x) density2d(x, y = NULL, n = 20, h = NULL, limits = c(range(x), range(y))) hist2d(x, y = NULL, n = c(20, 20)) integrate2d(fun, error = 1.0e-5, \dots) } \arguments{ \item{error}{ the error bound to be achieved by the integration formula. A numeric value. } \item{fun}{ the function to be integrated. The first argument requests the x values, the second the y values, and the remaining are reserved for additional parameters. The integration is over the unit square "[0,1]\^2". } \item{h}{ a vector of bandwidths for \code{x} and \code{y} directions. Defaults to normal reference bandwidth. } \item{limits}{ the limits of the rectangle covered by the grid. } \item{n}{ n - an integer specifying the number of grid points in each direction. The default value is 20.\cr [hist2D] - \cr In this case \code{n} may be a scalar or a two element vector. The default value is 20.\cr [rnorm2d] - \cr the number of random deviates to be generated, an integer value. } \item{x, y}{ two numeric vectors defining the x and y coordinates. \cr [density2D][hist2D] - \cr two vectors of coordinates of data. If \code{y} is NULL then \code{x} is assumed to be a two column matrix, where the first column contains the \code{x} data, and the second column the \code{y} data. } \item{\dots}{ parameters passed to the function to be integrated. } } \value{ \code{grid2d} \cr returns a list with two vectors named \code{$x} and \code{$y} spanning the grid defined by the coordinate vectors \code{x} and \code{y}. \code{density2d}\cr \code{hist2d} \cr returns a list with three elements \code{$x}, \code{$y}, and \code{$z}. \code{x} and \code{y} are vectors spanning the two dimensional grid and \code{z} the corresponding matrix. The output can directly serve as input to the plotting functions \code{image}, \code{contour} and \code{persp}. \code{integrate2d} \cr returns a list with the \code{$value} of the integral over the unit square [0,1]\^2, an \code{$error} estimate and the number of grid \code{$points} used by the integration function. } \references{ Azzalini A., (2004); \emph{The sn Package}; R Reference Guide available from www.r-project.org. Venables W.N., Ripley B.D., (2002); \emph{Modern Applied Statistics with S}, Fourth Edition, Springer. Warnes G.R., (2004); \emph{The gregmisc Package}; R Reference Guide available from www.r-project.org. } \author{ W.N. Venables and B.D. Ripley for the underlying kde2d function, \cr Gregory R. Warnes for the underlying hist2d function, \cr Diethelm Wuertz for the Rmetrics \R-port. } \keyword{math} fCopulae/man/cauchy2d.Rd0000644000176000001440000000335511370220745014613 0ustar ripleyusers\name{cauchy2d} \alias{cauchy2d} \alias{pcauchy2d} \alias{dcauchy2d} \alias{rcauchy2d} \title{Bivariate Cauchy Distribution} \description{ Density, distribution function, and random generation for the bivariate Cauchy distribution. } \usage{ pcauchy2d(x, y = x, rho = 0) dcauchy2d(x, y = x, rho = 0) rcauchy2d(n, rho = 0) } \arguments{ \item{n}{ the number of random deviates to be generated, an integer value. } \item{rho}{ the correlation parameter, a numeric value ranging between minus one and one, by default zero. } \item{x, y}{ two numeric vectors defining the x and y coordinates. } } \value{ \code{pcauchy2d} \cr returns a two column matrix of probabilities for the bivariate Cauchy distribution function.\cr \code{dcauchy2d} \cr returns a two column matrix of densities for the bivariate Cauchy distribution function.\cr \code{rcauchy2d} \cr returns a two column matrix of random deviates generated from the bivariate Cauchy distribution function. } \references{ Azzalini A., (2004); \emph{The sn Package}; R Reference Guide available from www.r-project.org. Venables W.N., Ripley B.D., (2002); \emph{Modern Applied Statistics with S}, Fourth Edition, Springer. } \author{ Adelchi Azzalini for the underlying pnorm2d function, \cr Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## Bivariate Cauchy Density: x = (-40:40)/10 X = grid2d(x) z = dcauchy2d(X$x, X$y, rho = 0.5) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) persp(Z, theta = -40, phi = 30, col = "steelblue") } \keyword{math} fCopulae/man/builtin-adapt.Rd0000644000176000001440000001010511370220745015635 0ustar ripleyusers\name{adapt} \title{Adaptive Numerical Integration in 2--20 Dimensions} \alias{adapt} \alias{print.integration} \usage{ adapt(ndim, lower, upper, minpts = 100, maxpts = NULL, functn, eps = 0.01, \dots) } \description{ Integrates a scalar function over a multidimensional rectangle. } \details{ The function computes \deqn{\int_l^u \mbox{functn}(t)\,d^nt}{% integral[l .. u] functn(t) d^n(t)} where \eqn{l =}\code{lower}, \eqn{u =}\code{upper} and \eqn{n =}\code{ndim}. Infinite rectangles are not allowed, and \code{ndim} must be between 2 and 20. This is modified from Mike Meyer's S code. The functions just call A.C. Genz's fortran ADAPT subroutine to do all of the calculations. A work array is allocated within the C/Fortran code. The Fortran function has been modified to use double precision, for compatibility with \R. It only works in two or more dimensions; for one-dimensional integrals use the \code{\link{integrate}} function in the base package. Setting \code{maxpts} to NULL asks the function to keep doubling \code{maxpts} (starting at \code{max(minpts,500, r(ndim))}) until the desired precision is achieved or \R runs out of memory. Note that the necessary number of evaluations typically grows exponentially with the dimension \code{ndim}, and the underlying code requires \code{maxpts >= r(ndim)} where \eqn{r(d) = 2^d + 2 d(d + 3) + 1}. } \arguments{ \item{ndim}{ the dimension of the integral, andi.e. number} \item{lower}{ vector of at least length \code{ndim} of the lower bounds on the integral.} \item{upper}{ vector of at least length \code{ndim} of the upper bounds on the integral.} \item{minpts}{ the minimum number of function evaluations.} \item{maxpts}{ the maximum number of function evaluations or \code{NULL} per default, see \emph{Details}.} \item{functn}{ an \R function which should take a single vector argument and possibly some parameters and return the function value at that point. \code{functn} must return a single numeric value.} \item{eps}{ the desired accuracy for the relative error.} \item{\dots}{ other parameters to be passed to \code{functn}} } \value{ A list of \code{\link{class} "integration"} with components \item{value}{ the estimated integral} \item{relerr}{ the estimated relative error; \code{< eps} argument if the algorithm converged properly.} \item{minpts}{ the actual number of function evaluations} \item{ifail}{ an error indicator. If \code{ifail} is not equal to 0, the function warns the user of the error condition.} } \seealso{ \code{\link{integrate}} } \examples{ ## Example of p - dimensional spherical normal distribution: ir2pi <- 1/sqrt(2*pi) fred <- function(z) { ir2pi^length(z) * exp(-0.5 * sum(z * z))} adapt(2, lo = c(-5, -5), up = c(5, 5), functn = fred) adapt(2, lo = c(-5, -5), up = c(5, 5), functn = fred, eps = 1e-4) adapt(2, lo = c(-5, -5), up = c(5, 5), functn = fred, eps = 1e-6) ## adapt "sees" function ~= constantly 0 --> wrong result adapt(2, lo = c(-9,-9), up = c(9,9), functn = fred) ## fix by using much finer initial grid: adapt(2, lo = c(-9,-9), up = c(9,9), functn = fred, min = 1000) adapt(2, lo = c(-9,-9), up = c(9,9), functn = fred, min = 1000, eps = 1e-6) i1 <- print(integrate(dnorm, -2, 2))$value ## True values for the following example: i1 ^ c(3, 5) for(p in c(3, 5)) { cat("\np = ", p, "\n------\n") f.lo <- rep(-2., p) f.up <- rep(+2., p) # not enough evaluations: print(adapt(p, lo=f.lo, up=f.up, max=100*p, functn = fred)) # enough evaluations: print(adapt(p, lo=f.lo, up=f.up, max=10^p, functn = fred)) # no upper limit; p=3: 7465 points, ie 5 attempts (on an Athlon/gcc/g77): print(adapt(p, lo=f.lo, up=f.up, functn = fred, eps = 1e-5)) } } \keyword{math} \keyword{utilities} fCopulae/man/ExtremeValueModelling.Rd0000644000176000001440000000635211370220745017352 0ustar ripleyusers\name{ExtremeValueModelling} \alias{ExtremeValueModelling} \alias{evCopulaSim} \alias{evCopulaFit} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions to investigate bivariate extreme value copulae. \cr Extreme Value Copulae Functions: \tabular{ll}{ \code{evCopulaSim} \tab simulates an extreme value copula, \cr \code{evCopulaFit} \tab fits the parameters of an extreme value copula. } } \usage{ evCopulaSim(n, param = NULL, type = evList()) evCopulaFit(u, v = NULL, type = evList(), \dots) } \arguments{ \item{n}{ [revCopula][evCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{param}{ [*ev*][A*] - \cr distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ [*ev*][Afunc] - \cr the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". \cr [evSlider] - \cr a character string specifying the plot type. Either a perspective plot which is the default or a contour plot with an underlying image plot will be created. } \item{u, v}{ [*evCopula][*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } \item{\dots}{ [evCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: if (require(tcltk)) { AfuncSlider() } } \keyword{models} fCopulae/man/ExtremeValueGenerator.Rd0000644000176000001440000000550011370220745017360 0ustar ripleyusers\name{ExtremeValueGenerator} \alias{ExtremeValueGenerator} \alias{evList} \alias{evParam} \alias{evRange} \alias{evCheck} \alias{Afunc} \alias{AfuncSlider} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions concerned with the generator function for the extreme value copula and with functions for setting and checking the distributional parameters. \cr Functions: \tabular{ll}{ \code{evList} \tab Returns list of implemented extreme value copulae, \cr \code{evParam} \tab sets default parameters for an extreme value copula, \cr \code{evRange} \tab returns the range of valid rho values, \cr \code{evCheck} \tab checks if rho is in the valid range, \cr \code{Afunc} \tab computes dependence function, \cr \code{AfuncSlider} \tab displays interactively dependence function. } } \usage{ evList() evParam(type = evList()) evRange(type = evList()) evCheck(param, type = evList()) Afunc(x, param = NULL, type = evList()) AfuncSlider() } \arguments{ \item{param}{ distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". } \item{x}{ a numeric value or vector ranging between zero and one. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: if (require(tcltk)) { AfuncSlider() } } \keyword{models} fCopulae/man/ExtremeValueDependency.Rd0000644000176000001440000000712611370220745017516 0ustar ripleyusers\name{ExtremeValueDependency} \alias{ExtremeValueDependency} \alias{evTau} \alias{evRho} \alias{evTailCoeff} \alias{evTailCoeffSlider} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions to investigate bivariate extreme value copulae. \cr Extreme Value Copulae Functions: \tabular{ll}{ \code{evTau} \tab Computes Kendall's tau for extreme value copulae, \cr \code{evRho} \tab computes Spearman's rho for extreme value copulae, \cr \code{evTailCoeff} \tab computes tail dependence for extreme value copulae, \cr \code{evTailCoeffSlider} \tab plots tail dependence for extreme value copulae. } } \usage{ evTau(param = NULL, type = evList(), alternative = FALSE) evRho(param = NULL, type = evList(), alternative = FALSE) evTailCoeff(param = NULL, type = evList()) evTailCoeffSlider(B = 10) } \arguments{ \item{alternative}{ [evRho][evTau][*evCopula] - \cr Should the probability be computed alternatively in a direct way from the probability formula or by default via the dependency function? } \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } %\item{error}{ % [evRho] - \cr % the error bound to be achieved by the \code{integrate2d} % integration formula. A numeric value, by default \code{error=1.0e-5}. % } \item{param}{ [*ev*][A*] - \cr distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ [*ev*][Afunc] - \cr the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". \cr [evSlider] - \cr a character string specifying the plot type. Either a perspective plot which is the default or a contour plot with an underlying image plot will be created. } \item{\dots}{ [evCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: if (require(tcltk)) { AfuncSlider() } } \keyword{models} fCopulae/man/ExtremeValueCopulae.Rd0000644000176000001440000001203511370220745017023 0ustar ripleyusers\name{ExtremeValueCopulae} \alias{ExtremeValueCopulae} \alias{revCopula} \alias{pevCopula} \alias{devCopula} \alias{revSlider} \alias{pevSlider} \alias{devSlider} \title{Bivariate Extreme Value Copulae} \description{ A collection and description of functions to investigate bivariate extreme value copulae. \cr Extreme Value Copulae Functions: \tabular{ll}{ \code{revCopula} \tab Generates extreme value copula random variates, \cr \code{pevCopula} \tab computes extreme value copula probability, \cr \code{devCopula} \tab computes extreme value copula density, \cr \code{revSlider} \tab displays interactive plots of extreme value random variates, \cr \code{pevSlider} \tab displays interactive plots of extreme value probability, \cr \code{devSlider} \tab displays interactive plots of extreme value density. } } \usage{ revCopula(n, param = NULL, type = evList()) pevCopula(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) devCopula(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) revSlider(B = 10) pevSlider(type = c("persp", "contour"), B = 10) devSlider(type = c("persp", "contour"), B = 10) } \arguments{ \item{alternative}{ [evRho][evTau][*evCopula] - \cr Should the probability be computed alternatively in a direct way from the probability formula or by default via the dependency function? } \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } %\item{error}{ % [evRho] - \cr % the error bound to be achieved by the \code{integrate2d} % integration formula. A numeric value, by default \code{error=1.0e-5}. % } \item{n}{ [revCopula][evCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{output}{ [*evCopula] - \cr output - a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v}. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{$x}, \code{y}, and \code{z} which can be directly used for example by 2D plotting functions. } \item{param}{ [*ev*][A*] - \cr distribution and copulae parameters. A numeric value or vector of named parameters as required by the copula specified by the variable \code{type}. If set to \code{NULL}, then the default parameters will be taken. } \item{type}{ [*ev*][Afunc] - \cr the type of the extreme value copula. A character string selected from: "gumbel", "galambos", "husler.reiss", "tawn", or "bb5". \cr [evSlider] - \cr a character string specifying the plot type. Either a perspective plot which is the default or a contour plot with an underlying image plot will be created. } \item{u, v}{ [*evCopula][*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } \item{\dots}{ [evCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") getSlots("fCOPULA") ## revCopula - # Not yet implemented # revCopula(n = 10, type = "galambos") ## pevCopula - pevCopula(u = grid2d(), type = "galambos", output = "list") ## devCopula - devCopula(u = grid2d(), type = "galambos", output = "list") ## AfuncSlider - # Generator, try: if (require(tcltk)) { AfuncSlider() } } \keyword{models} fCopulae/man/EmpiricalCopulae.Rd0000644000176000001440000000527411370220745016331 0ustar ripleyusers\name{EmpiricalCopulae} \alias{EmpiricalCopulae} \alias{pempiricalCopula} \alias{dempiricalCopula} \title{Bivariate Empirical Copulae} \description{ A collection and description of functions to investigate bivariate empirical copulae. \cr Empirical Copulae Functions: \tabular{ll}{ \code{pempiricalCopula} \tab computes empirical copula probability, \cr \code{dempiricalCopula} \tab computes empirical copula density. } } \usage{ pempiricalCopula(u, v, N = 10) dempiricalCopula(u, v, N = 10) } \arguments{ \item{N}{ [empiricalCopula] - \cr ... . } \item{u, v}{ [*evCopula][*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } } \value{ Th functions \code{*Spec} return an S4 object of class \code{"fCOPULA"}. The object contains the following slots: \item{@call}{ the function call. } \item{@copula}{ the name of the copula. } \item{@param}{ a list whose elements specify the model parameters. } \item{@title}{ a character string with the name of the copula. This can be overwritten specifying a user defined input argument. } \item{@description}{ a character string with an optional user defined description. By default just the current date when the test was applied will be returned. } The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/man/EllipticalModelling.Rd0000644000176000001440000001420111370220745017016 0ustar ripleyusers\name{EllipticalModelling} \alias{EllipticalModelling} \alias{ellipticalCopulaSim} \alias{ellipticalCopulaFit} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions to investigate bivariate elliptical copulae. \cr Elliptical Copulae Functions: \tabular{ll}{ \code{ellipticalCopulaSim} \tab simulates an elliptical copula, \cr \code{ellipticalCopulaFit} \tab fits the parameters of an elliptical copula. } } \usage{ ellipticalCopulaSim(n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) ellipticalCopulaFit(u, v, type = c("norm", "cauchy", "t"), \dots) } \arguments{ \item{n}{ [rellipticalCopula][ellipticalCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } \item{u, v}{ [*ellipticalCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{\$x} and \code{\$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. If \code{u} is an integer value greater than one, say \code{N}, than the values for all points on the \code{[(0:N)/N]^2} grid spanning the unit square will be returned. } \item{\dots}{ [ellipticalCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## [rp]ellipticalCopula - # Default Normal Copula: rellipticalCopula(10) pellipticalCopula(10) ## [rp]ellipticalCopula - # Student-t Copula Probability and Density: u = grid2d(x = (0:25)/25) pellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") d = dellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") persp(d, theta = -40, phi = 30, col = "steelblue") ## ellipticalTau - ## ellipticalRho - # Dependence Measures: ellipticalTau(rho = -0.5) ellipticalRho(rho = 0.75, type = "logistic", subdivisions = 100) ## ellipticalTailCoeff - # Student-t Tail Coefficient: ellipticalTailCoeff(rho = 0.25, param = 3, type = "t") ## gfunc - # Generator Function: plot(gfunc(x = 0:10), main = "Generator Function") ## ellipticalCopulaSim - ## ellipticalCopulaSim - # Simualtion and Parameter Fitting: rv = ellipticalCopulaSim(n = 100, rho = 0.75) ellipticalCopulaFit(rv) } \keyword{models} fCopulae/man/EllipticalGenerator.Rd0000644000176000001440000001303011370220745017031 0ustar ripleyusers\name{EllipticalGenerator} \alias{EllipticalGenerator} \alias{ellipticalList} \alias{ellipticalParam} \alias{ellipticalRange} \alias{ellipticalCheck} \alias{gfunc} \alias{gfuncSlider} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions concerned with the generator function for the elliptical copula and with functions for setting and checking the distributional parameters. \cr Functions: \tabular{ll}{ \code{ellipticalList} \tab Returns list of implemented elliptical copulae, \cr \code{ellipticalParam} \tab Sets default parameters for an elliptical copula, \cr \code{ellipticalRange} \tab returns the range of valid rho values, \cr \code{ellipticalCheck} \tab checks if rho is in the valid range, \cr \code{gfunc} \tab Generator function for elliptical distributions, \cr \code{gfuncSlider} \tab Slider for generator, density and probability. } } \usage{ ellipticalList() ellipticalParam(type = ellipticalList()) ellipticalRange(type = ellipticalList()) ellipticalCheck(rho = 0.75, param = NULL, type = ellipticalList()) gfunc(x, param = NULL, type = ellipticalList()) gfuncSlider(B = 10) } \arguments{ \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } \item{x}{ [gfunc] - \cr a numeric value or vector out of the range \code{[0,Inf)} at which the generator will be computed. } \item{\dots}{ [ellipticalCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## ellipticalList - # List implemented copulae: ellipticalList() ## gfunc - # Generator Function: gfunc(x = (0:10)/10, param = 2, type = "t") ## gfuncSlider - # Try: if (require(tcltk)) { gfuncSlider() } } \keyword{models} fCopulae/man/EllipticalDependency.Rd0000644000176000001440000001436511370220745017175 0ustar ripleyusers\name{EllipticalDependency} \alias{EllipticalDependency} \alias{ellipticalTau} \alias{ellipticalRho} \alias{ellipticalTailCoeff} \alias{ellipticalTailPlot} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions to investigate bivariate elliptical copulae. \cr Elliptical Copulae Functions: \tabular{ll}{ \code{ellipticalTau} \tab Computes Kendall's tau for elliptical copulae, \cr \code{ellipticalRho} \tab computes Spearman's rho for elliptical copulae, \cr \code{ellipticalTailCoeff} \tab computes tail dependence for elliptical copulae, \cr \code{ellipticalTailPlot} \tab plots tail dependence for elliptical copulae. } } \usage{ ellipticalTau(rho) ellipticalRho(rho, param = NULL, type = ellipticalList(), subdivisions = 500) ellipticalTailCoeff(rho, param = NULL, type = c("norm", "cauchy", "t")) ellipticalTailPlot(param = NULL, type = c("norm", "cauchy", "t"), tail = c("Lower", "Upper")) } \arguments{ \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{subdivisions}{ [ellipticalRho] - \cr an integer value with the number of subdivisons in each direction on the two dimensional unit square to compute the mean value of Spearman's Rho. By default 500 subdivisions are used. } \item{tail}{ [ellipticalTailPlot] - \cr a character string, either \code{"Upper"} or \code{"Lower"} denoting which of the two tails should be displayed. By default the upper tail dependence will be considered. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } \item{\dots}{ [ellipticalCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## [rp]ellipticalCopula - # Default Normal Copula: rellipticalCopula(10) pellipticalCopula(10) ## [rp]ellipticalCopula - # Student-t Copula Probability and Density: u = grid2d(x = (0:25)/25) pellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") d = dellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") persp(d, theta = -40, phi = 30, col = "steelblue") ## ellipticalTau - ## ellipticalRho - # Dependence Measures: ellipticalTau(rho = -0.5) ellipticalRho(rho = 0.75, type = "logistic", subdivisions = 100) ## ellipticalTailCoeff - # Student-t Tail Coefficient: ellipticalTailCoeff(rho = 0.25, param = 3, type = "t") ## gfunc - # Generator Function: plot(gfunc(x = 0:10), main = "Generator Function") ## ellipticalCopulaSim - ## ellipticalCopulaSim - # Simualtion and Parameter Fitting: rv = ellipticalCopulaSim(n = 100, rho = 0.75) ellipticalCopulaFit(rv) } \keyword{models} fCopulae/man/EllipticalCopulae.Rd0000644000176000001440000002015511370220745016501 0ustar ripleyusers\name{EllipticalCopulae} \alias{EllipticalCopulae} \alias{rellipticalCopula} \alias{pellipticalCopula} \alias{dellipticalCopula} \alias{rellipticalSlider} \alias{pellipticalSlider} \alias{dellipticalSlider} \title{Bivariate Elliptical Copulae} \description{ A collection and description of functions to investigate bivariate elliptical copulae. \cr Elliptical Copulae Functions: \tabular{ll}{ \code{rellipticalCopula} \tab Generates elliptical copula variates, \cr \code{pellipticalCopula} \tab computes elliptical copula probability, \cr \code{dellipticalCopula} \tab computes elliptical copula density, \cr \code{rellipticalSlider} \tab displays interactive plots of variates, \cr \code{pellipticalSlider} \tab displays interactive plots of probability, \cr \code{dellipticalSlider} \tab displays interactive plots of density. } } \usage{ rellipticalCopula(n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) pellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) dellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) rellipticalSlider(B = 100) pellipticalSlider(type = c("persp", "contour"), B = 20) dellipticalSlider(type = c("persp", "contour"), B = 20) } \arguments{ \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } \item{border}{ [pellipticalCopula][dellipticalCopula] - \cr a logical flag. If the argument \code{u} is an integer, say \code{N}, greater than one than all points on a square grid \code{[(0:N)/N]^2} are computed. If border is FALSE than the border points are removed from the returned value, by default this is not the case. } \item{n}{ [rellipticalCopula][ellipticalCopulaSim] - \cr the number of random deviates to be generated, an integer value. } \item{output}{ [pellipticalCopula][dellipticalCopula] - \cr a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v} is returned. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{$x}, \code{y}, and \code{z} which can be directly used for example by 2D plotting functions. For the grid version, when \code{u} is specified as an integer greater than one, always the output in form of a list will be returned. } \item{rho}{ [*ellipticalCopula] - \cr is the numeric value setting the correlation strength, ranging between minus one and one. } \item{param}{ [*ellipticalCopula][gfunc] - \cr additional distributional parameters: for the Sudent-t distribution this is "nu", for the Kotz distribution this is "r", and for the Exponential Power distribution these are "r" and "s". If the argument \code{param=NULL} then default values are taken. These are for the Student-t \code{param=c(nu=4))}, for the Kotz distribution \code{param=c(r=1))}, and for the exponential power distribution \code{param=c(r=1,s=1)}. Note, that the Kotz and exponential power copulae are independent of \code{r}, and that \code{r} only enters the generator, the density, the probability and the quantile functions. } \item{type}{ [*ellipticalCopula][gfunc] - \cr the type of the elliptical copula. A character string selected from: "norm", "cauchy", "t", "logistic", "laplace", "kotz", or "epower". [*ellipticalSlider] - \cr a character string which indicates what kind of plot should be displayed, either a perspective plot if \code{type="persp"}, the default value, or a contour plot if \code{type="contour"}. } \item{u, v}{ [*ellipticalCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. If \code{u} is an integer value greater than one, say \code{N}, than the values for all points on the \code{[(0:N)/N]^2} grid spanning the unit square will be returned. } \item{\dots}{ [ellipticalCopulaFit] - \cr arguments passed to the optimization function \code{nlminb}. } } \value{ \bold{Copula Functions:} \cr\cr The functions \code{[rpd]ellipticalCopula} return a numeric vector of random variates, probabilities, or densities for the specified copula computed at grid coordinates \code{u}|\code{v}. \cr The functions \code{[rpd]ellipticalSlider} display an interactive graph of an perspective copula plot either for random variates, probabilities or densities. Alternatively, an image underlayed contour plot can be shown. \cr \bold{Copula Dependence Measures:} \cr\cr The functions \code{ellipticalTau} and \code{ellipticalRho} return a numericc value for Kendall's Tau and Spearman's Rho. \cr \bold{Copula Tail Coefficient:} \cr\cr The function \code{ellipticalTailCoeff} returns the coefficient of tail dependence for a specified copula. The function \code{ellipticalTailPlot} displays a whole plot for the upper or alternatively for the lower tail dependence as a function of \code{u} for a set of nine \code{rho} values. \cr \bold{Copula Generator Function:} \cr\cr The function \code{gfunc} computes the generator function for the specified copula, by default the normal copula. If the argument \code{x} is missing, then the normalization constand lambda will be returned, otherwise if \code{x} is specified the values for the function \emph{g(x)} will be freturned. The selected type of copula is added to the output as an attribute named \code{"control"}. The function \code{gfuncSlider} allows to display interactively the generator function, the marginal density, the marginal probability, and the contours of the the bivariate density. \cr \bold{Copula Simulation and Parameter Fitting:} \cr\cr The function \code{ellipticalCopulaSim} returns a numeric two-column matrix with randomly generated variates for the specified copula. \cr The function \code{ellipticalCopulaFit} returns a fit to empirical data for the specified copula. The returned object is a list with elements from the function \code{nlminb}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## [rp]ellipticalCopula - # Default Normal Copula: rellipticalCopula(10) pellipticalCopula(10) ## [rp]ellipticalCopula - # Student-t Copula Probability and Density: u = grid2d(x = (0:25)/25) pellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") d = dellipticalCopula(u, rho = 0.75, param = 4, type = "t", output = "list") persp(d, theta = -40, phi = 30, col = "steelblue") ## ellipticalTau - ## ellipticalRho - # Dependence Measures: ellipticalTau(rho = -0.5) ellipticalRho(rho = 0.75, type = "logistic", subdivisions = 100) ## ellipticalTailCoeff - # Student-t Tail Coefficient: ellipticalTailCoeff(rho = 0.25, param = 3, type = "t") ## gfunc - # Generator Function: plot(gfunc(x = 0:10), main = "Generator Function") ## ellipticalCopulaSim - ## ellipticalCopulaSim - # Simualtion and Parameter Fitting: rv = ellipticalCopulaSim(n = 100, rho = 0.75) ellipticalCopulaFit(rv) } \keyword{models} fCopulae/man/CopulaeClass.Rd0000644000176000001440000000725511370220745015472 0ustar ripleyusers\name{CopulaeClass} \alias{CopulaeClass} \alias{fCOPULA} \alias{fCOPULA-class} \alias{show,fCOPULA-method} \alias{pfrechetCopula} \title{Bivariate Copulae Class} \description{ A collection and description of functions to specify the copula class and to investigate bivariate Frechet copulae. \cr The class representation and methods are: \tabular{ll}{ \code{fCOPULA} \tab representation for an S4 object of class "fCOPULA", \cr \code{show} \tab S4 print method. } Frechet Copulae: \tabular{ll}{ \code{pfrechetCopula} \tab computes Frechet copula probability. } } \usage{ \S4method{show}{fCOPULA}(object) pfrechetCopula(u = 0.5, v = u, type = c("m", "pi", "w"), output = c("vector", "list")) } \arguments{ \item{object}{ [show] - \cr an S4 object of class \code{"fCOPULA"}. } \item{output}{ [*frechetCopula] - \cr output - a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v}. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{$x}, \code{y}, and \code{z} which can be directly used for example by 2D plotting functions. } \item{type}{ [*frechetCopula] - \cr the type of the Frechet copula. A character string selected from: \code{"m"}, \code{"pi"}, or \code{"w"}. } \item{u, v}{ two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{$x} and \code{$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } } \value{ The print method \code{show} returns an S4 object of class \code{"fCOPULA"}. The object contains the following slots: \item{@call}{ the function call. } \item{@copula}{ the name of the copula. } \item{@param}{ a list whose elements specify the model parameters of the copula. } \item{@title}{ a character string with the name of the copula. This can be overwritten specifying a user defined input argument. } \item{@description}{ a character string with an optional user defined description. By default just the current date will be returned. } The function \code{pfrechetCopula} returns a numeric vector of probabilities. An attribute named \code{"control"} is added which returns the name of the Frechet copula. } \details{ The function \code{pfrechetCopula} returns a numeric matrix of probabilities computed at grid positions \code{u}|\code{v}. The arguments \code{u} and \code{v} are two single values or two numeric vectors of the same length. If \code{v} is not specified then the same values are taken as for \code{u}. Alternatively, \code{u} may be given as a two column vector or as a list with two entries as vectors. The first column or entry is taken as \code{u} and the second as \code{v}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## fCOPULA - getClass("fCOPULA") ## pcopula - # The Frechet Copula - m: pfrechetCopula(0.5) pfrechetCopula(0.25, 0.75) pfrechetCopula(runif(5)) grid2d() pfrechetCopula(grid2d()) } \keyword{models} fCopulae/man/ArchimedeanModelling.Rd0000644000176000001440000000506411370220745017143 0ustar ripleyusers\name{ArchimedeanModelling} \alias{ArchimedeanModelling} \alias{archmCopulaSim} \alias{archmCopulaFit} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions to investigate bivariate Archimedean copulae. \cr Archimedean Copulae Functions: \tabular{ll}{ \code{archmCopulaSim} \tab simulates an Archimedean copula, \cr \code{archmCopulaFit} \tab fits the parameters of an Archimedean copula. } } \usage{ archmCopulaSim(n, alpha = NULL, type = archmList()) archmCopulaFit(u, v = NULL, type = archmList(), \dots) } \arguments{ \item{alpha}{ [Phi*][*archmCopula] - \cr the parameter of the Archemedean copula. A numerical value. } \item{n}{ [rarchmCopula] - \cr the number of random deviates to be generated, an integer value. } \item{type}{ the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen. } \item{u, v}{ [*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{\$x} and \code{\$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } \item{\dots}{ [archmCopulaFit] - \cr arguments passed to the optimization function in use, \code{nlminb}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/man/ArchimedeanGenerator.Rd0000644000176000001440000000646611370220745017166 0ustar ripleyusers\name{ArchimedeanGenerator} \alias{ArchimedeanGenerator} \alias{archmList} \alias{archmParam} \alias{archmRange} \alias{archmCheck} \alias{Phi} \alias{PhiSlider} \alias{Kfunc} \alias{KfuncSlider} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions concerned with the generator function for the Archimedean copula and with functions for setting and checking the distributional parameters. \cr Functions: \tabular{ll}{ \code{evList} \tab Returns list of implemented Archimedean copulae, \cr \code{archmParam} \tab Sets default parameters for an Archimedean copula, \cr \code{archmRange} \tab returns the range of valid rho values, \cr \code{archmCheck} \tab checks if rho is in the valid range, \cr \code{Phi} \tab Computes generator Phi, inverse and derivatives, \cr \code{PhiSlider} \tab displays interactively generator function, \cr \code{Kfunc} \tab computes copula density and its inverse, \cr \code{KfuncSlider} \tab displays interactively density function. } } \usage{ archmList() archmParam(type = archmList()) archmRange(type = archmList(), B = Inf) archmCheck(alpha, type = archmList()) Phi(x, alpha = NULL, type = archmList(), inv = FALSE, deriv = paste(0:2)) PhiSlider(B = 5) Kfunc(x, alpha = NULL, type = archmList(), inv = FALSE, lower = 1.0e-8) KfuncSlider(B = 5) } \arguments{ \item{alpha}{ [Phi*][*archmCopula] - \cr the parameter of the Archemedean copula. A numerical value. } \item{B}{ [archmRange] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to \code{B=Inf}.\cr [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to \code{B=5}. } \item{deriv}{ [Phi] - \cr an integer value. Should the function itself, \code{deriv="0"}, or the first \code{deriv="1"}, or second \code{deriv="2"} derivative be evaluated? } \item{inv}{ [Phi][Kfunc] - \cr a logical flag. Should the inverse function be computed? } \item{lower}{ [Kfunc] - \cr a numeric value setting the lower bound for the internal root finding function \code{uniroot}. } \item{type}{ [*archmCopula][Phi][Kfunc] - \cr the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen. } \item{x}{ [Kfunc] - \cr a numeric value or vector ranging between zero and one.\cr [Phi] - \cr a numeric value or vector. } } \value{ The function \code{Phi} returns a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The function \code{Kfunc} returns a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \references{ RB Nelson - An Introduction to Copulas } \examples{ ## archmList - # Return list of implemented copulae: archmList() } \keyword{models} fCopulae/man/ArchimedeanDependency.Rd0000644000176000001440000000625211370220745017307 0ustar ripleyusers\name{ArchimedeanDependency} \alias{ArchimedeanDependency} \alias{archmTau} \alias{archmRho} \alias{archmTailCoeff} \alias{archmTailPlot} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions to investigate bivariate Archimedean copulae. \cr Archimedean Copulae Functions: \tabular{ll}{ \code{archmTau} \tab Computes Kendall's tau for Archimedean copulae, \cr \code{archmRho} \tab computes Spearman's rho for Archimedean copulae, \cr \code{archmTailCoeff} \tab computes tail dependence for Archimedean copulae, \cr \code{archmTailPlot} \tab plots tail dependence for Archimedean copulae. } } \usage{ archmTau(alpha = NULL, type = archmList(), lower = 1.0e-10) archmRho(alpha = NULL, type = archmList(), method = c("integrate2d", "adapt"), error = 1.0e-5) archmTailCoeff(alpha = NULL, type = archmList()) archmTailPlot(alpha = NULL, type = archmList(), tail = c("Upper", "Lower")) } \arguments{ \item{alpha}{ the parameter of the Archemedean copula. A numerical value. } \item{error}{ [archmRho] - \cr the error bound to be achieved by the \code{integrate2d} integration formula. A numeric value, by default \code{error=1.0e-5}. } \item{lower}{ [archmTau] - \cr a numeric value setting the lower bound for the internal integration function \code{integrate}. } \item{tail}{ [archmTailPlot] - \cr a character string, either \code{"Upper"} or \code{"Lower"} denoting which of the two tails should be displayed. By default the upper tail dependence will be considered. } \item{type}{ the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen. } \item{method}{ [archmRho] - \cr a character string that determines which integration method should be used, either \code{"integrate2d"} or \code{"adapt"}. If the second method is selected the contributed R package \code{"adapt"} is required. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/man/ArchimedeanCopulae.Rd0000644000176000001440000001113511370220745016615 0ustar ripleyusers\name{ArchimedeanCopulae} \alias{ArchimedeanCopulae} \alias{rarchmCopula} \alias{parchmCopula} \alias{darchmCopula} \alias{rarchmSlider} \alias{parchmSlider} \alias{darchmSlider} \alias{rgumbelCopula} \alias{pgumbelCopula} \alias{dgumbelCopula} \title{Bivariate Archimedean Copulae} \description{ A collection and description of functions to investigate bivariate Archimedean copulae. \cr Archimedean Copulae Functions: \tabular{ll}{ \code{rarchmCopula} \tab Generates Archimedean copula variates, \cr \code{parchmCopula} \tab computes Archimedean copula probability, \cr \code{darchmCopula} \tab computes Archimedean copula density, \cr \code{rarchmSlider} \tab displays interactive plots of variates, \cr \code{parchmSlider} \tab displays interactive plots of probability, \cr \code{darchmSlider} \tab displays interactive plots of density. } Special Copulae Functions: \tabular{ll}{ \code{rgumbelCopula} \tab Generates Gumbel copula variates, \cr \code{pgumbelCopula} \tab computes Gumbel copula probability, \cr \code{dgumbelCopula} \tab computes Gumbel copula density. } } \usage{ rarchmCopula(n, alpha = NULL, type = archmList()) parchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) darchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) rarchmSlider(B = 10) parchmSlider(type = c("persp", "contour"), B = 10) darchmSlider(type = c("persp", "contour"), B = 10) rgumbelCopula(n, alpha = 2) pgumbelCopula(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) dgumbelCopula(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) } \arguments{ \item{alpha}{ [Phi*][*archmCopula] - \cr the parameter of the Archemedean copula. A numerical value. } \item{alternative}{ [*Copula] - \cr Should the probability be computed alternatively ... } \item{B}{ [*Slider] - \cr the maximum slider menu value when the boundary value is infinite. By default this is set to 10. } \item{n}{ [rarchmCopula] - \cr the number of random deviates to be generated, an integer value. } \item{output}{ [*archmCopula] - \cr output - a character string specifying how the output should be formatted. By default a vector of the same length as \code{u} and \code{v}. If specified as \code{"list"} then \code{u} and \code{v} are expected to span a two-dimensional grid as outputted by the function \code{grid2d} and the function returns a list with elements \code{\$x}, \code{\$y}, and \code{\$z} which can be directly used for example by 2D plotting functions. } \item{type}{ [*archmCopula] - \cr the type of the Archimedean copula. A character string ranging beween \code{"1"} and \code{"22"}. By default copula No. 1 will be chosen.\cr [*archmSlider] - \cr the type of the plot. A charcter string either specifying a perspective or contour plot. } \item{u, v}{ [*archmCopula] - \cr two numeric values or vectors of the same length at which the copula will be computed. If \code{u} is a list then the the \code{\$x} and \code{\$y} elements will be used as \code{u} and \code{v}. If \code{u} is a two column matrix then the first column will be used as \code{u} and the the second as \code{v}. } } \value{ The function \code{pcopula} returns a numeric matrix of probabilities computed at grid positions \code{x}|\code{y}. \cr The function \code{parchmCopula} returns a numeric matrix with values computed for the Archemedean copula. \cr The function \code{darchmCopula} returns a numeric matrix with values computed for thedensity of the Archemedean copula. \cr The functions \code{Phi*} return a numeric vector with the values computed from the Archemedean generator, its derivatives, or its inverse. \cr The functions \code{cK} and \code{cKInv} return a numeric vector with the values of the density and inverse for Archimedian copulae. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } % \examples{ % ## fCOPULA - % # getClass("fCOPULA") % ## pcopula - % # The default Normal Copula: % # contour(pcopula()) % } \keyword{models} fCopulae/inst/0000755000176000001440000000000011720123747013021 5ustar ripleyusersfCopulae/inst/unitTests/0000755000176000001440000000000011720123747015023 5ustar ripleyusersfCopulae/inst/unitTests/runit.MultivariateDistributions.R0000644000176000001440000001762511370220745023547 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # dmvsnorm Multivariate Skew Normal Density Function # pmvsnorm Multivariate Skew Normal Probability Function # rmvsnorm Multivariate Skew Normal Random Deviates # FUNCTION: DESCRIPTION: # dmvst Multivariate Skew Sudent-t Density Function # pmvst Multivariate Skew Sudent-t Probability Function # rmvst Multivariate Skew Sudent-t Random Deviates # FUNCTION: DESCRIPTION: # fMV S4 Object of class 'fMV' # mvFit Fits a MV Normal or Student-t Distribution # print.fMV S3: Print method for objects of class 'fMV' # plot.fMV S3: Plot method for objects of class 'fMV' # summary.fMV S3: Summary method for objects of class 'fMV' ################################################################################ test.dmvsnorm = function() { # Multivariate Skew Normal # Bivariate Density: x = y = seq(-4, 4, length = 81) G = grid2d(x) X = cbind(G$x, G$y) z = dmvsnorm(X, dim = 2, mu = rep(0, 2), Omega = diag(2), alpha = rep(0, 2)) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) # Plot: par(mfrow = c(1, 1), ask = FALSE) persp(Z, theta = -40, phi = 30, col = "steelblue") # Return Value: return() } # ------------------------------------------------------------------------------ test.pmvsnorm = function() { # Multivariate Skew Normal # Bivariate Density: x = y = seq(-4, 4, length = 21) G = grid2d(x) X = cbind(G$x, G$y) z = pmvsnorm(X, dim = 2, mu = rep(0, 2), Omega = diag(2), alpha = rep(0, 2)) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) # Plot: par(mfrow = c(1, 1), ask = FALSE) persp(Z, theta = -40, phi = 30, col = "steelblue") # Return Value: return() } # ------------------------------------------------------------------------------ test.rmvsnorm = function() { # Multivariate Skew Normal # RVs: RNGkind(kind = "Marsaglia-Multicarry", normal.kind = "Inversion") set.seed(4711, kind = "Marsaglia-Multicarry") N = 5000 z = rmvsnorm(N, dim = 2, mu = rep(0, 2), Omega = diag(2), alpha = rep(1, 2)) # Scatterplot: par(mfrow = c(1, 1), ask = FALSE) plot(z, pch = 19, col = "steelblue") grid() # Return Value: return() } ################################################################################ test.dmvst = function() { # Multivariate Skew Sudent-t args(dmvst) # dmvst(x, dim = 2, mu = rep(0, dim), Omega = diag(dim), # alpha = rep(0, dim), df = 4) # Bivariate Density: x = y = seq(-4, 4, length = 81) G = grid2d(x) X = cbind(G$x, G$y) z = dmvst(X, dim = 2, mu = rep(0, 2), Omega = diag(2), alpha = c(-1, 1)) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) # Plot: par(mfrow = c(1, 1), ask = FALSE) persp(Z, theta = -40, phi = 30, col = "steelblue") # Return Value: return() } # ------------------------------------------------------------------------------ test.pmvst = function() { # Multivariate Skew Sudent-t # Bivariate Density: x = y = seq(-4, 4, length = 21) G = grid2d(x) X = cbind(G$x, G$y) z = pmvst(X, dim = 2, mu = rep(0, 2), Omega = diag(2), alpha = c(-1, 1)) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) # Plot: par(mfrow = c(1, 1), ask = FALSE) persp(Z, theta = -40, phi = 30, col = "steelblue") .perspPlot(Z) # Return Value: return() } # ------------------------------------------------------------------------------ test.rmvst = function() { # Multivariate Skew Sudent-t # RVs: RNGkind(kind = "Marsaglia-Multicarry", normal.kind = "Inversion") set.seed(4711, kind = "Marsaglia-Multicarry") N = 5000 z = rmvsnorm(N, dim = 2, mu = rep(0, 2), Omega = diag(2), alpha = c(-1, 1)) # Scatterplot: par(mfrow = c(1, 1), ask = FALSE) plot(z, pch = 19, col = "steelblue") grid() # Return Value: return() } ################################################################################ # fMV S4 Object of class 'fMV' ################################################################################ test.mvFit.mvsnorm = function() { # mvFit - Fits a MV Normal or Student-t Distribution # mvFit(x, method = c("snorm", "st"), fixed.df = NA, title = NULL, # description = NULL, trace = FALSE, ...) # RVs: RNGkind(kind = "Marsaglia-Multicarry", normal.kind = "Inversion") set.seed(4711, kind = "Marsaglia-Multicarry") N = 5000 z = rmvsnorm(N, dim = 2, mu = rep(0, 2), Omega = diag(2), alpha = c(-1, 1)) # Fit: fit = mvFit(x = z, method = "snorm") # Print: print(fit) # Interactive Plot: # plot(fit, which = "ask") # Scatterplot: par(mfrow = c(1, 1)) plot(fit, which = 1) # Normal QQ Plot of Mahalanobis Distances: par(mfrow = c(2, 2)) plot(fit, which = 2) # Skew Normal QQ Plot of Mahalanobis Distances: plot(fit, which = 3) # Normal PP Plot of Mahalanobis Distances: plot(fit, which = 4) # Skew Normal PP Plot of Mahalanobis Distances: plot(fit, which = 5) # Summary: summary(fit, doplot = FALSE) # Return Value: return() } ################################################################################ test.mvFit.mvst = function() { # mvFit - Fits a MV Normal or Student-t Distribution # mvFit(x, method = c("snorm", "st"), fixed.df = NA, title = NULL, # description = NULL, trace = FALSE, ...) # RVs: RNGkind(kind = "Marsaglia-Multicarry", normal.kind = "Inversion") set.seed(4711, kind = "Marsaglia-Multicarry") N = 1000 z = rmvst(N, dim = 2, mu = rep(0, 2), Omega = diag(2), alpha = c(-1, 1), df = 4) # Fit: # fit = mvFit(x = z, method = "st", trace = TRUE) fit = mvFit(x = z, method = "st") # Print: print(fit) # Interactive Plot: # plot(fit, which = "ask") # Scatterplot: par(mfrow = c(1, 1)) plot(fit, which = 1) # Normal QQ Plot of Mahalanobis Distances: par(mfrow = c(2, 2)) plot(fit, which = 2) # Skew Normal QQ Plot of Mahalanobis Distances: plot(fit, which = 3) # Normal PP Plot of Mahalanobis Distances: plot(fit, which = 4) # Skew Normal PP Plot of Mahalanobis Distances: plot(fit, which = 5) # Summary: summary(fit, doplot = FALSE) # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ExtrmeValueGenerator.R0000644000176000001440000000721411370220745022417 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # evParam Sets Default parameters for an extreme value copula # evRange Returns the range of valid parameter values # evCheck Checks if parameters are in the valid range # FUNCTION: EXTREME VALUE COPULAE GENERATOR FUNCTION: # Afunc Computes Dependence function # AfuncSlider Displays interactively dependence function ################################################################################# test.evList = function() { # Arguments: # evList() # List: evList() # c("gumbel", "galambos", "husler.reiss", "tawn", "bb5") # Return Value: return() } # ------------------------------------------------------------------------------ test.evParam = function() { # Arguments: # evParam(type = evList()) # Parameters: for (type in evList()) { cat("\n") print(unlist(evParam(type))) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evRange = function() { # Arguments: # evRange(type = evList()) # Range: for (type in evList()) { cat("\n") print(evRange(type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evCheck = function() { # Arguments: # evCheck(type = evList()) # Check: for (type in evList()) { cat("\n") param = evParam(type)$param print(evCheck(param)) } # Return Value: return() } ################################################################################ test.Afunc = function() { # Arguments: # Afunc(x, param = NULL, type = evList() # Afunc: x = (0:10)/10 for (type in evList()) { cat("\n") print(type) print(Afunc(x, type = type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.AfuncSlider = function() { # Arguments: # AfuncSlider() # Try Slider: # AfuncSlider() NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ExtremeValueModelling.R0000644000176000001440000000470411370220745022551 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULA PARAMETER FITTING: # evCopulaSim Simulates bivariate extreme value copula # evCopulaFit Fits the paramter of an extreme value copula ################################################################################# test.evCopulaSim = function() { # Arguments: # evCopulaSim(n, param = NULL, type = evList()) # Simulate Random Variates: for (type in evList()) { ans = evCopulaSim(5, type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evCopulaFit = function() { # Arguments: # evCopulaFit(u, v = NULL, type = evList(), ...) # Random Variates: set.seed(4711) type = "gumbel" R = evCopulaSim(500, param = NULL, type = type) Index = which(is.na(R[,2])) R = R[-Index, ] # Fit: ### evCopulaFit(u = R, type = type) # Check # Fit: ### evCopulaFit(u = R[, 1], v = R[, 2], type = type) # Check # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ExtremeValueDependency.R0000644000176000001440000000617511370220745022721 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # evTau Returns Kendall's tau for extreme value copulae # evRho Returns Spearman's rho for extreme value copulae # FUNCTION: EXTREME VALUE COPULAE TAIL DEPENDENCE: # evTailCoeff Computes tail dependence for extreme value copulae # evTailCoeffSlider Plots extreme value tail dependence function ################################################################################# test.evTau = function() { # Arguments: # evTau(param = NULL, type = evList(), alternative = FALSE) # Tau: for (type in evList()) { ans = evTau(type = type) cat("\n") print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evRho = function() { # Arguments: # evRho(param = NULL, type = evList(), alternative = FALSE) # Rho: for (type in evList()) { ans = evRho(type = type) cat("\n") print(type) print(ans) } # Return Value: return() } ################################################################################ test.evTailCoeff = function() { # Arguments: # evTailCoeff(param = NULL, type = evList()) # Tail Coefficient: for (type in evList()) { ans = evTailCoeff(type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.evTailCoeffSlider = function() { # Arguments: # evTailCoeffSlider(B = 10) # Try Slider: # evTailCoeffSlider() NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ExtremeValueCopulae.R0000644000176000001440000001105111370220745022220 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULAE RANDOM VARIATES: # revCopula Generates extreme value copula random variates # revSlider isplays interactively plots of random variates # FUNCTION: EXTREME VALUE COPULAE PROBABILIY: # pevCopula Computes extreme value copula probability # pevSlider Displays interactively plots of probability # FUNCTION: EXTREME VALUE COPULAE DENSITY: # devCopula Computes extreme value copula density # devSlider Displays interactively plots of density ################################################################################ test.revCopula = function() { # Arguments: # revCopula(n, param = NULL, type = evList()) # Random Variates - Check all Types: for (type in evList()) { R = revCopula(n = 5, param = NULL, type = type) cat("\n") print(type) print(R) } # Tawn Copula: revCopula(n = 5, param = NULL, type = "tawn") # Return Value: return() } # ------------------------------------------------------------------------------ test.revSlider = function() { # Arguments: # revSlider(B = 10) # Try Slider() # revSlider() # CHECK !!! NA # Return Value: return() } ################################################################################ test.pevCopula = function() { # Arguments: # pevCopula(u = 0.5, v = u, param = NULL, type = evList(), # output = c("vector", "list"), alternative = FALSE) # Random Variates - Check all Types: for (type in evList()) { R = pevCopula(u = grid2d(), param = NULL, type = type, output = "list") cat("\n") print(type) print(R) } # Tawn Copula: revCopula(n = 5, param = NULL, type = "tawn") # Return Value: return() } # ------------------------------------------------------------------------------ test.pevSlider = function() { # Arguments: # pevSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # pevSlider("persp") NA # Try Contour Slider: # pevSlider("contour") NA # Return Value: return() } ################################################################################ test.devCopula = function() { # Arguments: # devCopula(u = 0.5, v = u, param = NULL, type = evList(), # output = c("vector", "list"), alternative = FALSE) # Random Variates - Check all Types: for (type in evList()) { R = devCopula(u = grid2d(), param = NULL, type = type, output = "list") cat("\n") print(type) print(R) } # CHECK Border !!!! # Tawn Copula: revCopula(n = 5, param = NULL, type = "tawn") # Return Value: return() } # ------------------------------------------------------------------------------ test.devSlider = function() { # Arguments: # devSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # devSlider("persp") NA # Try Contour Slider: # devSlider("contour") NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EmpiricalCopulae.R0000644000176000001440000000360611370220745021526 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EMPIRICAL COPULAE: # pempiricalCopula Computes empirical copula probability # dempiricalCopula Computes empirical copula density ################################################################################ test.pempiricalCopula = function() { # Arguments: # pempiricalCopula(u, v, N = 10) NA # Return Value: return() } # ------------------------------------------------------------------------------ test.dempiricalCopula = function() { # Arguments: # dempiricalCopula(u, v, N = 10) NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EllipticalModelling.R0000644000176000001440000001004511370220745022220 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL COPULAE PARAMETER FITTING: # ellipticalCopulaSim Simulates bivariate elliptical copula # ellipticalCopulaFit Fits the paramter of an elliptical copula ################################################################################ test.copulaSim = function() { # Arguments: # ellipticalCopulaSim(n, rho = 0.75, param = NULL, # type = c("norm", "cauchy", "t")) # Normal Copula: rho = 0.5 R = ellipticalCopulaSim(n = 1000, rho = rho) R[1:10, ] plot(R, pch = 19) # Cauchy Copula: rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 100, rho = rho, type = "cauchy") R[1:10, ] plot(R, pch = 19) # Student-t Copula: rho = runif(1, -1, 1) nu = runif(1, 3, 20) print(c(rho, nu)) R = ellipticalCopulaSim(n = 1000, rho = rho, param = nu, type = "t") R[1:10, ] plot(R, pch = 19) # The remaining Copulae are not yet implemented ... # Return Value: return() } # ------------------------------------------------------------------------------ test.copulaFit = function() { # Arguments: # ellipticalCopulaFit(u, v = NULL, type = c("norm", "cauchy", "t"), ...) # Fit Normal Copula: rho = 0.5 R = ellipticalCopulaSim(n = 1000, rho = rho) fit = ellipticalCopulaFit(u = R[,1], v = R[,2]) fit rho - fit$par plot(c(-1,1), c(-1,1), xlab = "rho", ylab = "estimate", main = "Normal") for ( i in 1:100) { rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 1000, rho = rho) fit = ellipticalCopulaFit(R) points(rho, fit$par) print(c(rho-fit$par, fit$Rho-fit$par)) } # Fit Cauchy Copula: rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 100, rho = rho, type = "cauchy") ellipticalCopulaFit(R, type = "cauchy") rho plot(c(-1,1), c(-1,1), main = "Cauchy") for ( i in 1:100) { rho = runif(1, -1, 1) R = ellipticalCopulaSim(n = 1000, rho = rho, type = "cauchy") fit = ellipticalCopulaFit(R, type = "cauchy") points(rho, fit$par) print(c(rho-fit$par, fit$Rho-fit$par)) } # Fit Student-t Copula: rho = runif(1, -1, 1) nu = runif(1, 3, 20) print(c(rho, nu)) R = ellipticalCopulaSim(n = 1000, rho = rho, param = nu, type = "t") ellipticalCopulaFit(R, type = "t") plot(c(-1,1), c(-1,1), main = "Student-t") for ( i in 1:100) { rho = runif(1, -1, 1) nu = runif(1, 3, 20) R = ellipticalCopulaSim(n = 1000, rho = rho, param = nu, type = "t") fit = ellipticalCopulaFit(R, type = "t") points(rho, fit$par[1]) print(c(rho, nu, fit$par)) } # The remaining Copulae are not yet implemented ... # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EllipticalGenerator.R0000644000176000001440000001625511370220745022245 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: UTILITY FUNCTIONS: # ellipticalList Returns list of implemented Elliptical copulae # ellipticalParam Sets default parameters for an elliptical copula # ellipticalRange Returns the range of valid rho values # ellipticalCheck Checks if rho is in the valid range # FUNCTION: ELLIPTICAL GENERATOR AND RELATED FUNCTIONS: # gfunc Generator function for elliptical distributions # gfuncSlider Slider for generator, density and probability # .pelliptical Univariate elliptical distribution probability # .delliptical Univariate elliptical distribution density # .qelliptical Univariate elliptical distribution quantiles ################################################################################ test.ellipticalList = function() { # Arguments ? args(ellipticalList) # List: target = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") current = ellipticalList() print(current) # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalRange = function() { # Arguments ? args(ellipticalRange) # Range: for (type in ellipticalList()) { cat("\n") print(ellipticalRange(type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalParam = function() { # Arguments ? args(ellipticalParam) # Parameters: for (type in ellipticalList()) { cat("\n") print(unlist(ellipticalParam(type))) } # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalCheck = function() { # Arguments ? args(ellipticalCheck) # ellipticalCheck(rho = 0.75, param = NULL, type = ellipticalList()) # Range: for (type in ellipticalList()) { cat("\n") param = ellipticalParam(type)$param rho = param[1] # Returns NULL if OK print(ellipticalCheck(rho, param[-1], type)) } # Return Value: return() } ################################################################################ test.gfunc = function() { # Arguments ? args(gfunc) # gfunc(x, param = NULL, type = ellipticalList()) # Call Generator Function - Missing x: gfunc(type = "norm") gfunc(type = "cauchy") gfunc(type = "t") gfunc(type = "t", param = 2) gfunc(type = "logistic") gfunc(type = "laplace") gfunc(type = "kotz") gfunc(type = "kotz", param = 2) gfunc(type = "epower") gfunc(type = "epower", param = c(2, 1)) # Call Generator Function - With specified x: gfunc(x = 0:10, type = "norm") gfunc(x = 0:10, type = "cauchy") gfunc(x = 0:10, type = "t") gfunc(x = 0:10, type = "logistic") gfunc(x = 0:10, type = "laplace") gfunc(x = 0:10, type = "kotz") gfunc(x = 0:10, type = "epower") # Return Value: return() } # ------------------------------------------------------------------------------ test.gfuncSlider = function() { # Try Slider: # gfuncSlider() NA # Return Value: return() } # ------------------------------------------------------------------------------ test.pelliptical = function() { # Probability: q = (-1000:1000)/2000 S = NULL s = Sys.time() .pelliptical(q = q, param = NULL, type = "norm") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() .pelliptical(q = q, param = NULL, type = "cauchy") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() .pelliptical(q = q, param = 2, type = "t") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() .pelliptical(q = q, param = NULL, type = "logistic") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() .pelliptical(q = q, param = NULL, type = "laplace") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() .pelliptical(q = q, param = c(r = 1), type = "kotz") S = c(S, as.integer(Sys.time() - s)) s = Sys.time() .pelliptical(q = q, param = c(r = 1, s = 1), type = "epower") S = c(S, as.integer(Sys.time() - s)) # Return Value: return() } # ------------------------------------------------------------------------------ test.delliptical = function() { # Probability: N = 100 x = (-1999:1999)/N d = .delliptical(x = x, param = NULL, type = "norm") sum(d)/N d = .delliptical(x = x, param = NULL, type = "cauchy") sum(d)/N d = .delliptical(x = x, param = NULL, type = "t") sum(d)/N d = .delliptical(x = x, param = NULL, type = "logistic") sum(d)/N d = .delliptical(x = x, param = NULL, type = "laplace") sum(d)/N d = .delliptical(x = x, param = NULL, type = "kotz") sum(d)/N d = .delliptical(x = x, param = NULL, type = "epower") sum(d)/N # Non-default Parameters: d = .delliptical(x = (-100:100)/10, param = 1, type = "kotz") sum(d)/N d = .delliptical(x = (-100:100)/10, param = 1/2, type = "kotz") sum(d)/N # Return Value: return() } # ------------------------------------------------------------------------------ test.qelliptical = function() { # Probability: p = (0:10)/10 .qelliptical(p = p, param = NULL, type = "norm") .qelliptical(p = p, param = NULL, type = "cauchy") .qelliptical(p = p, param = 2, type = "t") .qelliptical(p = p, param = NULL, type = "logistic") .qelliptical(p = p, param = NULL, type = "laplace") .qelliptical(p = p, param = c(r = 1), type = "kotz") .qelliptical(p = p, param = c(r = 1, s = 1), type = "epower") # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EllipticalDependency.R0000644000176000001440000000637411370220745022376 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL COPULAE DEPENDENCE MASURES: # ellipticalTau Computes Kendall's tau for elliptical copulae # ellipticalRho Computes Spearman's rho for elliptical copulae # FUNCTION: ELLIPTICAL COPULAE TAIL COEFFICIENT: # ellipticalTailCoeff Computes tail dependence for elliptical copulae # ellipticalTailPlot Plots tail dependence function ################################################################################ test.ellipticalTau = function() { # Computes Kendall's tau for elliptical copulae args(ellipticalTau) ellipticalTau(rho = 0.5) ellipticalTau(rho = c(-0.5, 0, 0.5)) # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalRho = function() { # Computes Spearman's rho for elliptical copulae args(ellipticalRho) ellipticalRho(0.5) ellipticalRho(rho = c(-0.5, 0, 0.5)) # Return Value: return() } ################################################################################ test.ellipticalTailCoeff = function() { # Lower - Upper ---- # Tail Coefficient - Using Default Parameters: Type = c("norm", "cauchy", "t") for (type in Type) { ans = ellipticalTailCoeff(rho = 0.5, type = type) print(ans) cat("\n") } # Return Value: return() } # ------------------------------------------------------------------------------ test.ellipticalTailPlot = function() { # Arguments: # ellipticalTailPlot(param = NULL, type = c("norm", "cauchy", "t"), # tail = c("Lower", "Upper")) # Plot - Be patient, plotting takes some time ... Type = c("norm", "cauchy", "t") for (type in Type) { par(mfrow = c(2, 2), cex = 0.7) ellipticalTailPlot(type = type) ellipticalTailPlot(type = type, tail = "Lower") } # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.EllipticalCopulae.R0000644000176000001440000001177411370220745021710 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL COPULAE RANDOM DEVIATES: # rellipticalCopula Generates elliptical copula variates # rellipticalSlider Interactive plots of random variates # FUNCTION: ELLIPTICAL COPULAE PROBABILITY: # pellipticalCopula Computes elliptical copula probability # pellipticalSlider Interactive plots of probability # FUNCTION: ELLIPTICAL COPULAE DENSITY: # dellipticalCopula Computes elliptical copula density # dellipticalSlider Interactive plots of density ################################################################################ test.rellipticalCopula = function() { # Random Number Generator: R = rellipticalCopula(1000, type = "norm") plot(R, pch = 19, col = "steelblue", main = "norm") grid() R = rellipticalCopula(1000, type = "cauchy") plot(R, pch = 19, col = "steelblue", main = "cauchy") grid() R = rellipticalCopula(1000, type = "t") plot(R, pch = 19, col = "steelblue", main = "t-default") grid() R = rellipticalCopula(1000, param = c(nu = 3), type = "t") plot(R, pch = 19, col = "steelblue", main = "t3") grid() R = rellipticalCopula(1000, param = 3, type = "t") plot(R, pch = 19, col = "steelblue", main = "t3") grid() # The remaining copulae are not yet implemented ... # Return Value: return() } # ------------------------------------------------------------------------------ test.rellipticalSlider = function() { # Try Slider: # rellipticalSlider() NA # Return Value: return() } ################################################################################ test.pellipticalCopula = function() { # Arguments ? # pellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, # type = ellipticalList(), output = c("vector", "list"), border = TRUE) # Use Default Settings: par (mfrow = c(1, 1)) for (type in ellipticalList()) { UV = grid2d() p = pellipticalCopula(u = UV, rho = 0.75, type = type, output = "list") print(type) persp(p, main = type, theta = -40, phi = 30, col = "steelblue", ps = 9, xlab = "u", ylab = "v", zlab = "C") } # Return Value: return() } # ------------------------------------------------------------------------------ test.pellipticalSlider = function() { # Arguments: # pellipticalSlider(type = c("persp", "contour"), B = 20) # Try Perspective Slider: # pellipticalSlider() NA # Try Contour Slider: # pellipticalSlider("contour") NA # Return Value: return() } ################################################################################ test.dellipticalCopula = function() { # Arguments ? # dellipticalCopula(u = 0.5, v = u, rho = 0.75, param = NULL, # type = ellipticalList(), output = c("vector", "list"), border = TRUE) # Use Default Settings: par (mfrow = c(1, 1)) for (type in ellipticalList()) { UV = grid2d() d = dellipticalCopula(u = UV, rho = 0.75, type = type, output = "list") print(type) persp(d, main = type, theta = -40, phi = 30, col = "steelblue", ps = 9, xlab = "u", ylab = "v", zlab = "c") } # Return Value: return() } # ------------------------------------------------------------------------------ test.dellipticalSlider = function() { # Arguments: # dellipticalSlider(type = c("persp", "contour"), B = 20) # Try Perspective Slider: # dellipticalSlider() NA # Try Contour Slider: # dellipticalSlider("contour") NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.CopulaClass.R0000644000176000001440000000721011370220745020514 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: SPECIFICATION: # fCOPULA S4 class representation # show S4 print method for copula specification # FUNCTION: FRECHET COPULAE: # pfrechetCopula Computes Frechet copula probability # FUNCTION: SPEARMAN'S RHO: # .copulaRho Spearman's rho by integration for "ANY" copula ################################################################################ test.pfrechetCopula = function() { # pfrechetCopula(u = 0.5, v = u, type = c("m", "pi", "w"), # output = c("vector", "list")) # Grid: grid2d() grid2d(x = (0:10)/10) # Vector - M Copula: copula.vector = pfrechetCopula(u = grid2d(), output = "vector", type = "m") copula.vector class(copula.vector) cbind(u = grid2d()$x, v = grid2d()$y, C = copula.vector) # List - M Copula: copula.list = pfrechetCopula(u = grid2d(), output = "list", type = "m") copula.list class(copula.list) persp(copula.list, theta = -40, phi = 30, col = "steelblue", ps = 9) # Vector - Pi Copula: copula.vector = pfrechetCopula(u = grid2d(), output = "vector", type = "pi") copula.vector class(copula.vector) cbind(u = grid2d()$x, v = grid2d()$y, C = copula.vector) # List - Pi Copula: copula.list = pfrechetCopula(u = grid2d(), output = "list", type = "pi") copula.list class(copula.list) persp(copula.list, theta = -40, phi = 30, col = "steelblue", ps = 9) # Vector - W Copula: copula.vector = pfrechetCopula(u = grid2d(), output = "vector", type = "w") copula.vector class(copula.vector) cbind(u = grid2d()$x, v = grid2d()$y, C = copula.vector) # List - W Copula: copula.list = pfrechetCopula(u = grid2d(), output = "list", type = "w") copula.list class(copula.list) persp(copula.list, theta = -40, phi = 30, col = "steelblue", ps = 9) # Return Value: return() } ################################################################################ test.copulaRho = function() { # .copulaRho(rho = NULL, alpha = NULL, param = NULL, # family = c("elliptical", "archm", "ev", "archmax"), # type = NULL, error = 1e-3, ...) # Elliptical: .copulaRho(rho = 0.5, family = "elliptical", type = "norm") # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.BivariateGridding.R0000644000176000001440000000645211370220745021670 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: GRID DATA: # gridData Generates a grid data set # persp.gridData Generates a perspective plot from a grid data object # contour.gridData Generates a contour plot from a grid data object ################################################################################ test.gridData = function() { # gridData Generates a grid data set # persp.gridData Generates a perspective plot from a grid data object # contour.gridData Generates a contour plot from a grid data object # Generate Grid Data: gD = gridData() # Perspective Plot: persp(gD) # Contour Plot: contour(gD) # Return Value: return() } # ------------------------------------------------------------------------------ test.gridDataPlot = function() { if (FALSE) { require(akima) # gridData Generates a grid data set # persp.gridData Generates a perspective plot from a grid data object # contour.gridData Generates a contour plot from a grid data object # Generate Akima interpolated Grid Data: RNGkind(kind = "Marsaglia-Multicarry", normal.kind = "Inversion") set.seed(4711, kind = "Marsaglia-Multicarry") x = runif(999)-0.5 y = runif(999)-0.5 z = cos(2*pi*(x^2+y^2)) ans = akimaInterp(x, y, z, extrap = FALSE) persp(ans) title(main = "Akima Interpolation") contour(ans) title(main = "Akima Interpolation") # Generate Kriged Grid Data: require(spatial) RNGkind(kind = "Marsaglia-Multicarry", normal.kind = "Inversion") set.seed(4711, kind = "Marsaglia-Multicarry") x = runif(999)-0.5 y = runif(999)-0.5 z = cos(2*pi*(x^2+y^2)) ans = krigeInterp(x, y, z, extrap = FALSE) persp(ans) title(main = "Kriging") contour(ans) title(main = "Kriging") } # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.BivariateDistributions.R0000644000176000001440000001502211370220745022774 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # grid2d Returns from two vectors x-y grid coordinates # density2d Returns 2D Kernel Density Estimates # hist2d Returns 2D Histogram Counts # integrate2d Integrates over a two dimensional unit square # FUNCTION: BIVARIATE DISTRIBUTIONS: # pnorm2d Computes bivariate Normal probability function # dnorm2d Computes bivariate Normal density function # rnorm2d Generates bivariate normal random deviates # pcauchy2d Computes bivariate Cauchy probability function # dcauchy2d Computes bivariate Cauchy density function # rcauchy2d Generates bivariate Cauchy random deviates # pt2d Computes bivariate Student-t probability function # dt2d Computes bivariate Student-t density function # rt2d Generates bivariate Student-t random deviates # FUNCTION: ELLIPTICAL DISTRIBUTIONS: # delliptical2d Computes density for elliptical distributions # .gfunc2d Generator Function for elliptical distributions # .delliptical2dSlider Slider for bivariate densities ################################################################################ test.grid2d = function() { # Grid Data: grid2d(x = (0:10)/10) # Return Value: return() } # ------------------------------------------------------------------------------ test.density2d = function() { # Data: z = rnorm2d(1000) # Density: D = density2d(x = z[, 1], y = z[, 2]) .perspPlot(D) .contourPlot(D) # Return Value: return() } # ------------------------------------------------------------------------------ test.hist2d = function() { # Data: z = rnorm2d(1000) # Histogram: H = hist2d(x = z[, 1], y = z[, 2]) .perspPlot(H) .contourPlot(H) # Return Value: return() } # ------------------------------------------------------------------------------ test.integrate2d = function() { # Data: z = rnorm2d(1000) # Return Value: return() } # ------------------------------------------------------------------------------ test.norm2d = function() { # pnorm2d - Computes bivariate Normal probability function # dnorm2d - Computes bivariate Normal density function # rnorm2d - Generates bivariate normal random deviates # Normal Density: x = (-40:40)/10 X = grid2d(x) z = dnorm2d(X$x, X$y) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) .perspPlot(Z) .contourPlot(Z) # Normal Density, rho = 0.5: x = (-40:40)/10 X = grid2d(x) z = dnorm2d(X$x, X$y, rho = 0.5) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) .perspPlot(Z) .contourPlot(Z) # Return Value: return() } # ------------------------------------------------------------------------------ test.cauchy2d = function() { # pcauchy2d - Computes bivariate Cauchy probability function # dcauchy2d - Computes bivariate Cauchy density function # rcauchy2d - Generates bivariate Cauchy random deviates # Cauchy Density: x = (-40:40)/10 X = grid2d(x) z = dcauchy2d(X$x, X$y) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) .perspPlot(Z) .contourPlot(Z) # Cauchy Density, rho = 0.5: x = (-40:40)/10 X = grid2d(x) z = dcauchy2d(X$x, X$y, rho = 0.5) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) .perspPlot(Z) .contourPlot(Z) # Return Value: return() } # ------------------------------------------------------------------------------ test.t2d = function() { # pt2d - Computes bivariate Student-t probability function # dt2d - Computes bivariate Student-t density function # rt2d - Generates bivariate Student-t random deviates # Student Density: x = (-40:40)/10 X = grid2d(x) z = dt2d(X$x, X$y, nu = 4) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) .perspPlot(Z) .contourPlot(Z) # Student Density, rho = 0.5: x = (-40:40)/10 X = grid2d(x) z = dt2d(X$x, X$y, rho = 0.5, nu = 4) Z = list(x = x, y = x, z = matrix(z, ncol = length(x))) .perspPlot(Z) .contourPlot(Z) # Return Value: return() } # ------------------------------------------------------------------------------ test.delliptical2d = function() { # Settings: xy = grid2d((-50:50)/10) # Contour Plots: par(ask = FALSE) par(mfrow = c(1, 1)) contour(delliptical2d(xy, rho = 0.75, param = NULL, type = "norm", output = "list"), main = "norm") contour(delliptical2d(xy, rho = 0.75, param = NULL, type = "cauchy", output = "list"), main = "cauchy") contour(delliptical2d(xy, rho = 0.75, param = 4, type = "t", output = "list"), main = "t") contour(delliptical2d(xy, rho = 0.75, param = NULL, type = "laplace", output = "list"), main = "laplace") contour(delliptical2d(xy, rho = 0.75, param = NULL, type = "kotz", output = "list"), main = "kotz") contour(delliptical2d(xy, rho = 0.75, param = NULL, type = "epower", output = "list"), main = "epower") # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.BivariateBinning.R0000644000176000001440000000546211370220745021525 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # squareBinning Square binning of irregularly distributed data sets # plot S3 Method for plotting square binned data sets # FUNCTION: DESCRIPTION: # hexBinning Hexagonal binning of irregularly distributed data sets # plot S3 Method for plotting hexagonal binned data sets ################################################################################ test.squareBinning = function() { # squareBinning Square binning of irregularly distributed data sets # plot S3 Method for plotting square binned data sets # Generate Grid Data: RNGkind(kind = "Marsaglia-Multicarry", normal.kind = "Inversion") set.seed(4711, kind = "Marsaglia-Multicarry") sB = squareBinning(x = rnorm(1000), y = rnorm(1000)) # Plot: par(mfrow = c(1, 1)) plot(sB) title(main = "Square Binning") # Return Value: return() } # ------------------------------------------------------------------------------ test.hexBinning = function() { # hexBinning Hexagonal binning of irregularly distributed data sets # plot S3 Method for plotting hexagonal binned data sets # Generate Grid Data: RNGkind(kind = "Marsaglia-Multicarry", normal.kind = "Inversion") set.seed(4711, kind = "Marsaglia-Multicarry") hB = hexBinning(x = rnorm(1000), y = rnorm(1000)) # Plot: par(mfrow = c(1, 1)) plot(hB) title(main = "Hexagonal Binning") # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ArchimedeanModelling.R0000644000176000001440000000453511370220745022345 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER FITTING: # archmCopulaSim Simulates bivariate elliptical copula # archmCopulaFit Fits the paramter of an elliptical copula ################################################################################ test.archmCopulaSim = function() { # Arguments: # archmCopulaSim(n, alpha = NULL, type = archmList()) # Simulate Random Variates: for (type in archmList()) { ans = archmCopulaSim(5, type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmCopulaFit = function() { # Arguments: # archmCopulaFit(u, v = NULL, type = archmList(), ...) # Random Variates: R = archmCopulaSim(n = 100, alpha = 2, type = "4") # Fit: fit = archmCopulaFit(u = R, type = "4") fit # Fit: fit = archmCopulaFit(u = R[, 1], v = R[, 2], type = "4") fit # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ArchimedeanGenerator.R0000644000176000001440000001230211370220745022350 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # archmParam Sets Default parameters for an extreme value copula # archmRange Returns the range of valid alpha values # archmCheck Checks if alpha is in the valid range # FUNCTION: ARCHIMEDEAN COPULAE PHI GENERATOR: # Phi Computes Archimedean Phi, inverse and derivatives # PhiSlider Displays interactively generator function # FUNCTION: ARCHIMEDEAN DENSITY K GENERATOR: # Kfunc Computes Archimedean Density Kc and its Inverse # KfuncSlider Displays interactively the density and concordance ################################################################################ test.archmList = function() { # Arguments: # archmList() # List: archmList() # Return Value: return() } # ------------------------------------------------------------------------------ test.archmParam = function() { # Arguments: # archmParam(type = archmList()) # Parameters: for (type in archmList()) { cat("\n") print(unlist(archmParam(type))) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmRange = function() { # Arguments: # archmRange(type = archmList(), B = Inf) # Range: for (type in archmList()) { cat("\n") print(archmRange(type)) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmCheck = function() { # Arguments ? # archmCheck(alpha, type = archmList()) # Check: for (type in archmList()) { cat("\n") print(archmCheck(archmParam(type)$param)) } # Return Value: return() } ################################################################################ test.Phi = function() { # Arguments: # Phi(x, alpha = NULL, type = archmList(), inv = FALSE, deriv = paste(0:2)) # Call Generator Function Phi: for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = TRUE, deriv = "0")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = TRUE, deriv = "1")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = TRUE, deriv = "2")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = FALSE, deriv = "0")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = FALSE, deriv = "1")) cat("\n") } for (type in paste(1:22)) { print(Phi(x = 0.5, type = type, inv = FALSE, deriv = "2")) cat("\n") } # Return Value: return() } # ------------------------------------------------------------------------------ test.PhiSlider = function() { # Arguments: # PhiSlider() # Try Slider: # PhiSlider() NA # Return Value: return() } ################################################################################ test.Kfunc = function() { # Arguments: # Kfunc(x, alpha = NULL, type = archmList(), inv = FALSE, lower = 1e-08) # Call Generator Function Phi: for (type in paste(1:22)) { print(Kfunc(x = 0.5, inv = FALSE)) cat("\n") } for (type in paste(1:22)) { print(Kfunc(x = 0.5, inv = TRUE)) cat("\n") } # Return Value: return() } # ------------------------------------------------------------------------------ test.KfuncSlider = function() { # Arguments: # KfuncSlider() # Try Slider: # KfuncSlider() NA # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ArchimedeanDependency.R0000644000176000001440000000711311370220745022504 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # archmTau Returns Kendall's tau for Archemedean copulae # archmRho Returns Spearman's rho for Archemedean copulae # FUNCTION: ARCHIMEDEAN COPULAE TAIL COEFFICIENT: # archmTailCoeff Computes tail dependence for Archimedean copulae # archmTailPlot Plots Archimedean tail dependence function ################################################################################ test.archmTau = function() { # Arguments: # archmTau(alpha = NULL, type = archmList(), lower = 1e-10) # Tau: for (type in archmList()) { ans = archmTau(type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmRho = function() { # Arguments: # archmRho(alpha = NULL, type = archmList(), # method = c("integrate2d", "adapt"), error = 1e-05) # Rho: for (type in archmList()) { ans = archmRho(alpha = NULL, type = type, method = "integrate2d", error = 1e-5) cat("\n") print(type) print(ans) } # Return Value: return() } ################################################################################ test.archmTailCoeff = function() { # Arguments: # archmTailCoeff(alpha = NULL, type = archmList()) # Tail Coefficient: for (type in archmList()) { ans = archmTailCoeff(alpha = NULL, type = type) cat("\n") print(type) print(ans) } # Return Value: return() } # ------------------------------------------------------------------------------ test.archmTailPlot = function() { # Arguments: # archmTailPlot(alpha = NULL, type = archmList(), # tail = c("Upper", "Lower")) # Lower Tail Coefficient Plot: par(mfrow = c(2, 2), cex = 0.7) for (type in archmList()) { print(type) archmTailPlot(alpha = NULL, type = type, tail = "Upper") } # Upper Tail Coefficient Plot: for (type in archmList()) { print(type) archmTailPlot(alpha = NULL, type = type, tail = "Lower") } # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runit.ArchimedeanCopulae.R0000644000176000001440000001535611370220745022026 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE RANDOM VARIATES: # rarchmCopula Generates Archimedean copula random variates # rarchmSlider Displays interactively archimedean probability # FUNCTION: ARCHIMEDEAN COPULAE PROBABILITY: # parchmCopula Computes Archimedean copula probability # parchmSlider Displays interactively archimedean probability # FUNCTION: ARCHIMEDEAN COPULAE DENSITY: # darchmCopula Computes Archimedean copula density # darchmSlider Displays interactively archimedean density # FUNCTION: SPECIAL BIVARIATE COPULA: # rgumbelCopula Generates fast gumbel random variates # pgumbelCopula Computes bivariate Gumbel copula probability # dgumbelCopula Computes bivariate Gumbel copula density ################################################################################ test.rarchmCopula = function() { # Arguments: # rarchmCopula(n, alpha = NULL, type = archmList()) # Random Variates - Check all Types: for (type in archmList()) { R = rarchmCopula(n = 5, alpha = NULL, type = type) cat("\n") print(type) print(R) } # Return Value: return() } # ------------------------------------------------------------------------------ test.rarchmSlider = function() { # Arguments: # rarchmSlider(B = 10) # Try Slider: # rarchmSlider() NA # Return Value: return() } ################################################################################ test.parchmCopula = function() { # Arguments: # parchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), # output = c("vector", "list"), alternative = FALSE) # u - single input value: parchmCopula() parchmCopula(0.5) parchmCopula(0.5, 0.25) # u - input vector: U = (0:10)/10 V = U parchmCopula(U) parchmCopula(u = U, v = V) parchmCopula(u = U, v = rev(V)) # u - input matrix: parchmCopula(cbind(U, V)) # u - input list: u = grid2d() u parchmCopula(u) # output = "vector" parchmCopula(u, output = "list") diff = parchmCopula(u) - parchmCopula(u, alternative = TRUE) mean(abs(diff)) # Check All Types: u = grid2d() for (type in paste(1:22)) { cop1 = parchmCopula(u, type = type, output = "list") cop2 = parchmCopula(u, type = type, output = "list", alternative = TRUE) cat("Type: ", type, "\t Difference: ", mean(abs(cop1$z-cop2$z)), "\n") persp(cop1, main = type, theta = -40, phi = 30, col = "steelblue") } # Return Value: return() } # ------------------------------------------------------------------------------ test.parchmSlider = function() { # Arguments: # parchmSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # parchmSlider() NA # Try Contour Slider: # parchmSlider("contour") NA # Return Value: return() } ################################################################################ test.darchmCopula = function() { # Arguments: # darchmCopula(u = 0.5, v = u, alpha = NULL, type = archmList(), # output = c("vector", "list"), alternative = FALSE) # u - single input value: darchmCopula() darchmCopula(0.5) darchmCopula(0.5, 0.25) # u - input vector: U = (0:10)/10 V = U darchmCopula(U) darchmCopula(u = U, v = V) darchmCopula(u = U, v = rev(V)) # u - input matrix: darchmCopula(cbind(U, V)) # u - input list: u = grid2d() u darchmCopula(u) # output = "vector" darchmCopula(u, output = "list") # Check All Types: u = grid2d(x = (0:25)/25) for (type in archmList()) { cop1 = darchmCopula(u, type = type, output = "list") cop2 = darchmCopula(u, type = type, output = "list", alternative = TRUE) diff = abs(cop1$z-cop2$z) diff = diff[!is.na(diff)] cat("Type: ", type, "\t Difference: ", mean(diff), "\n") persp(cop2, main = type, theta = -40, phi = 30, col = "steelblue") } # Return Value: return() } # ------------------------------------------------------------------------------ test.darchmSlider = function() { # Arguments: # darchmSlider(type = c("persp", "contour"), B = 10) # Try Perspective Slider: # darchmSlider() NA # Try Contour Slider: # darchmSlider("contour") NA # Return Value: return() } ################################################################################ test.rgumbelCopula = function() { # Generates fast gumbel random variates # Copula: rgumbelCopula() # Return Value: return() } # ------------------------------------------------------------------------------ test.pgumbelCopula = function() { # Computes bivariate Gumbel copula probability # Copula: pgumbelCopula() # Return Value: return() } # ------------------------------------------------------------------------------ test.dgumbelCopula = function() { # Computes bivariate Gumbel copula density # Copula: dgumbelCopula() # Return Value: return() } ################################################################################ fCopulae/inst/unitTests/runTests.R0000644000176000001440000000453011370220745016774 0ustar ripleyuserspkg <- "fCopulae" if(require("RUnit", quietly = TRUE)) { library(package=pkg, character.only = TRUE) if(!(exists("path") && file.exists(path))) path <- system.file("unitTests", package = pkg) ## --- Testing --- ## Define tests testSuite <- defineTestSuite(name = paste(pkg, "unit testing"), dirs = path) if(interactive()) { cat("Now have RUnit Test Suite 'testSuite' for package '", pkg, "' :\n", sep='') str(testSuite) cat('', "Consider doing", "\t tests <- runTestSuite(testSuite)", "\nand later", "\t printTextProtocol(tests)", '', sep = "\n") } else { ## run from shell / Rscript / R CMD Batch / ... ## Run tests <- runTestSuite(testSuite) if(file.access(path, 02) != 0) { ## cannot write to path -> use writable one tdir <- tempfile(paste(pkg, "unitTests", sep="_")) dir.create(tdir) pathReport <- file.path(tdir, "report") cat("RUnit reports are written into ", tdir, "/report.(txt|html)", sep = "") } else { pathReport <- file.path(path, "report") } ## Print Results: printTextProtocol(tests, showDetails = FALSE) printTextProtocol(tests, showDetails = FALSE, fileName = paste(pathReport, "Summary.txt", sep = "")) printTextProtocol(tests, showDetails = TRUE, fileName = paste(pathReport, ".txt", sep = "")) ## Print HTML Version to a File: ## printHTMLProtocol has problems on Mac OS X if (Sys.info()["sysname"] != "Darwin") printHTMLProtocol(tests, fileName = paste(pathReport, ".html", sep = "")) ## stop() if there are any failures i.e. FALSE to unit test. ## This will cause R CMD check to return error and stop tmp <- getErrors(tests) if(tmp$nFail > 0 | tmp$nErr > 0) { stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail, ", R errors: ", tmp$nErr, ")\n\n", sep="")) } } } else { cat("R package 'RUnit' cannot be loaded -- no unit tests run\n", "for package", pkg,"\n") } ################################################################################ fCopulae/inst/unitTests/Makefile0000644000176000001440000000042011370220745016454 0ustar ripleyusersPKG=fCopulae TOP=../.. SUITE=doRUnit.R R=R all: inst test inst: # Install package -- but where ?? -- will that be in R_LIBS ? cd ${TOP}/..;\ ${R} CMD INSTALL ${PKG} test: # Run unit tests export RCMDCHECK=FALSE;\ cd ${TOP}/tests;\ ${R} --vanilla --slave < ${SUITE}fCopulae/inst/COPYRIGHT.html0000644000176000001440000002041111370220745015252 0ustar ripleyusers Rmetrics::COPYRIGHT

Rmetrics Copyrights

2005-12-18 Built 221.10065 

  
________________________________________________________________________________
Copyrights (C) for 

    R:  
      see R's copyright and license file
      
    Version R 2.0.0 claims:
    - The stub packages from 1.9.x have been removed.
    - All the datasets formerly in packages 'base' and 'stats' have
      been moved to a new package 'datasets'. 
    - Package 'graphics' has been split into 'grDevices' (the graphics
      devices shared between base and grid graphics) and 'graphics'
      (base graphics). 
    - Packages must have been re-installed for this version, and
      library() will enforce this.
    - Package names must now be given exactly in library() and
      require(), regardless of whether the underlying file system is
      case-sensitive or not.    

________________________________________________________________________________
for 
    
    Rmetrics:
      (C) 1999-2005, Diethelm Wuertz, GPL
      Diethelm Wuertz 
      www.rmetrics.org
      info@rmetrics.org
 
________________________________________________________________________________
for non default loaded basic packages part of R's basic distribution

    MASS:    
      Main Package of Venables and Ripley's MASS.
      We assume that MASS is available. 
      Package 'lqs' has been returned to 'MASS'.  
      S original by Venables & Ripley.
      R port by Brian Ripley .
      Earlier work by Kurt Hornik and Albrecht Gebhardt.
    methods: 
      Formally defined methods and classes for R objects, plus other 
      programming tools, as described in the reference "Programming 
      with Data" (1998), John M. Chambers, Springer NY. 
      R Development Core Team.
    mgcv:   
      Routines for GAMs and other generalized ridge regression
      with multiple smoothing parameter selection by GCV or UBRE.
      Also GAMMs by REML or PQL. Includes a gam() function.
      Simon Wood 
    nnet: 
      Feed-forward Neural Networks and Multinomial Log-Linear Models
      Original by Venables & Ripley. 
      R port by Brian Ripley .
      Earlier work by Kurt Hornik and Albrecht Gebhardt.
      
________________________________________________________________________________
for the code partly included as builtin functions from other R ports:

    fBasics:CDHSC.F
      GRASS program for distributional testing.
      By James Darrell McCauley 
      Original Fortran Source by Paul Johnson EZ006244@ALCOR.UCDAVIS.EDU>
    fBasics:nortest
      Five omnibus tests for the composite hypothesis of normality
      R-port by Juergen Gross 
    fBasics:SYMSTB.F
      Fast numerical approximation to the Symmetric Stable distribution 
      and density functions.  
      By Hu McCulloch 
    fBasics:tseries
      Functions for time series analysis and computational finance.
      Compiled by Adrian Trapletti 
         
    fCalendar:date     
      The tiny C program from Terry Therneau  is used
      R port by Th. Lumley ,
      K. Halvorsen , and 
      Kurt Hornik 
    fCalendar:holidays
      The holiday information was collected from the internet and 
      governmental sources obtained from a few dozens of websites
    fCalendar:libical
      Libical is an Open Source implementation of the IETF's 
      iCalendar Calendaring and Scheduling protocols. (RFC 2445, 2446, 
      and 2447). It parses iCal components and provides a C API for 
      manipulating the component properties, parameters, and subcomponents.
    fCalendar:vtimezone
      Olsen's VTIMEZONE database consists of data files are released under 
      the GNU General Public License, in keeping with the license options of 
      libical. 
     
    fSeries:bdstest.c
      C Program to compute the BDS Test.
      Blake LeBaron
    fSeries:fracdiff  
      R functions, help pages and the Fortran Code for the 'fracdiff' 
      function are included. 
      S original by Chris Fraley 
      R-port by Fritz Leisch 
      since 2003-12: Martin Maechler
    fSeries:lmtest
      R functions and help pages for the linear modelling tests are included .
      Compiled by Torsten Hothorn ,
      Achim Zeileis , and
      David Mitchell
    fSeries:mda    
      R functions, help pages and the Fortran Code for the 'mars' function
      are implemeted.
      S original by Trevor Hastie & Robert Tibshirani,
      R port by Friedrich Leisch, Kurt Hornik and Brian D. Ripley 
    fSeries:modreg
      Brian Ripley and the R Core Team
    fSeries:polspline   
      R functions, help pages and the C/Fortran Code for the 'polymars' 
      function are implemented
      Charles Kooperberg 
    fSeries:systemfit
      Simultaneous Equation Estimation Package.
      R port by Jeff D. Hamann  and 
      Arne Henningsen 
    fSeries:tseries
      Functions for time series analysis and computational finance.
      Compiled by Adrian Trapletti 
    fSeries:UnitrootDistribution:
      The program uses the Fortran routine and the tables 
      from J.G. McKinnon. 
    fSeries:urca
      Unit root and cointegration tests for time series data.
      R port by Bernhard Pfaff .
     
    fExtremes:evd
      Functions for extreme value distributions.
      R port by Alec Stephenson 
      Function 'fbvpot' by Chris Ferro.
    fExtremes:evir
      Extreme Values in R
      Original S functions (EVIS) by Alexander McNeil 
      R port by Alec Stephenson   
    fExtremes:ismev
      An Introduction to Statistical Modeling of Extreme Values
      Original S functions by Stuart Coles 
      R port/documentation by Alec Stephenson 
      
    fOptions
      Option Pricing formulas are implemented along the book and 
      the Excel spreadsheets of E.G. Haug, "The Complete Guide to Option 
      Pricing"; documentation is partly taken from www.derivicom.com which 
      implements a C Library based on Haug. For non-academic and commercial 
      use we recommend the professional software from "www.derivicom.com".  
    fOptions:SOBOL.F
      ACM Algorithm 659 by P. Bratley and B.L. Fox
      Extension on Algorithm 659 by S. Joe and F.Y. Kuo
    fOptions:CGAMA.F
      Complex gamma and related functions.
      Fortran routines by Jianming Jin.
    fOptions:CONHYP.F
      Confluenet Hypergeometric and related functions.
      ACM Algorithm 707 by mark Nardin, W.F. Perger, A. Bhalla
             
    fPortfolio:mvtnorm
      Multivariate Normal and T Distribution.
      Alan Genz , 
      Frank Bretz 
      R port by Torsten Hothorn 
    fPortfolio:quadprog
      Functions to solve Quadratic Programming Problems.
      S original by Berwin A. Turlach  
      R port by Andreas Weingessel 
    fPortfolio:sn
      The skew-normal and skew-t distributions.
      R port by Adelchi Azzalini 
    fPortfolio:tseries
      Functions for time series analysis and computational finance.
      Compiled by Adrian Trapletti
fCopulae/R/0000755000176000001440000000000012110722425012235 5ustar ripleyusersfCopulae/R/zzz.R0000644000176000001440000000271212110721717013222 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2008, Diethelm Wuertz, Rmetrics Foundation, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ .onLoad <- function(libname, pkgname) { setRmetricsOptions(.counter = NA) } if(!exists("Sys.setenv", mode = "function")) # pre R-2.5.0, use "old form" Sys.setenv <- Sys.putenv ################################################################################ fCopulae/R/mv-dst.R0000644000176000001440000001077211370220745013606 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # dmvst Multivariate Skew Sudent-t Density Function # pmvst Multivariate Skew Sudent-t Probability Function # rmvst Multivariate Skew Sudent-t Random Deviates # REQUIREMENTS: DESCRIPTION: # "mvtnorm" Contributed R - Package # "sn" | "mnormt" Contributed R - Package ################################################################################ ################################################################################ dmvst = function(x, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim), df = 4) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Sudent-t Density Function # Arguments: # FUNCTION: # Settings: xi = mu ans = NA # Univariate Case: if (is.vector(x) & dim == 1) { ans = dst(x, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1], df = Inf) } # Multivariate Case: if (is.matrix(x)) { if (dim == ncol(x)) { ans = dmst(x = x, xi = xi, Omega = Omega, alpha = alpha, df = df) } } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("conflicting x and dim") } # Return Value: as.vector(ans) } # ------------------------------------------------------------------------------ pmvst = function(q, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim), df = 4) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Sudent-t Probability Function # Arguments: # FUNCTION: # Settings: x = q xi = mu ans = NA # Univariate Case: if (is.vector(x) & dim == 1) { ans = pst(x, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1], df = df) } # Multivariate Case: if (is.matrix(x)) { if (dim == ncol(x)) { ans = NULL for (i in 1:nrow(x) ) { ans = c(ans, pmst(x = x[i,], xi = xi, Omega = Omega, alpha = alpha, df = df)) } } } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("conflicting x and dim") } # Return Value: as.vector(ans) } # ------------------------------------------------------------------------------ rmvst = function(n, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim), df = 4) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Sudent-t Random Number Generator # Arguments: # FUNCTION: # Settings: ans = NA xi = mu # Univariate Case: if (dim == 1) { ans = as.matrix(rst(n, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1], df = df)) } # Multivariate Case: if (dim > 1) { ans = rmst(n, xi = xi, Omega = Omega, alpha = alpha, df = df) } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("dim must be greater 1") } # Return Value: rownames(ans) = as.character(1:n) colnames(ans) = as.character(1:dim) ans } ################################################################################ fCopulae/R/mv-dsnorm.R0000644000176000001440000001121611370220745014310 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # dmvsnorm Multivariate Skew Normal Density Function # pmvsnorm Multivariate Skew Normal Probability Function # rmvsnorm Multivariate Skew Normal Random Deviates # REQUIREMENTS: DESCRIPTION: # "mvtnorm" Contributed R - Package # "sn" | "mnormt" Contributed R - Package ################################################################################ ################################################################################ # Multivariate Skew Normal Distribution dmvsnorm = function(x, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim)) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Normal Density Function # Note: # Requires dsn() and dmsn() from R package sn # FUNCTION: # Settings: xi = mu ans = NA # Univariate Case: if (is.vector(x) & dim == 1) { ans = dsn(x, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1]) } # Multivariate Case: if (is.matrix(x)) { if (dim == ncol(x)) { ans = dmsn(x = x, xi = xi, Omega = Omega, alpha = alpha) } } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("conflicting x and dim") } # Return Value: as.vector(ans) } # ------------------------------------------------------------------------------ pmvsnorm = function(q, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim)) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Normal Probability Function # Algorithm: # Note: # Requires psn() and pmsn() from R package sn # FUNCTION: # Settings: x = q xi = mu ans = NA # Univariate Case: if (is.vector(x) & dim == 1) { ans = psn(x, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1]) } # Multivariate Case: if (is.matrix(x)) { if (dim == ncol(x)) { ans = NULL for (i in 1:nrow(x) ) { ans = c(ans, pmsn(x = x[i,], xi = xi, Omega = Omega, alpha = alpha)) } } } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("conflicting x and dim") } # Return Value: as.vector(ans) } # ------------------------------------------------------------------------------ rmvsnorm = function(n, dim = 2, mu = rep(0, dim), Omega = diag(dim), alpha = rep(0, dim)) { # A function implemented by Diethelm Wuertz # Description: # Multivariate Skew Normal Random Number Generator # Algorithm: # Note: # Requires rsn() and rmsn() from R package sn # FUNCTION: # Settings: ans = NA xi = mu # Univariate Case: if (dim == 1) { ans = as.matrix(rsn(n, location = xi[1], scale = as.vector(Omega)[1], shape = alpha[1])) } # Multivariate Case: if (dim > 1) { ans = rmsn(n, xi = xi, Omega = Omega, alpha = alpha) } # Check for conflicting Dimensions: if (is.na(ans[1])) { stop("dim must be greater 1") } # Return Value: rownames(ans) = as.character(1:n) colnames(ans) = as.character(1:dim) ans } ################################################################################ fCopulae/R/mv-distributions.R0000644000176000001440000004006611370220745015715 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: PARAMETER ESTIMATION: # fMV S4 Object of class 'fMV' # mvFit Fits a MV Normal or Student-t Distribution # print.fMV S3: Print method for objects of class 'fMV' # plot.fMV S3: Plot method for objects of class 'fMV' # summary.fMV S3: Summary method for objects of class 'fMV' # .mvnormFit Fits a Multivariate Normal Distribution # .mvstFit Fits a Multivariate Student-t Distribution # .mvsnormPlot Plots for Multivariate Normal Distribution # .mvstPlot Plots for Multivariate Student-t Distribution # REQUIREMENTS: DESCRIPTION: # "mvtnorm" Contributed R - Package # "sn" | "mnormt" Contributed R - Package ################################################################################ ################################################################################ # PARAMETER FIT: setClass("fMV", representation( call = "call", method = "character", model = "list", data = "data.frame", fit = "list", title = "character", description = "character") ) # ------------------------------------------------------------------------------ mvFit = function(x, method = c("snorm", "st"), fixed.df = NA, title = NULL, description = NULL, trace = FALSE, ...) { # A function implemented by Diethelm Wuertz # Description: # FUNCTION: # Fit: if (method[1] == "snorm") { # Normal Fit: fit = .mvsnormFit(x = x, trace = trace, ...) fit$df = Inf } if (method[1] == "st") { # Student-t Fit: fit = .mvstFit(x = x, fixed.df = fixed.df, trace = trace, ...) } # Add to fit: fit$method = method[1] class(fit) = "list" # Model Slot: model = list(beta = fit$beta, Omega = fit$Omega, alpha = fit$alpha, df = fit$df) # Title Slot: if (is.null(title)) { if (method[1] == "snorm") title = "Multivariate Normal Distribution" if (method[1] == "st") title = "Multivariate Student-t Distribution" } # Description Slot: if (is.null(description)) description = description() # Return Value: new("fMV", call = as.call(match.call()), method = as.character(method[1]), model = model, data = as.data.frame(x), fit = fit, title = as.character(title), description = as.character(description) ) } # ------------------------------------------------------------------------------ setMethod("show", "fMV", function(object) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # FUNCTION: # Extract fit: fit = object@fit # Print: cat("\nCall:\n ") print.default(fit$call) cat("\nParameter Sstimates:\n") print.default(fit$dp) cat("\nParameter Errors:\n") print.default(fit$se) # cat("\nOptimization:\n") # print.default(fit$optim) }) # ------------------------------------------------------------------------------ plot.fMV = function(x, which = "ask", ...) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # FUNCTION: # Plot: if (x@fit$method == "snorm") { # Multivariate Skew Normal Distribution: return(.mvsnormPlot(x = x@fit, which = which, ...)) } if (x@fit$method == "st") { # Multivariate Skew Student-t Distribution: return(.mvstPlot(x = x@fit, which = which, ...)) } } # ------------------------------------------------------------------------------ summary.fMV = function(object, which = "ask", doplot = TRUE, ...) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # FUNCTION: # Print: print(x = object, ...) # Plot: if (doplot) plot(x = object, which = which, doplot, ...) # Return Value: invisible(object) } ################################################################################ # INERNAL FUNCTIONS: .mvsnormFit = function(x, trace = FALSE, ...) { # A function implemented by Diethelm Wuertz # Description: # Internal Function # Arguments: # FUNCTION: # Settings: y = x y.name = deparse(substitute(y)) y.names = dimnames(y)[[2]] y = as.matrix(y) colnames(y) = y.names k = ncol(y) freq = rep(1, nrow(y)) n = sum(freq) X = rep(1, nrow(y)) X = as.matrix(X) m = ncol(X) dimnames(y) = list(NULL, outer("V", as.character(1:k), paste, sep = "")) y.names = as.vector(dimnames(y)[[2]]) qrX = qr(X) # Fit: mle = msn.mle(X = X, y = y, freq = freq, trace = trace, ...) mle$call = match.call() mle$y = y mle$y.names = y.names # Parameters: mle$beta = beta = mle$dp$beta mle$xi = xi = X %*% beta mle$Omega = Omega = mle$dp$Omega mle$alpha = alpha = mle$dp$alpha # Test: # dev.norm = msn.dev(c(qr.coef(qrX, y), rep(0, k)), X, y, freq) # test = dev.norm + 2 * mle$logL # p.value = 1 - pchisq(test, k) # mle$test.normality = list(LRT = test, p.value = p.value) # Save for Plot: Xb = qr.fitted(qrX, y) res = qr.resid(qrX, y) mle$k = k mle$n = n mle$pp = qchisq((1:n)/(n + 1), k) mle$rad.n = apply((y - Xb) * ((y - Xb) %*% solve(var(res))), 1, sum) mle$rad.sn = apply((y - xi) * ((y - xi) %*% solve(Omega)), 1, sum) # Return Value: class(mle) = "snFit" mle } # ------------------------------------------------------------------------------ .mvstFit = function(x, fixed.df = NA, trace = FALSE, ...) { # A function implemented by Diethelm Wuertz # Description: # Internal Function # Arguments: # FUNCTION: # Settings: y = as.matrix(x) k = ncol(y) y.name = deparse(substitute(y)) dimnames(y) = list(NULL, outer("V", as.character(1:k), paste, sep = "")) y.names = dimnames(y)[[2]] freq = rep(1, nrow(y)) n = sum(freq) X = as.matrix(rep(1, nrow(y))) qrX = qr(X) m = ncol(X) # Fit: mle = mst.mle(X = X, y = y, freq = freq, fixed.df = fixed.df, trace = trace, ...) mle$call = match.call() mle$y = y mle$y.names = y.names # Parameters: mle$beta = beta = mle$dp$beta mle$xi = xi = X %*% beta mle$Omega = Omega = mle$dp$Omega mle$alpha = alpha = mle$dp$alpha mle$df = df = mle$dp$df # Save for Plot: Xb = qr.fitted(qrX, y) res = qr.resid(qrX, y) mle$k = k mle$n = n mle$pp = k * qf((1:n)/(n + 1), k, df) mle$rad.n = as.vector(apply(res * (res %*% solve(var(res))), 1, sum)) mle$rad.sn = as.vector(apply((y - xi)*((y - xi) %*% solve(Omega)), 1, sum)) # Return Value: class(mle) = "stFit" mle } # ------------------------------------------------------------------------------ .mvsnormPlot = function(x, which = "ask", ...) { # A function implemented by Diethelm Wuertz # Description: # Internal Plot Function # Arguments: # x - the slot @fit from an object of class "fMV" # FUNCTION: # Settings: dim = ncol(x$y) # Plot Title: plot1Title = "Scatterplots" if (dim == 1) plot1Title = "Histogram Plot" # Plot: interactivePlot( x = x, choices = c( plot1Title, "Normal QQ-Plot", "Skew-Normal QQ-Plot", "Normal PP-Plot", "Skew-Normal PP-Plot"), plotFUN = c( ".mvsnorm.plot.1", ".mvsnorm.plot.2", ".mvsnorm.plot.3", ".mvsnorm.plot.4", ".mvsnorm.plot.5"), which = which) # Return Value: invisible(x) } # ------------------------------------------------------------------------------ .mvsnorm.plot.1 <- function(x) { # Plot: dim = x$k if(dim == 1) .mvsnorm.plot.1A(x) else .mvsnorm.plot.1B(x) } # ------------------------------------------------------------------------------ .mvsnorm.plot.1A <- function(x) { # Plot: z = x y0 <- z$y xi0 <- apply(z$xi, 2, mean) y0 <- as.vector(y0) x <- seq(min(pretty(y0, 10)), max(pretty(y0, 10)), length = 100) omega <- sqrt(diag(z$Omega)) dp0 <- c(xi0, omega, z$alpha) xlab <- z$y.name hist(y0, prob = TRUE, breaks = "FD", xlab = xlab, ylab = "density", border = "white", col = "steelblue4", main = z$y.name) lines(x, dsn(x, dp0[1], dp0[2], dp0[3])) if (length(y0) < 201) points(y0, rep(0, z$n), pch = 1) } # ------------------------------------------------------------------------------ .mvsnorm.plot.1B <- function(x) { # Plot: opt = options() options(warn = -1) pairs( x$y, labels = x$y.names, panel = function(x, y, Y, y.names, xi, Omega, alpha) { for (i in 1:length(alpha)) { if (all(Y[, i] == x)) Ix = i if (all(Y[, i] == y)) Iy = i } points(x, y) marg = msn.marginal(xi, Omega, alpha, c(Ix, Iy)) xi.marg = marg$xi Omega.marg = marg$Omega alpha.marg = marg$alpha x1 = seq(min(x), max(x), length = 30) x2 = seq(min(y), max(y), length = 30) dsn2.plot(x1, x2, xi.marg, Omega.marg, alpha.marg, add = TRUE, col = "steelblue4")}, Y = x$y, y.names = dimnames(x$y)[[2]], xi = apply(x$xi, 2, mean), Omega = x$Omega, alpha = x$alpha) options(opt) } # ------------------------------------------------------------------------------ .mvsnorm.plot.2 <- function(x) { # Plot: plot(x$pp, sort(x$rad.n), pch = 1, ylim = c(0, max(x$rad.n, x$rad.sn)), xlab = "Chi-square Percentiles", ylab = "Mahalanobis Distances") abline(0, 1, lty = 3) title(main = "Normal QQ-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvsnorm.plot.3 <- function(x) { # Plot: plot(x$pp, sort(x$rad.sn), pch = 1, ylim = c(0, max(x$rad.n, x$rad.sn)), xlab = "Percentiles of chi-square distribution", ylab = "Mahalanobis distances") abline(0, 1, lty = 3) title(main = "Skew-Normal QQ-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvsnorm.plot.4 <- function(x) { # Plot: plot((1:x$n)/(x$n + 1), sort(pchisq(x$rad.n, x$k)), xlab = "", ylab = "") abline(0, 1, lty = 3) title(main = "Normal PP-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvsnorm.plot.5 <- function(x) { # Plot: plot((1:x$n)/(x$n + 1), sort(pchisq(x$rad.sn, x$k)), xlab = "", ylab = "") abline(0, 1, lty = 3) title(main = "Skew-Normal PP-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvstPlot = function(x, which = "ask", ...) { # A function implemented by Diethelm Wuertz # Description: # Internal Plot Function # Arguments: # x - the slot @fit from an object of class "fMV" # FUNCTION: # Settings: dim = ncol(x$y) # Plot Title: plot1Title = "Scatterplots" if (dim == 1) plot1Title = "Histogram Plot" # Plot: plot1Title = "Scatterplots" if (dim == 1) plot1Title = "Histogram Plot" interactivePlot( x = x, choices = c( plot1Title, "Normal QQ-Plot", "Skew-Normal QQ-Plot", "Normal PP-Plot", "Skew-Normal PP-Plot"), plotFUN = c( ".mvst.plot.1", ".mvst.plot.2", ".mvst.plot.3", ".mvst.plot.4", ".mvst.plot.5"), which = which) # Return Value: invisible(x) } # ------------------------------------------------------------------------------ .mvst.plot.1 <- function(x) { # Plot: dim = x$k if(dim == 1) .mvst.plot.1A(x) else .mvst.plot.1B(x) } # ------------------------------------------------------------------------------ .mvst.plot.1A <- function(x) { # Plot: z = x y0 <- z$y xi0 <- apply(z$xi, 2, mean) y0 <- as.vector(y0) x <- seq(min(pretty(y0, 10)), max(pretty(y0, 10)), length = 100) omega <- sqrt(diag(z$Omega)) dp0 <- c(xi0, omega, z$alpha, z$df) xlab <- z$y.name hist(y0, prob = TRUE, breaks = "FD", xlab = xlab, ylab = "density", border = "white", col = "steelblue4", main = z$y.name) lines(x, dst(x, dp0[1], dp0[2], dp0[3], dp0[4])) if (length(y0) < 201) points(y0, rep(0, z$n), pch = 1) } # ------------------------------------------------------------------------------ .mvst.plot.1B <- function(x) { # Plot: opt = options() options(warn = -1) pairs( x$y, labels = x$y.names, panel = function(x, y, Y, y.names, xi, Omega, alpha, df) { for (i in 1:length(alpha)) { if (all(Y[, i] == x)) Ix = i if (all(Y[, i] == y)) Iy = i } points(x, y) marg = msn.marginal(xi, Omega, alpha, c(Ix, Iy)) xi.marg = marg$xi Omega.marg = marg$Omega alpha.marg = marg$alpha x1 = seq(min(x), max(x), length = 30) x2 = seq(min(y), max(y), length = 30) dst2.plot(x1, x2, xi.marg, Omega.marg, alpha.marg, df, add = TRUE, col = "steelblue4")} , Y = x$y, y.names = dimnames(x$y)[[2]], xi = apply(x$xi, 2, mean), Omega = x$Omega, alpha = x$alpha, df = x$df) options(opt) } # ------------------------------------------------------------------------------ .mvst.plot.2 <- function(x) { # Plot: plot(x$pp, sort(x$rad.n), pch = 1, ylim = c(0, max(x$rad.n, x$rad.sn)), xlab = "Chi-square Percentiles", ylab = "Mahalanobis Distances") abline(0, 1, lty = 3) title(main = "Normal QQ-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvst.plot.3 <- function(x) { # Plot: plot(x$pp, sort(x$rad.sn), pch = 1, ylim = c(0, max(x$rad.n, x$rad.sn)), xlab = "Percentiles of chi-square distribution", ylab = "Mahalanobis distances") abline(0, 1, lty = 3) title(main = "Skew-Normal QQ-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvst.plot.4 <- function(x) { # Plot: plot((1:x$n)/(x$n + 1), sort(pchisq(x$rad.n, x$k)), xlab = "", ylab = "") abline(0, 1, lty = 3) title(main = "Normal PP-Plot", sub = x$y.name) } # ------------------------------------------------------------------------------ .mvst.plot.5 <- function(x) { # Plot: plot((1:x$n)/(x$n + 1), sort(pchisq(x$rad.sn, x$k)), xlab = "", ylab = "") abline(0, 1, lty = 3) title(main = "Skew-Normal PP-Plot", sub = x$y.name) } ################################################################################ fCopulae/R/fCopulaeEnv.R0000644000176000001440000000116311370220745014575 0ustar ripleyusers.fCopulaeEnv <- new.env(hash = TRUE) .setfCopulaeEnv <- function(...) { x <- list(...) nm <- names(x) if (is.null(nm) || "" %in% nm) stop("all arguments must be named") sapply(nm, function(nm) assign(nm, x[[nm]], envir = .fCopulaeEnv)) invisible() } .getfCopulaeEnv <- function(x = NULL, unset = "") { if (is.null(x)) x <- ls(all.names = TRUE, envir = .fCopulaeEnv) ### unlist(mget(x, envir = .fCopulaeEnv, mode = "any", ### ifnotfound = as.list(unset)), recursive = FALSE) get(x, envir = .fCopulaeEnv, mode = "any") } fCopulae/R/bv-dt.R0000644000176000001440000001017211370220745013402 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: BIVARIATE STUDENT-T DISTRIBUTION: # pt2d Computes bivariate Student-t probability function # dt2d Computes bivariate Student-t density function # rt2d Generates bivariate Student-t random deviates ################################################################################ pt2d = function(x, y = x, rho = 0, nu = 4) { # pnorm2d: A copy from R package "sn" # Description: # Computes bivariate Student-t probability function # Arguments: # x, y - two numeric values or vectors of the same length at # which the probability will be computed. # Example: # pt2d(rnorm(5), rnorm(5), 0.5, 5) # Value: # returns a numeric vector of probabilities of the same length # as the input vectors # FUNCTION: # Normal Limit: if (nu == Inf) return(pnorm2d(x = x, y = y, rho = rho)) # Settings: sigma = diag(2) sigma[1, 2] = sigma[2, 1] = rho X = cbind(x, y) # Probaility: ans = pmvst(X, dim = 2, mu = c(0, 0), Omega = sigma, alpha = c(0, 0), df = nu) attr(ans, "control") = c(rho = rho, nu = nu) # Return Value: ans } # ------------------------------------------------------------------------------ dt2d = function(x, y = x, rho = 0, nu = 4) { # A function implemented by Diethelm Wuertz # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # Description: # Computes bivariate Student-t density function # Example: # dt2d(rnorm(5), rnorm(5), 0.5, 5) # Note: # Partly copied from contributed R package 'sn' # FUNCTION: # Normal Limit: if (nu == Inf) return(dnorm2d(x = x, y = y, rho = rho)) # Argument: xoy = (x^2 - 2*rho*x*y + y^2)/ (2*(1 - rho^2)) # Density: density = (1 + 2*xoy/nu)^(-(nu+2)/2) / (2*pi*sqrt(1-rho^2)) attr(density, "control") = c(rho = rho, nu = nu) # Return value: density } # ------------------------------------------------------------------------------ rt2d = function(n, rho = 0, nu = 4) { # A function implemented by Diethelm Wuertz # Description: # Generates bivariate Student-t random deviates # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # Note: # Partly copied from contributed R package 'mvtnorm' # Author Friedrich Leisch # FUNCTION: # Normal Limit: if (nu == Inf) return(rnorm2d(n = n, rho = rho)) # Random Deviates: ans = rnorm2d(n, rho)/sqrt(rchisq(n, nu)/nu) attr(ans, "control") = c(rho = rho, nu = nu) # Return Value: ans } ################################################################################ fCopulae/R/bv-dnorm.R0000644000176000001440000002170412110722425014110 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: BIVARIATE NORMAL DISTRIBUTION: # pnorm2d Computes bivariate Normal probability function # dnorm2d Computes bivariate Normal density function # rnorm2d Generates bivariate normal random deviates ################################################################################ pnorm2d = function(x, y = x, rho = 0) { # pnorm2d: A copy from R package "sn" # Description: # Computes bivariate Normal probability function # Arguments: # x, y - two numeric values or vectors of the same length at # which the probability will be computed. # Value: # returns a numeric vector of probabilities of the same length # as the input vectors # FUNCTION: # Probaility: X = cbind(x, y) ans = apply(X, 1, .pnorm2d, rho = rho) attr(ans, "control") = c(rho = rho) # Return Value: ans } # ------------------------------------------------------------------------------ .pnorm2d = function(X, rho = 0) { # pnorm2d: A copy from R package "sn" # Description: # Bivariate Normal probability function # Arguments: # x, y - two numeric values at which the probability will # be computed. # Value: # returns a numeric vector of probabilities of the same length # as the input vectors # FUNCTION: # Probability: x = X[1] y = X[2] if (x == 0 & y == 0) { return(0.25 + asin(rho)/(2 * pi)) } p = 0.5 * (pnorm(x) + pnorm(y)) if (x == 0) { p = p - 0.25 * sign(y) } else { if (is.finite(x)) { Y = (y - rho * x)/(x * sqrt(1 - rho^2)) } else { Y = -rho/sqrt(1-rho^2) } p = p - .TOwen(x, Y) } if (y == 0) { p = p - 0.25 * sign(x) } else { if (is.finite(y)) { X = (x - rho * y)/(y * sqrt(1 - rho^2)) } else { X = -rho/sqrt(1-rho^2) } p = p - .TOwen(y, X) } if (is.finite(x) & is.finite(y)) { if ((x * y < 0) | ((x * y == 0) & (x + y) < 0)) { p = p - 0.5 } } # Return Value: return(p) } # ------------------------------------------------------------------------------ .TInt = function(h, a, jmax, cut.point) { # T.int: A copy from R package "sn" # Note: # Required by .pnorm2d and .TOwen # FUNCTION: .fui = function(h, i) (h^(2 * i))/((2^i) * gamma(i + 1)) seriesL = seriesH = NULL i = 0:jmax low = (h <= cut.point) hL = h[low] hH = h[!low] L = length(hL) if (L > 0) { b = outer(hL, i, .fui) cumb = apply(b, 1, cumsum) b1 = exp(-0.5 * hL^2) * t(cumb) matr = matrix(1, jmax + 1, L) - t(b1) jk = rep(c(1, -1), jmax)[1:(jmax + 1)]/(2 * i + 1) matr = t(matr * jk) %*% a^(2 * i + 1) seriesL = (atan(a) - as.vector(matr))/(2 * pi) } if (length(hH) > 0) { seriesH = atan(a) * exp(-0.5 * (hH^2) * a/atan(a)) * (1 + 0.00868 * (hH^4) * a^4)/(2 * pi) } series = c(seriesL, seriesH) id = c((1:length(h))[low], (1:length(h))[!low]) series[id] = series # Return Value: series } # ------------------------------------------------------------------------------ .TOwen = function (h, a, jmax = 50, cut.point = 6) { # T.Owen: A copy from R package "sn" # Note: # Required by .pnorm2d # FUNCTION: if (!is.vector(a) | length(a) > 1) stop("a must be a vector of length 1") if (!is.vector(h)) stop("h must be a vector") aa = abs(a) ah = abs(h) if (aa == Inf) return(0.5 * pnorm(-ah)) if (aa == 0) return(rep(0, length(h))) na = is.na(h) inf = (ah == Inf) ah = replace(ah, (na | inf), 0) if (aa <= 1) { owen = .TInt(ah, aa, jmax, cut.point) } else { owen = 0.5 * pnorm(ah) + pnorm(aa * ah) * (0.5 - pnorm(ah)) - .TInt(aa * ah, (1/aa), jmax, cut.point) } owen = replace(owen, na, NA) owen = replace(owen, inf, 0) ans = return(owen * sign(a)) # Return Value: ans } # ------------------------------------------------------------------------------ dnorm2d = function(x, y = x, rho = 0) { # A function implemented by Diethelm Wuertz # Arguments: # x,y - two numeric vectors # rho - the linear correlation, a numeric value between # minus one and one. # FUNCTION: # Argument: xoy = (x^2 - 2*rho*x*y + y^2)/ (2*(1 - rho^2)) # Density: density = exp(-xoy) / ( 2*pi*sqrt(1-rho^2)) attr(density, "control") = c(rho = rho) # Return Value: density } # ------------------------------------------------------------------------------ .dnorm2d = function(x, y = x, rho = 0) { # A function implemented by Diethelm Wuertz # Arguments: # x,y - two numeric vectors # rho - the linear correlation, a numeric value between # minus one and one. # Note: # Partly copied from contributed R package 'mvtnorm' # Author Friedrich Leisch # FUNCTION # Settings: mean = c(0,0) sigma = diag(2) sigma[1,2] = sigma[2,1] = rho log = FALSE x = cbind(x, y) # From mvtnorm - Check: if (is.vector(x)) { x = matrix(x, ncol = length(x)) } if (missing(mean)) { mean = rep(0, length = ncol(x)) } if (missing(sigma)) { sigma = diag(ncol(x)) } if (ncol(x) != ncol(sigma)) { stop("x and sigma have non-conforming size") } if (nrow(sigma) != ncol(sigma)) { stop("sigma meanst be a square matrix") } if (length(mean) != nrow(sigma)) { stop("mean and sigma have non-conforming size") } # From mvtnorm - Density: distval = mahalanobis(x, center = mean, cov = sigma) logdet = sum(log(eigen(sigma, symmetric = TRUE, only.values = TRUE)$values)) logretval = -(ncol(x)*log(2*pi) + logdet + distval)/2 if(log) return(logretval) ans = exp(logretval) attr(ans, "control") = c(rho = rho) # Return value: ans } # ------------------------------------------------------------------------------ rnorm2d = function(n, rho = 0) { # A function implemented by Diethelm Wuertz # Description: # Generates bivariate normal random deviates # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # Note: # Partly copied from contributed R package 'mvtnorm' # Author Friedrich Leisch # FUNCTION # Settings: mean = c(0,0) sigma = diag(2) sigma[1,2] = sigma[2,1] = rho # From mvtnorm - Random Numbers: ev = eigen(sigma, symmetric = TRUE)$values if (!all(ev >= -sqrt(.Machine$double.eps) * abs(ev[1]))) warning("sigma is numerically not positive definite") sigsvd = svd(sigma) ans = t(sigsvd$v %*% (t(sigsvd$u) * sqrt(sigsvd$d))) ans = matrix(rnorm(n * ncol(sigma)), nrow = n) %*% ans ans = sweep(ans, 2, mean, "+") attr(ans, "control") = c(rho = rho) # Return Value: ans } # ------------------------------------------------------------------------------ .rnorm2d = function(n, rho = 0) { # A function implemented by Diethelm Wuertz # Description: # Alternative direct algorithm from Lindskog Master Thesis # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # FUNCTION: # Random Deviates x = matrix(c(1, rho, rho,1), 2) V = NULL U = chol(x) siz = dim(x)[1] for(i in 1:n) { Z = rnorm(siz) res = t(U)%*%Z V = cbind(V,res) } rmn = t(V) # Return Value: rmn } ################################################################################ fCopulae/R/bv-delliptical.R0000644000176000001440000002326111370220745015264 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL BIVARIATE DISTRIBUTIONS: # delliptical2d Computes density for elliptical distributions # .gfunc2d Generator Function for elliptical distributions # .delliptical2dSlider Slider for bivariate densities ################################################################################ delliptical2d = function(x, y = x, rho = 0, param = NULL, type = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower"), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Density function for bivariate elliptical distributions # Arguments: # x, y - two numeric vectors of the same length. # rho - a anumeric value specifying the correlation. # param - NULL, a numeric value, or a numeric vector adding # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # FUNCTION: # Type: type = type[1] # Settings: if (is.list(x)) { y = x$y x = x$x } if (is.matrix(x)) { y = x[, 2] x = x[, 2] } # Add Default Parameters: if (is.null(param)) { if (type == "t") param = c(nu = 4) if (type == "kotz") param = c(r = sqrt(2)) if (type == "epower") param = c(r = sqrt(2), s = 1/2) } # Density: xoy = ( x^2 - 2*rho*x*y + y^2 ) / (1-rho^2) lambda = .gfunc2d(param = param, type = type)[[1]] density = lambda * .gfunc2d(x = xoy, param = param, type = type) / sqrt(1 - rho^2) # Add attributes: if (is.null(param)) { attr(density, "control") = unlist(list(type = type, rho = rho)) } else { attr(density, "control") = unlist(list(type = type, rho = rho, param = param)) } # As List ? if (output[1] == "list") { N = sqrt(length(x)) x = x[1:N] y = matrix(y, ncol = N)[1, ] density = list(x = x, y = y, z = matrix(density, ncol = N)) } # Return Value: density } # ------------------------------------------------------------------------------ .gfunc2d = function(x, param = NULL, type = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower")) { # A function implemented by Diethelm Wuertz # Description: # Generator function for elliptical distributions # Note: # A copy from fExtremes 'gfunc' # Arguments: # x - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Value: # Returns a numeric vector "g(x)" for the generator computed at # the x values taken from the input vector. If x is missing, # the normalizing constant "lambda" will be returned. # FUNCTION: # Handle Missing x: if (missing(x)) { x = NA output = "lambda" } else { output = "g" } # Get Type: type = type[1] # Get Parameters: # if (is.null(param)) param = .ellipticalParam$param # Create Generator: if (type == "norm") { g = exp(-x/2) lambda = 1 / (2*pi) param = NULL } if (type == "cauchy") { g = ( 1 + x )^ (-3/2 ) lambda = 1 / (2*pi) param = NULL } if (type == "t") { if (is.null(param)) { nu = 4 } else { nu = param[[1]] } g = ( 1 + x/nu )^ ( -(nu+2)/2 ) lambda = 1/(2*pi) param = c(nu = nu) } if (type == "logistic"){ g = exp(-x/2)/(1+exp(-x/2))^2 # lambda: # integrate(function(x) { exp(-x)/(1+exp(-x))^2}, 0, Inf, # subdivision = 10000, rel.tol = .Machine$double.eps^0.8) # 0.5 with absolute error < 2.0e-13 lambda = 1 / pi param = NULL } if (type == "laplace") { # or "double exponential" # epower: r = sqrt(2) s = 1/2 g = exp(-r*(x/2)^s) lambda = s * r^(1/s) / ( 2 * pi * gamma(1/s) ) param = NULL } if (type == "kotz") { # epower: s = 1 if (is.null(param)) { r = sqrt(2) } else { r = param } g = exp(-r*(x/2)) lambda = r/(2*pi) param = c(r = r) } if (type == "epower") { if (is.null(param)) { r = sqrt(2) s = 1/2 } else { r = param[[1]] s = param[[2]] } g = exp(-r*(x/2)^s) lambda = s * r^(1/s) / ( 2 * pi * gamma(1/s) ) param = c(r = r, s = s) } # Output: output = output[1] if (output == "g") { ans = g } else if (output == "lambda") { ans = lambda } # Add Control: if (output == "g") { attr(ans, "control") = c(type = type, lambda = as.character(lambda)) } else if (output == "lambda") { if (is.null(param)) { attr(ans, "control") = unlist(list(type = type)) } else { attr(ans, "control") = unlist(list(type = type, param = param)) } } # Return Value: ans } # ------------------------------------------------------------------------------ .delliptical2dSlider = function(B = 10, eps = 1.e-3) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1), cex = 0.7) # Internal Function: refresh.code = function(...) { # Sliders: Distribution = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) r = .sliderMenu(no = 5) s = .sliderMenu(no = 6) nlev = .sliderMenu(no = 7) ncol = .sliderMenu(no = 8) if (rho == +1) rho = rho - eps if (rho == -1) rho = rho + eps # Title: Names = c("- Normal", "- Cauchy", "- Student t", "- Logistic", "- Laplace", "- Kotz", "- Exponential Power") Title = paste("Elliptical Density No:", as.character(Distribution), Names[Distribution], "\nrho = ", as.character(rho)) if (Distribution == 3) Title = paste(Title, "nu =", as.character(nu)) if (Distribution >= 6) Title = paste(Title, "r =", as.character(r)) if (Distribution >= 7) Title = paste(Title, "s =", as.character(s)) # Plot: xy= grid2d(x = seq(-5, 5, length = N)) Type = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") param = NULL if (Distribution == 3) param = nu if (Distribution == 6) param = r if (Distribution == 7) param = c(r, s) D = delliptical2d(x = xy, rho = rho, param = param, type = Type[Distribution], output = "list") image(D, col = heat.colors(ncol), xlab = "x", ylab = "y" ) contour(D, nlevels = nlev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1), cex = 0.7) } # Open Slider Menu: plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Distribution", "N", "rho", "t: nu", "r", "s", plot.names), minima = c( 1, 10, -1, 1, 0, 0, 10, 12), maxima = c( 7, 100, +1, B, B, B, 100, 256), resolutions = c( 1, 10, 0.1, 0.1, 0.1, 0.1, 10, 1), starts = c( 1, 10, 0, 4, 1, 1, 10, 12)) } ################################################################################ fCopulae/R/bv-dcauchy.R0000644000176000001440000000705411370220745014420 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: BIVARIATE CAUCHY DISTRIBUTION: # pcauchy2d Computes bivariate Cauchy probability function # dcauchy2d Computes bivariate Cauchy density function # rcauchy2d Generates bivariate Cauchy random deviates ################################################################################ pcauchy2d = function(x, y = x, rho = 0) { # A function Implemented by Diethelm Wuertz # Description: # Computes bivariate Cauchy probability function # Arguments: # x, y - two numeric values or vectors of the same length at # which the probability will be computed. # Example: # pt2d(rnorm(5), rnorm(5), 0.5, 5) # Value: # returns a numeric vector of probabilities of the same length # as the input vectors # FUNCTION: # Settings: # Probaility: ans = pt2d(x = x, y = y, rho = rho, nu = 1) attr(ans, "control") = c(rho = rho) # Return Value: ans } # ------------------------------------------------------------------------------ dcauchy2d = function(x, y = x, rho = 0) { # A function implemented by Diethelm Wuertz # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # Description: # Computes bivariate Cauchy density function # Note: # Partly copied from contributed R package 'sn' # FUNCTION: # Density: density = dt2d(x = x, y = y, rho = rho, nu = 1) attr(density, "control") = c(rho = rho) # Return value: density } # ------------------------------------------------------------------------------ rcauchy2d = function(n, rho = 0) { # A function implemented by Diethelm Wuertz # Description: # Generates bivariate Cauchy random deviates # Arguments: # n - number of random deviates to be generated # rho - the linear correlation, a numeric value between # minus one and one. # Note: # Partly copied from contributed R package 'mvtnorm' # Author Friedrich Leisch # FUNCTION: # Random Deviates: ans = rt2d(n = n, rho = rho) attr(ans, "control") = c(rho = rho) # Return Value: ans } ################################################################################ fCopulae/R/builtin-adapt.R0000644000176000001440000001335711370220745015133 0ustar ripleyusers # Title: adapt -- multidimensional numerical integration # Package: adapt # Version: 1.0-4 # Author: FORTRAN by Alan Genz, # S by Mike Meyer, R by Thomas Lumley and Martin Maechler # Description: Adaptive Quadrature in up to 20 dimensions # Depends: # License: Unclear (Fortran) -- code in Statlib's ./S/adapt # Maintainer: Thomas Lumley # Packaged: Fri Apr 20 11:38:07 2007; thomas # [from Statlib's original http://lib.stat.cmu.edu/S/adapt ] # This code contains an S function and supporting C and Fortran code for # adaptive quadrature. The underlyling fortran code is purported to # work in from 2 to 20 dimensions. The code is set up to dynamically # load from a central library area. If you can not do dynamic loading, # you may need to build a staticly loaded version. The adapt S function # calls load.if.needed to do the dynamic loading. You will have to # change the functions used here (probably to call library.dynam). # S code written by Michael Meyer (mikem@andrew.cmu.edu). # October, 1989. # 2002-03-14 Martin Maechler # * DESCRIPTION (Version): 1.0-3 --> CRAN # * R/adapt.R (adapt): use defaults for minpts, maxpts, eps; # more logical maxpts default (for ndim >= 7) using rulcls # * man/adapt.Rd: extended example # 2002-03-13 Martin Maechler # * DESCRIPTION (Version): 1.0-2 # * man/adapt.Rd: indentation, using \code{.}, etc; # example also tries p=5 dimensions # * R/adapt.R: clean up (spaces) # 2002-01-09 Martin Maechler # * R/adapt.R: do not use .Alias anymore # 2001-06-29 Thomas Lumley # * move (improved!) integrate() into base, using .Call() etc. # Message-ID: <4AD7A74B.3020108@math.wsu.edu> # Date: Thu, 15 Oct 2009 15:50:51 -0700 # From: Alan Genz # User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.21) # Gecko/20090402 SeaMonkey/1.1.16 # MIME-Version: 1.0 # To: Diethelm Wuertz # CC: Alan C Genz # Subject: Re: adapt # References: <4AD3032B.4090801@itp.phys.ethz.ch> # In-Reply-To: <4AD3032B.4090801@itp.phys.ethz.ch> # Content-Type: text/plain; charset=ISO-8859-1; format=flowed # Content-Transfer-Encoding: 7bit # Status: O # Dear Prof. Wuertz, # Thank you for your message and your interest in my adaptive integration # Fortran code. I would be pleased if you included my code in your open # source R fCopulae package under the Gnu GPL2 license. You have my # permission to do this. # Sincerely, # Alan Genz ################################################################################ adapt <- function (ndim, lower, upper, minpts = 100, maxpts = NULL, functn, eps = 0.01, ...) { keep.trying <- is.null(maxpts) if (ndim == 1) { ## fudge for 1-d functions warning("Using integrate() from base package for 1-d integration") if (keep.trying) maxpts <- minpts return(integrate(functn,lower,upper,subdivisions=maxpts,rel.tol=eps,...)) } ## else ndim >= 2 : ## Check to make sure that upper and lower are reasonable lengths ## Both the upper and lower limits should be at least of length ndim if (length(lower) < ndim || length(upper) < ndim)#MM: dropped 'at least': stop(paste("The lower and upper vectors need to have ndim elements\n", "Your parameters are: ndim", ndim, ", length(lower)", length(lower), ", length(upper)", length(upper), "\n")) ff <- if(length(list(...)) && length(formals(functn)) > 1) function(x) functn(x, ...) else functn # .Alias rulcls <- 2^ndim + 2*ndim^2 + 6*ndim + 1 #-> ../src/adapt.f ## maxpts should be large enough. Prefer 10*rulclc, but use 2*rulclc. if (keep.trying) maxpts <- max(minpts, 500, 2 * rulcls) else { if (minpts >= maxpts) { warning(paste("maxpts must be > minpts.\n", "Maxpts has be increased to minpts + 1")) maxpts <- minpts + 1 } ## if (maxpts < 2 * rulcls) { warning(paste( "You have maxpts (= ", maxpts, ") too small\n", "It needs to be at least 2 times 2^ndim + 2*ndim^2 + 6*ndim+1\n", "It has been reset to ", 2 * rulcls, "\n", sep="")) maxpts <- 2 * rulcls } } repeat { lenwrk <- (2*ndim + 3)* (1 + maxpts/rulcls)/2# mandated in adapt source x <- .C("cadapt", as.integer(ndim), as.double(lower), as.double(upper), minpts = as.integer(minpts), maxpts = as.integer(maxpts), ## now pass ff and current environment ff, rho = environment(), as.double(eps), relerr = double(1), lenwrk = as.integer(lenwrk), value = double(1), # will contain the value of the integral ifail = integer(1), PACKAGE = "fCopulae")[ c("value", "relerr", "minpts", "lenwrk", "ifail")] if (x$ifail == 1 && keep.trying) maxpts <- maxpts*2 else break } if(x$ifail) warning(x$warn <- c("Ifail=1, maxpts was too small. Check the returned relerr!", paste("Ifail=2, lenwrk was too small. -- fix adapt() !\n", "Check the returned relerr!"), "Ifail=3: ndim > 20 -- rewrite the fortran code ;-) !", "Ifail=4, minpts > maxpts; should not happen!", "Ifail=5, internal non-convergence; should not happen!" )[x$ifail]) class(x) <- "integration" x } # ------------------------------------------------------------------------------ print.integration <- function(x, ...) { print(noquote(sapply(x, format, ...)),...) invisible(x) } ################################################################################ fCopulae/R/biv-gridding.R0000644000176000001440000000774311370220745014745 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received A copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file # fEcofin::4A-BivariateGridding.R ################################################################################ # FUNCTION: GRID DATA: # gridData Generates grid data set # persp.gridData Generates perspective plot from a grid data object # contour.gridData Generates contour plot from a grid data object ################################################################################ ################################################################################ # FUNCTION: GRID DATA: # gridData Generates grid data set # persp.gridData Generates perspective plot from a grid data object # contour.gridData Generates contour plot from a grid data object gridData = function(x = (-10:10)/10, y = x, z = outer(x, y, function(x, y) (x^2+y^2)) ) { # A function implemented by Diethelm Wuertz # Description: # Generates a grid data set # Arguments: # x, y - two numeric vectors of grid pounts # z - a numeric matrix or any other rectangular object which can # be transformed by the function 'as.matrix' into a matrix # object. # Example: # persp(as.gridData()) # FUNCTION: # Grid Data: data = list(x = x, y = y, z = as.matrix(z)) class(data) = "gridData" # Return Value: data } # ------------------------------------------------------------------------------ persp.gridData = function(x, theta = -40, phi = 30, col = "steelblue", ticktype = "detailed", ...) { # A function implemented by Diethelm Wuertz # Description: # S3 method to generate a perspective plot from a grid data object # Example: # x = y = seq(-10, 10, length = 30) # z = outer(x, y, function(x, y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r }) # data = list(x = x, y = y, z = z) # class(data) = "gridData" # persp(data) # FUNCTION: # Grid Data: class(x) = "default" persp(x, theta = theta, phi = phi, col = col, ticktype = ticktype, ...) # Return Value: invisible(NULL) } # ------------------------------------------------------------------------------ contour.gridData = function(x, addImage = TRUE, ...) { # A function implemented by Diethelm Wuertz # Description: # S3 method to generate a contour plot from a grid data object # Example: # x = y = seq(-10, 10, length = 30) # z = outer(x, y, function(x, y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r }) # data = list(x = x, y = y, z = z) # class(data) = "gridData" # contour(data) # FUNCTION: # Grid Data: class(x) = "default" if (addImage) image(x, ...) contour(x, add = addImage, ...) box() # Return Value: invisible(NULL) } ################################################################################ fCopulae/R/biv-density.R0000644000176000001440000001747711370220745014642 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # grid2d Returns from two vectors x-y grid coordinates # density2d Returns 2D Kernel Density Estimates # hist2d Returns 2D Histogram Counts # integrate2d Integrates over a two dimensional unit square ################################################################################ grid2d = function(x = (0:10)/10, y = x) { # A function implemented by Diethelm Wuertz # Description: # Creates from two vectors x-y grid coordinates # Arguments: # x, y - two numeric vectors defining the x and y coordinates. # Value: # returns a list with two vectors named $x and $y spanning the # grid defined by the coordinates x and y. # Example: # > grid2d(1:3, 1:2) # $x # [1] 1 2 3 1 2 3 # $y # [1] 1 1 1 2 2 2 # FUNCTION: # Prepare for Input: nx = length(x) ny = length(y) xoy = cbind(rep(x, ny), as.vector(matrix(y, nx, ny, byrow = TRUE))) XY = matrix(xoy, nx * ny, 2, byrow = FALSE) # Return Value: list(x = XY[, 1], y = XY[, 2]) } # ------------------------------------------------------------------------------ density2d = function (x, y = NULL, n = 20, h = NULL, limits = c(range(x), range(y))) { # A function implemented by Diethelm Wuertz # Description: # Returns 2D Kernel Density Estimates # Arguments: # x, y - two vectors of coordinates of data. If y is NULL then x # is assumed to be a two column matrix, where the first column # contains the x data, and the second column the y data. # n - Number of grid points in each direction. # h - a vector of bandwidths for x and y directions. Defaults to # normal reference bandwidth. # limits - the limits of the rectangle covered by the grid. # Value: # A list with three elements x, y, and z. x and y are vectors # spanning the two dimensioanl grid and z the corresponding # matrix. The output can directly serve as input to the # plotting functions image, contour and persp. # Details: # Two-dimensional kernel density estimation with an axis-aligned # bivariate normal kernel, evaluated on a square grid. # Note: # Partly copied from R Package MASS, function 'kde2d'. # Reference: # Venables, W.N., Ripley, B. D. (2002); # Modern Applied Statistics with S. # Fourth edition, Springer. # FUNCTION: # Settings: lims = limits if (is.null(y)) { y = x[, 2] x = x[, 1] } # Bandwidth: .bandwidth.nrd = function (x) { r = quantile(x, c(0.25, 0.75)) h = (r[2] - r[1])/1.34 4 * 1.06 * min(sqrt(var(x)), h) * length(x)^(-1/5) } # Kernel Density Estimator: nx = length(x) if (length(y) != nx) stop("Data vectors must be the same length") gx = seq(lims[1], lims[2], length = n) gy = seq(lims[3], lims[4], length = n) if (is.null(h)) h = c(.bandwidth.nrd(x), .bandwidth.nrd(y)) h = h/4 ax = outer(gx, x, "-")/h[1] ay = outer(gy, y, "-")/h[2] z = matrix(dnorm(ax), n, nx) %*% t(matrix(dnorm(ay), n, nx))/(nx * h[1] * h[2]) # Return Value: list(x = gx, y = gy, z = z) } # ------------------------------------------------------------------------------ hist2d = function(x, y = NULL, n = c(20, 20)) { # A function implemented by Diethelm Wuertz # Description: # Returns 2D Histogram Counts # Arguments: # x, y - two vectors of coordinates of data. If y is NULL then x # is assumed to be a two column matrix, where the first column # contains the x data, and the second column the y data. # n - number of bins in each dimension, may be a scalar or a 2 # element vector. The default value is 20. # Value: # A list with three elements x, y, and z. x and y are vectors # spanning the two dimensioanl grid and z the corresponding # matrix. The output can directly serve as input to the # plotting functions image, contour and persp. # Note: # Partly copied from R Package gregmisc, function 'hist2d'. # FUNCTION: # 2D Histogram Counts: if (is.null(y)) { y = x[, 2] x = x[, 1] } if (length(n) == 1) { nbins = c(n, n) } else { nbins = n } nas = is.na(x) | is.na(y) x.cuts = seq(from = min(x, y), to = max(x,y), length = nbins[1]+1) y.cuts = seq(from = min(x, y), to = max(x,y), length = nbins[2]+1) index.x = cut(x, x.cuts, include.lowest = TRUE) index.y = cut(y, y.cuts, include.lowest = TRUE) m = matrix(0, nrow=nbins[1], ncol = nbins[2], dimnames = list( levels(index.x), levels(index.y) ) ) for ( i in 1:length(index.x) ) { m[index.x[i], index.y[i] ] = m[index.x[i], index.y[i] ] + 1 } xvals = x.cuts[1:nbins[1]] yvals = y.cuts[1:nbins[2]] # Return Value: list(x = xvals, y = yvals, z = m) } # ------------------------------------------------------------------------------ integrate2d = function(fun, error = 1.0e-5, ...) { # A function implemented by Diethelm Wuertz # Description: # 2-dimension quadrature rule on [0,1]^2 # Arguments: # fun - function to be integrated. The first argument requests # the x values, the second the y values, and the remaining # are reserved for additional parameters. # ... - parameters passed to the function to be integrated # Details: # see: Abramowitz and Stegun, p. 892 # FUNCTION: # Estimate a reasonable number of subintervals: H = sqrt(sqrt(error)) n = ceiling(1/H + 1) blocks = ceiling(log(n+1)/log(2)) n = 2^blocks-1 h = 1/(n-1) # The error will be of order h^4: error = h^4 # Create all grid coordinates: x = y = h*seq(1, n-1, by = 2) nx = ny = length(x) xoy = cbind(rep(x, ny), as.vector(matrix(y, nx, ny, byrow = TRUE))) XY = matrix(xoy, nx * ny, 2, byrow = FALSE) # The integration rule: rule = function(x, h, ...) { X = x[1] + h*c( 0, -1, -1, 1, 1, -1, 1, 0, 0) Y = x[2] + h*c( 0, -1, 1, -1, 1, 0, 0, -1, 1) W = c( 16, 1, 1, 1, 1, 4, 4, 4, 4)/36 ans = sum( W * fun(X, Y, ...) ) } # Result: ans = (4*h^2)*sum(apply(XY, 1, rule, h = h, ...)) # Return Value: list(value = ans, error = error, points = n) } ################################################################################ fCopulae/R/biv-binning.R0000644000176000001440000002443311370220745014575 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received A copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # squareBinning Square binning of irregularly spaced points # plot S3 Method for plotting square binned points # FUNCTION: DESCRIPTION: # hexBinning Hexagonal binning of irregularly spaced points # plot S3 Method for plotting hexagonal binned points ################################################################################ ################################################################################ # FUNCTION: DESCRIPTION: # squareBinning Square binning of irregularly spaced points # plot S3 Method for plotting square binned points squareBinning = function(x, y = NULL, bins = 30) { # A function implemented by Diethelm Wuertz # Description: # Returns 2D Histogram Counts # Arguments: # x, y - two vectors of coordinates of data. If y is NULL then x # is assumed to be a two column matrix, where the first column # contains the x data, and the second column the y data. # 'timeSeries' objects are also allowed as input. # bins - number of bins in each dimension, may be a scalar or a 2 # element vector. The default value is 20. # Value: # A list with three elements x, y, and z. x and y are vectors # spanning the two dimensioanl grid and z the corresponding # matrix. The output can directly serve as input to the # plotting functions image, contour and persp. # Example: # sB = squareBinning(x = rnorm(1000), y = rnorm(1000)); plot(sB) # Note: # Partly copied from R Package gregmisc, function 'hist2d'. # FUNCTION: # 2D Histogram Counts: if (is.null(y)) { x = as.matrix(x) y = x[, 2] x = x[, 1] } else { x = as.vector(x) y = as.vector(y) } data = cbind(x, y) # Bins: n = bins if (length(n) == 1) { nbins = c(n, n) } else { nbins = n } # Binning: xo = seq(min(x), max(x), length = nbins[1]) yo = seq(min(y), max(y), length = nbins[2]) xvals = xo[-1] - diff(xo)/2 yvals = yo[-1] - diff(yo)/2 ix = findInterval(x, xo) iy = findInterval(y, yo) xcm = ycm = zvals = matrix(0, nrow = nbins[1], ncol = nbins[2]) for (i in 1:length(x)) { zvals[ix[i], iy[i]] = zvals[ix[i], iy[i]] + 1 xcm[ix[i], iy[i]] = xcm[ix[i], iy[i]] + x[i] ycm[ix[i], iy[i]] = ycm[ix[i], iy[i]] + y[i] } # Reduce to non-empty cells: u = v = w = ucm = vcm = rep(0, times = nbins[1]*nbins[2]) L = 0 for (i in 1:(nbins[1]-1)) { for (j in 1:(nbins[2]-1)) { if (zvals[i, j] > 0) { L = L + 1 u[L] = xvals[i] v[L] = yvals[j] w[L] = zvals[i, j] ucm[L] = xcm[i, j]/w[L] vcm[L] = ycm[i, j]/w[L] } } } length(u) = length(v) = length(w) = L length(ucm) = length(vcm) = L ans = list(x = u, y = v, z = w, xcm = ucm, ycm = vcm, bins = bins, data = data) class(ans) = "squareBinning" # Return Value: ans } # ------------------------------------------------------------------------------ plot.squareBinning = function(x, col = heat.colors(12), addPoints = TRUE, addRug = TRUE, ...) { # A function implemented by Diethelm Wuertz # Description: # Plot square binned data points # FUNCTION: # Binning: X = x$x Y = x$y # Plot Center Points: plot(X, Y, type = "n", ...) # Create Hexagon Coordinates: rx = min(diff(unique(sort(X))))/2 ry = min(diff(unique(sort(Y))))/2 u = c(-rx, rx, rx, -rx) v = c( ry, ry, -ry, -ry) # Create Color Palette: N = length(col) Z = x$z zMin = min(Z) zMax = max(Z) Z = (Z - zMin)/(zMax - zMin) Z = trunc(Z*(N-1)+1) # Add Colored Hexagon Polygons: for (i in 1:length(X)) { polygon(u+X[i], v+Y[i], col = col[Z[i]], border = "white") } # Add Center of Mass Points: if (addPoints) { points(x$xcm, x$ycm, pch = 19, cex = 1/3, col = "black") } # Add rug: if (addRug) { rug(x$data[, 1], ticksize = 0.01, side = 3) rug(x$data[, 2], ticksize = 0.01, side = 4) } # Return Value: invisible(NULL) } ################################################################################ # FUNCTION: DESCRIPTION: # hexBinning Hexagonal binning of irregularly spaced points # plot S3 Method for plotting hexagonal binned points hexBinning = function(x, y = NULL, bins = 30) { # A function implemented by Diethelm Wuertz # Description: # Does a hexagonal binning of data points # Arguments: # x, y - two vectors of coordinates of data. If y is NULL then x # is assumed to be a two column matrix, where the first column # contains the x data, and the second column the y data. # 'timeSeries' objects are also allowed as input. # bins - number of bins in each dimension, may be a scalar or a 2 # element vector. The default value is 20. # Example: # hB = hexBinning(x = rnorm(10000), y = rnorm(10000)); plot(hB) # FUNCTION: # Extract Series: if (is.null(y)) { x = as.matrix(x) y = x[, 2] x = x[, 1] } else { x = as.vector(x) y = as.vector(y) } data = cbind(x, y) # Set Parameters: shape = 1 n = length(x) xbnds = range(x) ybnds = range(y) jmax = floor(bins + 1.5001) c1 = 2 * floor((bins *shape)/sqrt(3) + 1.5001) imax = trunc((jmax*c1 -1)/jmax + 1) lmax = jmax * imax cell = cnt = xcm = ycm = rep(0, times = max(n, lmax)) xmin = xbnds[1] ymin = ybnds[1] xr = xbnds[2] - xmin yr = ybnds[2] - ymin c1 = bins/xr c2 = bins*shape/(yr*sqrt(3.0)) jinc = jmax lat = jinc + 1 iinc = 2*jinc con1 = 0.25 con2 = 1.0/3.0 # Count Bins: for ( i in 1:n ) { sx = c1 * (x[i] - xmin) sy = c2 * (y[i] - ymin) j1 = floor(sx + 0.5) i1 = floor(sy + 0.5) dist1 = (sx-j1)^2 + 3.0*(sy-i1)^2 if( dist1 < con1) { L = i1*iinc + j1 + 1 } else if (dist1 > con2) { L = floor(sy)*iinc + floor(sx) + lat } else { j2 = floor(sx) i2 = floor(sy) test = (sx-j2 -0.5)^2 + 3.0*(sy-i2-0.5)^2 if ( dist1 <= test ) { L = i1*iinc + j1 + 1 } else { L = i2*iinc + j2 + lat } } cnt[L] = cnt[L]+1 xcm[L] = xcm[L] + (x[i] - xcm[L])/cnt[L] ycm[L] = ycm[L] + (y[i] - ycm[L])/cnt[L] } # Reduce to Non-Empty Cells: nc = 0 for ( L in 1:lmax ) { if(cnt[L] > 0) { nc = nc + 1 cell[nc] = L cnt[nc] = cnt[L] xcm[nc] = xcm[L] ycm[nc] = ycm[L] } } bnd = c(imax, jmax) bnd[1] = (cell[nc]-1)/bnd[2] + 1 length(cell) = nc length(cnt) = nc length(xcm) = nc length(ycm) = nc if(sum(cnt) != n) warning("Lost counts in binning") # Compute Positions: c3 = diff(xbnds)/bins ybnds = ybnds c4 = (diff(ybnds) * sqrt(3))/(2 * shape * bins) cell = cell - 1 i = cell %/% jmax j = cell %% jmax y = c4 * i + ybnds[1] x = c3 * ifelse(i %% 2 == 0, j, j + 0.5) + xbnds[1] # Result: ans = list(x = x, y = y, z = cnt, xcm = xcm, ycm = ycm, bins = bins, data = data) class(ans) = "hexBinning" # Return Value: ans } # ------------------------------------------------------------------------------ plot.hexBinning = function(x, col = heat.colors(12), addPoints = TRUE, addRug = TRUE, ...) { # A function implemented by Diethelm Wuertz # Description: # Plot hexagonal binned data points # Example: # hexPlot(rnorm(1000), rnorm(1000), bins = 20) # FUNCTION: # Binning: X = x$x Y = x$y # Plot Center Points: plot(X, Y, type = "n", ...) # Create Hexagon Coordinates: rx = min(diff(unique(sort(X)))) ry = min(diff(unique(sort(Y)))) rt = 2*ry u = c(rx, 0, -rx, -rx, 0, rx) v = c(ry, rt, ry, -ry, -rt, -ry) / 3 # Create Color Palette: N = length(col) z = x$z zMin = min(z) zMax = max(z) Z = (z - zMin)/(zMax - zMin) Z = trunc(Z*(N-1)+1) # Add Colored Hexagon Polygons: for (i in 1:length(X)) { polygon(u+X[i], v+Y[i], col = col[Z[i]], border = "white") } # Add Center of Mass Points: if (addPoints) { points(x$xcm, x$ycm, pch = 19, cex = 1/3, col = "black") } # Add rug: if (addRug) { rug(x$data[, 1], ticksize = 0.01, side = 3) rug(x$data[, 2], ticksize = 0.01, side = 4) } # Return Value: invisible(NULL) } ################################################################################ fCopulae/R/ExtremeValueModelling.R0000644000176000001440000000710611370220745016632 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULA PARAMETER FITTING: # evCopulaSim Simulates bivariate extreme value copula # evCopulaFit Fits the paramter of an extreme value copula ################################################################################ ################################################################################ # FUNCTION: EXTREME VALUE COPULA PARAMETER FITTING: # evCopulaSim Simulates bivariate extreme value copula # evCopulaFit Fits the paramter of an extreme value copula evCopulaSim = function(n, param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Simulates bivariate extreme value Copula # FUNCTION: # Match Arguments: type = match.arg(type) # Settings: if (is.null(param)) param = evParam(type)$param # Random Variates: ans = revCopula(n = n, param = param, type = type) # Return Value: ans } # ------------------------------------------------------------------------------ evCopulaFit = function(u, v = NULL, type = evList(), ...) { # A function implemented by Diethelm Wuertz # Description: # Fits the paramter of an elliptical copula # Note: # The upper limit for nu is 100 # FUNCTION: # Match Arguments: type = match.arg(type) # Settings: U <<- u V <<- v if (is.list(u)) { U <<- u[[1]] V <<- u[[2]] } if (is.matrix(u)) { U = u[, 1] V = u[, 2] } # Start Values: param = evParam(type)$param range = evRange(type) paramLength = length(param) # Log-Likelihood Function: .fun = function(x, type) { -mean( log(devCopula(u = U, v = V, param = x, type = type)) ) } if (paramLength == 1) { # We have only one parameter to optimize ... fit = optimize(f = .fun, lower = range[1], upper = range[2], maximum = FALSE, tol = .Machine$double.eps^0.25, type = type, ...) } else { # Log-Likelihood Function: range = evRange(type) fit = nlminb(start = param, objective = .fun, lower = range[1], upper = range[2], type = type, ...) } # Return Value: fit } ################################################################################ fCopulae/R/ExtremeValueGenerator.R0000644000176000001440000006127411370220745016654 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # evParam Sets Default parameters for an extreme value copula # evCheck Checks if parameters are in the valid range # evRange Returns the range of valid parameter values # FUNCTION: EXTREME VALUE COPULAE GENERATOR FUNCTION: # Afunc Computes Dependence function # AfuncSlider Displays interactively dependence function # .AfuncFirstDer Computes Derivative of dependence function # .AfuncSecondDer Computes 2nd Derivative of dependence function ################################################################################ ################################################################################ # FUNCTION: EXTREME VALUE COPULAE PARAMETER: # evList Returns list of implemented extreme value copulae # evParam Sets parameters for an extreme value copula # evRange Returns the range of valid parameter values # evCheck Checks if parameters are in the valid range evList = function() { # A function implemented by Diethelm Wuertz # Description: # Returns list of implemented extreme value copulae # Compose List: ans = c("gumbel", "galambos", "husler.reiss", "tawn", "bb5") # Return Value: ans } # ------------------------------------------------------------------------------ evParam = function(type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Sets default parameters for extreme value copulae # Arguments: # type - a character string naming the copula. By default the # "gumbel" copula will be chosen. # Value: # returns a list with two elements, 'param' sets the parameters # which may be a vector, 'range' the range with minimum and # maximum values for each of the parameters. For the "pi" and # "m" copula NULL will be returned. # FUNCTION: # Settings: type = match.arg(type) ans = list(copula = type) # Select: if ( type == "gumbel" ) { ans$param = c(delta = 2) ans$range = c(1, Inf) } if ( type == "galambos" ) { ans$param = c(delta = 2) ans$range = c(0, Inf) } if ( type == "husler.reiss" ) { ans$param = c(delta = 2) ans$range = c(0, Inf) } if ( type == "tawn" ) { ans$param = c(alpha = 2, beta = 1/2, r = 2) ans$range = c(0, 1, 0, 1, 1, Inf) } if ( type == "bb5" ) { ans$param = c(delta = 2, theta = 2) ans$range = c(0, Inf, 0, Inf) } # Some more, yet untested and undocumented: if ( type == "gumbelII" ) { ans$param = c(alpha = 2) ans$range = NULL } if ( type == "marshall.olkin" ) { ans$param = c(alpha1 = 2, alpha2 = 2) ans$range = NULL } if ( type == "pi" ) { ans$param = NULL ans$range = NULL } if ( type == "m" ) { ans$param = NULL ans$range = NULL } # Return Value: ans } # ------------------------------------------------------------------------------ evRange = function(type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Returns the range of valid parameter values # Examples: # evRange("galambos") # evRange("bb5") # FUNCTION: # Type: type = match.arg(type) # Range: ans = evParam(type)$range Names1 = rep(c("lower", "upper"), times = length(ans)/2) Names2 = rep(names(evParam(type)$param), each = 2) names(ans) = paste(Names1, Names2, sep = ".") attr(ans, "control")<-type # Return Value: ans } # ------------------------------------------------------------------------------ evCheck = function(param, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Checks if parameters are in the valid range # FUNCTION: # Type: type = match.arg(type) # Check range = evRange(type) nParam = length(range)/2 j = -1 J = 0 for (i in 1:nParam) { j = j + 2 J = J + 2 if (param[i] < range[j] | param[i] > range[J]) { print(c(param = param[i])) print(c(range = c(range[j], range[J]))) stop("param is out of range") } } # Return Value: invisible(TRUE) } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE GENERATOR FUNCTION: # Afunc Computes Dependence function # AfuncSlider Displays interactively dependence function # .AfuncFirstDer Computes Derivative of dependence function # .AfuncSecondDer Computes 2nd Derivative of dependence function Afunc = function(x, param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes dependence function for extreme value copulae # Arguments: # x - a numeric vector, with values ranging between # zero and one # param - numeric parameter vector, if set to NULL then # default values are taken # type - character string naming the type of copula, # by default "gumbel" # Details: # Extreme Value Copulae can be represented in the form # # C(u,v) = exp { log(uv)*A[log(u)/log(uv)] } # # where A:[0,1] -> [1/2,1] is a convex function # such that max(x,1-x) < A(x) < 1 for all x in [0,1]. # Notes: # Copulae included also in EVANESCE: # gumbel, galambos, husler.reiss, tawn, bb5 # Additionally - not yet tested and documented # gumbelII, marshall.olkin, pi[Cperp], m[Cplus] # References: # Bouye E. (2000), Copulas for Finance: A Reading Guide and # Some Applications, (see the Table on page 49). # Insightful Corp, EVANESCE Implementation in S-PLUS # FinMetrics Module. # FUNCTION: # Missing x: if (missing(x)) x = (0:10)/10 # Type: type = type[1] if (is.null(param)) param = evParam(type)$param names(param) = names(evParam(type)$param) # Compute Dependence Function: if (type == "gumbel") { # 1 <= alpha < Inf alpha = param[1] if (alpha == 1) A = rep(1, times = length(x)) else A = (x^alpha + (1-x)^alpha)^(1/alpha) } if (type == "galambos") { # 0 <= alpha < Inf alpha = param[1] A = 1 - (x^(-alpha) + (1-x)^(-alpha))^(-1/alpha) } if (type == "husler.reiss") { # 0 <= alpha <= Inf alpha = param[1] A = x * pnorm(1/alpha + 0.5*alpha*log(x/(1-x))) + (1-x) * pnorm(1/alpha - 0.5*alpha*log(x/(1-x))) } if (type == "tawn") { # 0 <= alpha <=1 # 0 <= beta <= 1 # 1 <= r < Inf alpha = param[1] beta = param[2] r = param[3] if (alpha == 0 | beta == 0 | r == 1) A = rep(1, times = length(x)) else A = 1 - beta +(beta-alpha)*x + ( (alpha*x)^r + (beta*(1-x))^r )^(1/r) } if (type == "bb5") { # 0 < delta < Inf # 1 <= theta Inf delta = param[1] theta = param[2] if (theta == 1) return(Afunc(x, param, "galambos")) else A = ( x^theta + (1-x)^theta - ( x^(-delta*theta) + (1-x)^(-delta*theta) )^(-1/delta))^(1/theta) } # Some more, yet untested and undocumented: if (type == "gumbelII") { # 0 <= alpha < Inf alpha = param[1] A = alpha*x^2 - alpha*x + 1 } if (type == "marshall.olkin") { alpha1 = param[1] alpha2 = param[2] A = NULL for (i in 1:length(x)) A = c(A, max(1-alpha1*x[i], 1-alpha2*(1-x[i]))) } if (type == "pi" || type == "Cperp") { # No parameters A = rep(1, times = length(x)) } if (type == "m" || type == "Cplus") { # No parameters A = NULL for (i in 1:length(x)) A = c(A, max(x[i], 1-x[i])) } # Result: attr(A, "control") <- unlist(list(param = param, type = type)) # Return Value: A } # ------------------------------------------------------------------------------ AfuncSlider = function() { # A function implemented by Diethelm Wuertz # Description: # Displays interactively the dependence function # Graphic Frame: par(mfrow = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot A: plot(x = (0:N)/N, Afunc(x = (0:N)/N, param = param, type = type), ylim = c(0.5, 1), type = "l", xlab = "x", ylab = "A", main = Title) lines(c(0.0, 1.0), c(1.0, 1.0), col = "steelblue", lty = 3) lines(c(0.0, 0.5), c(1.0, 0.5), col = "steelblue", lty = 3) lines(c(0.5, 1.0), c(0.5, 1.0), col = "steelblue", lty = 3) points(x = c(0, 1), Afunc(x = c(0, 1), param = param, type = type), col = "red") # Plot A': plot(x = (0:N)/N, .AfuncFirstDer(x = (0:N)/N, param = param, type = type), type = "l", xlab = "x", ylab = "A'", main = Title) points(x = c(0, 1), .AfuncFirstDer(x = c(0, 1), param = param, type = type), col = "red") # Plot A'': plot(x = (0:N)/N, .AfuncSecondDer(x = (0:N)/N, param = param, type = type), type = "l", xlab = "x", ylab = "A''", main = Title) points(x = c(0, 1), .AfuncSecondDer(x = c(0, 1), param = param, type = type), col = "red") # Reset Frame: par(mfrow = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("Gumbel: delta", "Galambos: delta", "Husler-Reis: delta", "Tawn: alpha", "... beta", "... r", "BB5: delta", "... theta") .sliderMenu(refresh.code, names = c("Copula", "N", C), #gal hr tawn bb5 minima = c(1, 100, 1.0, 0.00, 0.00, 0.00, 0.00, 1.0, 0.0, 1.0), maxima = c(5, 10000, 10.0, 10.0, 10.0, 1.00, 1.00, 10., 10., 10.), resolutions = c(1, 100, 0.05, 0.05, 0.05, 0.01, 0.01, 0.1, 0.1, 0.1), starts = c(1, 5000, 1.00, 0.00, 0.00, 0.00, 0.00, 1.0, 0.0, 1.0)) } # ------------------------------------------------------------------------------ .AfuncFirstDer = function(x, param = NULL, type = evList(), eps = 1.0e-6 ) { # A function implemented by Diethelm Wuertz # Description: # # Computes derivaive of dependence function # Arguments: # x - a numeric vector, with values ranging between # zero and one # param - numeric parameter vector, if set to NULL then # default values are taken # type - character string naming the type of copula, # by default "gumbel" # Details: # Extreme Value Copulae can be represented in the form # # C(u,v) = exp { log(uv)*A[log(u)/log(uv)] } # # where A:[0,1] -> [1/2,1] is a convex function # such that max(x,1-x) < A(x) < 1 for all x in [0,1]. # Notes: # Copulae included also in EVANESCE: # gumbel, galambos, husler.reiss, tawn, bb5 # Additionally - not yet tested and documented # gumbelII, marshall.olkin, pi[Cperp], m[Cplus] # References: # Bouye E. (2000), Copulas for Finance: A Reading Guide and # Some Applications, (see the Table on page 49). # Insightful Corp, EVANESCE Implementation in S-PLUS # FinMetrics Module. # FUNCTION: # Missing x: if (missing(x)) x = (0:10)/10 # Type: type = type[1] if (is.null(param)) param = evParam(type)$param names(param) = names(evParam(type)$param) # Settings for Maple Output: Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Compute Derivative: if (type == "gumbel") { # alpha >= 1 alpha = param[1] # Maple Generated Output: if (alpha == 1) A1 = rep(0, times = length(x)) else { A1 = (x^alpha+(1-x)^alpha)^(1/alpha)/alpha*(x^alpha*alpha/x-(1-x)^alpha* alpha/(1-x))/(x^alpha+(1-x)^alpha) A1[x < eps] = -1 A1[x > 1-eps] = 1 } } if (type == "galambos") { # 0 <= alpha < Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A1 = rep(1, times = length(x)) else { A1 = (x^(-alpha)+(1-x)^(-alpha))^(-1/alpha)/alpha*(-x^(-alpha)*alpha/x+( 1-x)^(-alpha)*alpha/(1-x))/(x^(-alpha)+(1-x)^(-alpha)) A1[x < eps] = -1 A1[x > 1-eps] = 1 } } if (type == "husler.reiss") { # 0 <= alpha <= Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A1 = rep(1, times = length(x)) else { A1 = .5*erf(1/2*(1/alpha+.5*alpha*ln(x/(1-x)))*2^(1/2))+.2500000000/Pi^( 1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x)+x/(1 -x)^2)*(1-x)*2^(1/2)-.5*erf(1/2*(1/alpha-.5*alpha*ln(x/(1-x)))*2^(1 /2))-.2500000000*(1-x)^2/Pi^(1/2)*exp(-1/2*(1/alpha-.5*alpha*ln(x/( 1-x)))^2)*alpha*(1/(1-x)+x/(1-x)^2)/x*2^(1/2) A1[x < eps] = -1 A1[x > 1-eps] = 1 } } if (type == "tawn") { # 0 <= alpha < Inf # beta <= 1 # 1 <= r < Inf alpha = param[1] beta = param[2] r = param[3] # Maple Generated Output: if (alpha == 0 | beta == 0 | r == 1) A1 = rep(0, length(x)) else { A1 = beta-alpha+((alpha*x)^r+(beta*(1-x))^r)^(1/r)/r*((alpha*x)^r*r/x-( beta*(1-x))^r*r/(1-x))/((alpha*x)^r+(beta*(1-x))^r) A1[x < eps] = -alpha A1[x > 1-eps] = beta } } if (type == "bb5") { # 0 < delta < Inf # 1 <= theta < Inf delta = param[1] theta = param[2] # Maple Generated Output: if (theta == 1) return(.AfuncFirstDer(x, param, "galambos")) else A1 = (x^theta+(1-x)^theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/ delta))^(1/theta)/theta*(x^theta*theta/x-(1-x)^theta*theta/(1-x)+(x ^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(-delta* theta)*delta*theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))/(x^(- delta*theta)+(1-x)^(-delta*theta)))/(x^theta+(1-x)^theta-(x^(-delta *theta)+(1-x)^(-delta*theta))^(-1/delta)) A1[x < eps] = -1 A1[x > 1-eps] = 1 } # Some more, yet untested and undocumented: if (type == "gumbelII") { # 0 <= alpha < Inf alpha = param[1] A1 = 2*alpha*x-alpha } if (type == "marshall.olkin") { alpha1 = param[1] alpha2 = param[2] A1 = NULL for (i in 1:length(x)) { if (x[i] < 0) A1 = c(A1, -alpha1) if (x[i] > 0) A1 = c(A1, alpha2) if (x[i] == 0) A1 = c(A1, NA) } } if (type == "pi" || type == "Cperp") { A1 = rep(0, times = length(x)) } if (type == "m" || type == "Cplus") { A1 = sign(x-1/2) } # Result: attr(A1, "control") <- unlist(list(param = param, type = type)) # Return Value: A1 } # ------------------------------------------------------------------------------ .AfuncSecondDer = function(x, param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes 2nd derivative of dependence function # Arguments: # x - a numeric vector, with values ranging between # zero and one # param - numeric parameter vector, if set to NULL then # default values are taken # type - character string naming the type of copula, # by default "gumbel" # Details: # Extreme Value Copulae can be represented in the form # # C(u,v) = exp { log(uv)*A[log(u)/log(uv)] } # # where A:[0,1] -> [1/2,1] is a convex function # such that max(x,1-x) < A(x) < 1 for all x in [0,1]. # Note: # The five Copulae considered in EVANESCE are: # gumbel, galambos, husler.reis, tawn, bb5 # Furthermore, added are: # pi|Cperp, gumbelII, marshall.olkin, m|Cplus # References: # Bouye E. (2000), Copulas for Finance: A Reading Guide and # Some Applications, (see the Table on page 49). # Insightful Corp, EVANESCE Implementation in S-PLUS # FinMetrics Module. # FUNCTION: # Missing x: if (missing(x)) x = (0:10)/10 # Type: type = type[1] if (is.null(param)) param = evParam(type)$param names(param) = names(evParam(type)$param) # Settings for Maple Output: Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Compute 2nd Derivative: if (type == "gumbel") { # alpha >= 1 alpha = param[1] # Maple Generated Output: if (alpha == 1) A2 = rep(0, times = length(x)) else A2 = (x^alpha+(1-x)^alpha)^(1/alpha)/alpha^2*(x^alpha*alpha/x-(1-x)^ alpha*alpha/(1-x))^2/(x^alpha+(1-x)^alpha)^2+(x^alpha+(1-x)^alpha)^ (1/alpha)/alpha*(x^alpha*alpha^2/x^2-x^alpha*alpha/x^2+(1-x)^alpha* alpha^2/(1-x)^2-(1-x)^alpha*alpha/(1-x)^2)/(x^alpha+(1-x)^alpha)-(x ^alpha+(1-x)^alpha)^(1/alpha)/alpha*(x^alpha*alpha/x-(1-x)^alpha* alpha/(1-x))^2/(x^alpha+(1-x)^alpha)^2 } if (type == "galambos") { # 0 <= alpha < Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A2 = rep(0, times = length(x)) else if (alpha == 1) A2 = rep(2, times = length(x)) else A2 = -(x^(-alpha)+(1-x)^(-alpha))^(-1/alpha)/alpha^2*(-x^(-alpha)*alpha/ x+(1-x)^(-alpha)*alpha/(1-x))^2/(x^(-alpha)+(1-x)^(-alpha))^2+(x^(- alpha)+(1-x)^(-alpha))^(-1/alpha)/alpha*(x^(-alpha)*alpha^2/x^2+x^( -alpha)*alpha/x^2+(1-x)^(-alpha)*alpha^2/(1-x)^2+(1-x)^(-alpha)* alpha/(1-x)^2)/(x^(-alpha)+(1-x)^(-alpha))-(x^(-alpha)+(1-x)^(- alpha))^(-1/alpha)/alpha*(-x^(-alpha)*alpha/x+(1-x)^(-alpha)*alpha/ (1-x))^2/(x^(-alpha)+(1-x)^(-alpha))^2 } if (type == "husler.reiss") { # 0 <= alpha <= Inf alpha = param[1] # Maple Generated Output: if (alpha == 0) A2 = rep(0, times = length(x)) else A2 = .2500000000/Pi^(1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)* alpha*(1/(1-x)+x/(1-x)^2)/x*(1-x)*2^(1/2)-.1250000000/Pi^(1/2)*(1/ alpha+.5*alpha*ln(x/(1-x)))*alpha^2*(1/(1-x)+x/(1-x)^2)^2/x*(1-x)^2* exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)*2^(1/2)+.2500000000/Pi^( 1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(x/(1-x)))^2)*alpha*(2/(1-x)^2+2 *x/(1-x)^3)*(1-x)*2^(1/2)-.2500000000/Pi^(1/2)*exp(-1/2*(1/alpha+.5 *alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x)+x/(1-x)^2)*2^(1/2)+.75000000/ Pi^(1/2)*exp(-1/2*(1/alpha-.5*alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x )+x/(1-x)^2)/x*(1-x)*2^(1/2)-.1250000000*(1-x)^3/Pi^(1/2)*(1/alpha- .5*alpha*ln(x/(1-x)))*alpha^2*(1/(1-x)+x/(1-x)^2)^2/x^2*exp(-1/2*(1 /alpha-.5*alpha*ln(x/(1-x)))^2)*2^(1/2)-.2500000000*(1-x)^2/Pi^(1/2 )*exp(-1/2*(1/alpha-.5*alpha*ln(x/(1-x)))^2)*alpha*(2/(1-x)^2+2*x/( 1-x)^3)/x*2^(1/2)+.2500000000*(1-x)^2/Pi^(1/2)*exp(-1/2*(1/alpha-.5* alpha*ln(x/(1-x)))^2)*alpha*(1/(1-x)+x/(1-x)^2)/x^2*2^(1/2) } if (type == "tawn") { # 0 <= alpha, beta <= 1, 1 <= r < Inf alpha = param[1] beta = param[2] r = param[3] # Maple Generated Output: if (alpha == 0 | beta == 0 | r == 1) A2 = rep(0, length(x)) else A2 = ((alpha*x)^r+(beta*(1-x))^r)^(1/r)/r^2*((alpha*x)^r*r/x-(beta*(1-x) )^r*r/(1-x))^2/((alpha*x)^r+(beta*(1-x))^r)^2+((alpha*x)^r+(beta*(1 -x))^r)^(1/r)/r*((alpha*x)^r*r^2/x^2-(alpha*x)^r*r/x^2+(beta*(1-x)) ^r*r^2/(1-x)^2-(beta*(1-x))^r*r/(1-x)^2)/((alpha*x)^r+(beta*(1-x))^ r)-((alpha*x)^r+(beta*(1-x))^r)^(1/r)/r*((alpha*x)^r*r/x-(beta*(1-x ))^r*r/(1-x))^2/((alpha*x)^r+(beta*(1-x))^r)^2 # A2[x<1e-12] = 0 # A2[x>1-1e-12] = 0 } if (type == "bb5") { # delta > 0, theta >= 1 delta = param[1] theta = param[2] # Maple Generated Output: if (theta == 1) return(.AfuncSecondDer(x, param, "galambos")) else A2 = (x^theta+(1-x)^theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/ delta))^(1/theta)/theta^2*(x^theta*theta/x-(1-x)^theta*theta/(1-x)+ (x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(- delta*theta)*delta*theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))/ (x^(-delta*theta)+(1-x)^(-delta*theta)))^2/(x^theta+(1-x)^theta-(x^ (-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))^2+(x^theta+(1-x)^ theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))^(1/theta)/ theta*(x^theta*theta^2/x^2-x^theta*theta/x^2+(1-x)^theta*theta^2/( 1-x)^2-(1-x)^theta*theta/(1-x)^2-(x^(-delta*theta)+(1-x)^(-delta* theta))^(-1/delta)/delta^2*(-x^(-delta*theta)*delta*theta/x+(1-x)^( -delta*theta)*delta*theta/(1-x))^2/(x^(-delta*theta)+(1-x)^(-delta* theta))^2+(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta* (x^(-delta*theta)*delta^2*theta^2/x^2+x^(-delta*theta)*delta*theta/ x^2+(1-x)^(-delta*theta)*delta^2*theta^2/(1-x)^2+(1-x)^(-delta* theta)*delta*theta/(1-x)^2)/(x^(-delta*theta)+(1-x)^(-delta*theta)) -(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(- delta*theta)*delta*theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))^ 2/(x^(-delta*theta)+(1-x)^(-delta*theta))^2)/(x^theta+(1-x)^theta-( x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))-(x^theta+(1-x)^ theta-(x^(-delta*theta)+(1-x)^(-delta*theta))^(-1/delta))^(1/theta)/ theta*(x^theta*theta/x-(1-x)^theta*theta/(1-x)+(x^(-delta*theta)+( 1-x)^(-delta*theta))^(-1/delta)/delta*(-x^(-delta*theta)*delta* theta/x+(1-x)^(-delta*theta)*delta*theta/(1-x))/(x^(-delta*theta)+( 1-x)^(-delta*theta)))^2/(x^theta+(1-x)^theta-(x^(-delta*theta)+(1-x )^(-delta*theta))^(-1/delta))^2 } # Some more, yet untested and undocumented: if (type == "gumbelII") { alpha = param[1] A2 = rep(2*alpha, times = length(x)) } if (type == "marshall.olkin") { alpha1 = param[1] alpha2 = param[2] A2 = rep(0, times = length(x)) } if (type == "pi" || type == "Cperp") { A2 = rep(0, times = length(x)) } if (type == "m" || type == "Cplus") { A2 = rep(0, times = length(x)) } # Result: attr(A2, "control") <- unlist(list(param = param, type = type)) # Return Value: A2 } ################################################################################ fCopulae/R/ExtremeValueDependency.R0000644000176000001440000002506711370220745017004 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # evTau Returns Kendall's tau for extreme value copulae # .ev1Tau Computes Kendall's tau from dependency function # .ev2Tau Computes Kendall's tau from integration # evRho Returns Spearman's rho for extreme value copulae # .ev1Rho Computes Spearman's rho from dependency function # .ev2Rho Computes Spearman's rho from integration # FUNCTION: EXTREME VALUE COPULAE TAIL DEPENDENCE: # evTailCoeff Computes tail dependence for extreme value copulae # evTailCoeffSlider Plots extreme value tail dependence function ################################################################################ ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # evTau Returns Kendall's tau for extreme value copulae # evRho Returns Spearman's rho for extreme value copulae evTau = function(param = NULL, type = evList(), alternative = FALSE) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau for an extreme value copula # Example: # evTau(alternative = FALSE) # evTau(alternative = TRUE) # FUNCTION: # Kendall's Tau: if (!alternative) { # Default Method: ans = .ev1Tau(param, type) } else { # Alternative Method: ans = .ev2Tau(param, type) } # Return Value: ans } # ------------------------------------------------------------------------------ .ev1Tau = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau from dependency function # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Kendall's Tau Integrand: fun = function(x, param, type) { # To be integrated from 0 to 1 ... A = Afunc(x = x, param = param, type = type) A2 = .AfuncSecondDer(x, param, type) f = (x*(1-x)/A) * A2 f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate(fun, 0, 1, param = param, type = type) Tau = c(Tau = ans[[1]]) # Add Control Attribute: attr(Tau, "control")<-attr(attribute, "control") # Return Value: Tau } # ------------------------------------------------------------------------------ .ev2Tau = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau from integration # Example: # .ev2Tau() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Kendall's Tau Minus Rho/3 Double Integrand: fun = function(x, y, ...) { D = devCopula(x, y, alternative = FALSE, ...) D[is.na(D)] = 0 f = 4 * ( pevCopula(x, y, alternative = FALSE, ...) - x*y) * D f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate2d(fun, param = param, type = type, error = 1e-8) Tau = c(Tau = ans[[1]] + .ev2Rho(param, type)/3) # Add Control Attribute: attr(Tau, "control")<-attr(attribute, "control") # Return Value: Tau } # ------------------------------------------------------------------------------ evRho = function(param = NULL, type = evList(), alternative = FALSE) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho for an extreme value copula # Example: # evRho(alternative = FALSE) # evRho(alternative = TRUE) # FUNCTION: # Spearman's Rho: if (!alternative) { # Default Method: ans = .ev1Rho(param, type) } else { # Alternative Method: ans = .ev2Rho(param, type) } # Return Value: ans } # ------------------------------------------------------------------------------ .ev1Rho = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho from dependency function # Example: # .ev1Rho() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Spearman's Rho Integrand: fun = function(x, param, type) { # To be integrated from 0 to 1 ... A = Afunc(x = x, param = param, type = type) f = ( 12 / (A+1)^2 ) - 3 f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate(fun, 0, 1, param = param, type = type) Rho = c(Rho = ans[[1]]) # Add Control Attribute: attr(Rho, "control")<-attr(attribute, "control") # Return Value: Rho } # ------------------------------------------------------------------------------ .ev2Rho = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho from integration # Example: # .ev2Rho() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Spearman's Rho Integrand: fun = function(x, y, ...) { f = 12 * pevCopula(x, y, ...) - 3 f } # Get control attribute from: attribute = Afunc(0.5, param, type) # Integrate: ans = integrate2d(fun, param = param, type = type) Rho = c(Rho = ans[[1]]) # Add Control Attribute: attr(Rho, "control")<-attr(attribute, "control") # Return Value: Rho } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE TAIL DEPENDENCE: # evTailCoeff Computes tail dependence for extreme value copulae # evTailCoeffSlider Plots extreme value tail dependence function evTailCoeff = function(param = NULL, type = evList()) { # A function implemented by Diethelm Wuertz # Description: # Tail Dependence for extreme value copulae # Example: # evTailCoeff() # FUNCTION: # Type: type = match.arg(type) # Default Parameters: if (is.null(param)) param = evParam(type)$param # Limit: lambdaU = 2-2*Afunc(0.5, param, type)[[1]] lambdaL = 0 ans = c(lower = lambdaL, upper = lambdaU) # Add Control Attribute: attr(ans, "control") <- unlist(list(copula = "ev", param = param, type = type)) # Return Value: ans } # ------------------------------------------------------------------------------ evTailCoeffSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of tail coefficient # Example: # evTailCoeffSlider() # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return() # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: u = seq(0, 0.5, length = N+1)[-1] C.uu = pevCopula(u, u, param, type) lambda = C.uu/u v = seq(0.5, 1, length = N+1)[-(N+1)] C.uu = pevCopula(v, v, param, type) lambda = c(lambda, (1-2*v+C.uu)/(1-v)) x = c(u, v) plot(x, lambda, xlim = c(0, 1), ylim = c(0, 1), pch = 19, col = "steelblue", xlab = "u") title(main = Title) grid() # Add Points: points(x = 0, y = 0, pch = 19, col = "red") points(x = 1, y = 2-2*Afunc(0.5, param, type), pch = 19, col = "red") # Lines: abline(h = 0, col = "grey") abline(v = 0.5, col = "grey") # Reset Frame: par(mfrow = c(1, 1)) } setRmetricsOptions(.counter = 0) # Open Slider Menu: C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta") .sliderMenu(refresh.code, names = c("Copula", "N", C), # N gumbel galamb h.r tawn-tawn-tawn bb5-bb5 minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1), maxima = c(5, 100, B, B, B, 1, 1, B, B, B), resolutions = c(1, 10, .05, .05, .05, .01, .01, .1, .1, .1), starts = c(1, 20, 2, 1, 1, .5, .5, 2, 1, 2)) } ################################################################################ fCopulae/R/ExtremeValueCopulae.R0000644000176000001440000011330711370220745016311 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EXTREME VALUE COPULAE RANDOM VARIATES: # revCopula Generates extreme value copula random variates # revSlider isplays interactively plots of random variates # FUNCTION: EXTREME VALUE COPULAE PROBABILIY: # pevCopula Computes extreme value copula probability # pevSlider Displays interactively plots of probability # .pev1Copula EV copula probability via dependence function # .pev2Copula EV copula probability direct computation # .pevContourSlider Interactive contour plots of EV probability # .pevPerspSlider Interactive perspective plots of EV probability # FUNCTION: EXTREME VALUE COPULAE DENSITY: # devCopula Computes extreme value copula density # devSlider Displays interactively plots of density # .dev1Copula EV copula density via dependence function # .dev2Copula EV copula density direct computation # .devContourSlider Interactive contour plots of EV density # .devPerspSlider Interactive perspective plots of EV density ################################################################################ ################################################################################ # FUNCTION: EXTREME VALUE COPULAE RANDOM VARIATES: # revCopula Generates extreme value copula random variates # revSlider Displays interactively plots of random variates revCopula = function(n, param = NULL, type = evList()) { # Default Settings: subintervals = 100 u = runif(n) # Match Arguments: type = match.arg(type) # Check Parameters: if (is.null(param)) param = evParam(type)$param # Random Variates: q = runif(n) v = u Y = seq(0, 1, length = subintervals) for (i in 1:n) { U = rep(u[i], times = subintervals) C.uv = pevCopula(u = U, v = Y, param, type) / U x = log(U)/log(U*Y) A = Afunc(x, param, type) Aderiv = .AfuncFirstDer(x, param, type) X = C.uv * (A + Aderiv * log(Y)/log(U*Y)) v[i] = approx(X, Y, xout = q[i])$y } ans = cbind(u = u, v = v) # Add Control List: control = list(param = param, copula = "ev", type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ revSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of random variates # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: R = revCopula(N, param = param, type = type) plot(R, pch = 19, col = "steelblue") grid() title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta") .sliderMenu(refresh.code, names = c("Copula", "N", C), # gumbel galamb h.r tawn-tawn-tawn bb5-bb5 minima = c(1, 100, 1, 0, 0, 0, 0, 1, 0, 1), maxima = c(5,5000, B, B, B, 1, 1, B, B, B), resolutions = c(1, 100, .05, .05, .05, .01, .01, .1, .1, .1), starts = c(1, 100, 2, 1, 1, .5, .5, 2, 1, 2)) } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE PROBABILIY: # pevCopula Computes extreme value copula probability # pevSlider Displays interactively plots of probability # .pev1Copula EV copula probability via dependence function # .pev2Copula EV copula probability direct computation # .pevContourSlider Interactive contour plots of EV probability # .pevPerspSlider Interactive perspective plots of EV probability pevCopula = function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # param - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'evParam'. # type - the type of the maximum extreme value copula. A character # string selected from: "gumbel", "galambos", "husler.reiss", # "tawn", or "bb5". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the probability be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: pevCopula((0:10)/10) # persp(pevCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Select Type: type = match.arg(type) # Compute Copula: if (!alternative) { ans = .pev1Copula(u, v, param, type, output) } else { ans = .pev2Copula(u, v, param, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ pevSlider = function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # Match Arguments: type = match.arg(type) # Plot: if (type == "persp") .pevPerspSlider(B = B) if (type == "contour") .pevContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .pev1Copula = function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability via dependency function # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Settings: log.u = log(u) log.v = log(v) x = log.u/(log.u+log.v) # Copula Probability: A = Afunc(x, param = param, type = type) C = exp((log.u+log.v) * A) names(C) = NULL # Simulates Max function: C = (C + abs(C))/2 # On Boundary: C[is.na(C)] = 0 C[which(u == 0)] = 0 C[which(u == 1)] = v[which(u == 1)] C[which(v == 0)] = 0 C[which(v == 1)] = u[which(v == 1)] C[which(u*v == 1)] = 1 C[which(u+v == 0)] = 0 # Result: attr(C, "control") <- unlist(list(param = param, type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C = list(x = x, y = y, z = matrix(C, ncol = N)) } # Return Value: C } # ------------------------------------------------------------------------------ .pev2Copula = function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability directly # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Compute Probability: if (type == "gumbel") { alpha = param[1] C = exp(-((-log(u))^alpha + (-log(v))^alpha)^(1/alpha)) } if (type == "galambos") { alpha = param[1] u.tilde = -log(u) v.tilde = -log(v) C = u*v*exp(((u.tilde)^(-alpha) + (v.tilde)^(-alpha))^(-1/alpha)) } if (type == "husler.reiss") { alpha = param[1] u.tilde = -log(u) v.tilde = -log(v) C = exp(- u.tilde * pnorm(1/alpha + 0.5*alpha*log(u.tilde/v.tilde)) - v.tilde * pnorm(1/alpha + 0.5*alpha*log(v.tilde/u.tilde)) ) } if (type == "tawn") { b = param[1] a = param[2] r = param[3] log.uv = log(u*v) t = log(u)/log.uv A = 1-b+(b-a)*t+(a^r*t^r+b^r*(1-t)^r)^(1/r) C = exp(log.uv*A) } if (type == "bb5") { delta = param[1] theta = param[2] u.tilde = -log(u) v.tilde = -log(v) C = exp(-( u.tilde^theta + v.tilde^theta - ( u.tilde^(-theta*delta) + v.tilde^(-theta*delta) )^(-1/delta))^(1/theta)) } # Some more, yet untested and undocumented: if (type == "gumbelII") { alpha = param[1] C = u*v*exp(alpha*log(u)*log(v)/(log(u)+log(v))) } if (type == "marshall.olkin") { a = param[1] b = param[2] C = apply(cbind(v*u^(1-a), u*v^(1-b)), 1, min) } if (type == "pi" || type == "Cperp") { C = u*v } if (type == "m" || type == "Cplus") { C = apply(cbind(u, v), 1, min) } # Simulates Max function: C = (C + abs(C))/2 # On Boundary: C[is.na(C)] = 0 C[which(u == 0)] = 0 C[which(u == 1)] = v[which(u == 1)] C[which(v == 0)] = 0 C[which(v == 1)] = u[which(v == 1)] C[which(u*v == 1)] = 1 C[which(u+v == 0)] = 0 # Result: attr(C, "control") <- unlist(list(param = param, type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C = list(x = x, y = y, z = matrix(C, ncol = N)) } # Return Value: C } # ------------------------------------------------------------------------------ .pevContourSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively contour plots of probability #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) nlev = .sliderMenu(no = 11) ncol = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: uv = grid2d(x = (0:N)/N) D = .pev1Copula(u = uv, type = type, param = param, output = "list") image(D, col = heat.colors(ncol) ) contour(D, nlevels = nlev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula","N", C), #gal hr tawn bb5 nlev ncol minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, 5, 12), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 100, 256), resolutions = c(1, 1, .05, .05, .05, .01, .01, .1, .1, .1, 5, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, 10, 12)) } # ------------------------------------------------------------------------------ .pevPerspSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 12) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: uv = grid2d(x = (0:N)/N) D = .pev1Copula(u = uv, type = type, param = param, output = "list") #D2 = .pev2Copula(u = uv, type = type, param = param, output = "list") persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C), #gal hr tawn bb5 theta phi minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, -180, 0), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 180, 360), resolutions = c(1, 1, .05, .05, .05, .01, .01, .1, .1, .1, 1, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, -40, 30)) } ################################################################################ # FUNCTION: EXTREME VALUE COPULAE DENSITY: # devCopula Computes extreme value copula density # devSlider Displays interactively plots of density # .dev1Copula EV copula density via dependence function # .dev2Copula EV copula density direct computation # .devContourSlider Interactive contour plots of EV density # .devPerspSlider Interactive perspective plots of EV density devCopula = function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density from dependence function # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # param - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'evParam'. # type - the type of the maximum extreme value copula. A character # string selected from: "gumbel", "galambos", "husler.reiss", # "tawn", or "bb5". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the density be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of density values depending on the # value of the "output" variable. # Example: # Diagonal Value: devCopula((0:10)/10) # persp(devCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Copula Density: if (alternative) { ans = .dev2Copula(u, v, param, type, output) } else { ans = .dev1Copula(u, v, param, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ devSlider = function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # Match Arguments: type = match.arg(type) # Plot: if (type == "persp") .devPerspSlider(B = B) if (type == "contour") .devContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .dev1Copula = function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density from dependence function # Example: # Diagonal Value: devCopula((0:10)/10) # persp(devCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Settings for Maple Output: Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Further Settings: log.u = log(u) log.v = log(v) x = log.u/(log.u+log.v) y = log.v/(log.u+log.v) # Copula Probability: A = Afunc(x, param = param, type = type) A1 = .AfuncFirstDer(x, param = param, type = type) A2 = .AfuncSecondDer(x, param = param, type = type) # Prefactor: P = pevCopula(u, v, param = param, type = type) / (u*v) c.uv = P * (( -x*y/(log.u+log.v))*A2 + (A+y*A1)*(A-x*A1) ) c.uv[which(u*v == 0 | u*v == 1)] = 0 # Result: attr(c.uv, "control") <- unlist(list(param = param, type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dev2Copula = function(u = 0.5, v = u, param = NULL, type = evList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density directly # Details: # List - 9 Types: # pi[Cperp], gumbel, gumbelII, galambos, husler.reiss, # tawn, bb5, marshall.olkin, m[Cplus] # References: # Carmona, Evanesce # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.null(param)) { param = evParam(type)$param } if (is.list(u)) { v = u$y u = u$x } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Settings: if (is.null(param)) param = evParam[[type]] Pi = pi ln = function(x) { log(x) } erf = function (x) { 2*pnorm(sqrt(2)*x)-1 } # Compute Probability: if (type == "gumbel") { alpha = param[1] # Maple Generated Output: c.uv = -((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha)*(-ln(v))^alpha/v/ln(v)/( (-ln(u))^alpha+(-ln(v))^alpha)^2*(-ln(u))^alpha/u/ln(u)*exp(-((-ln( u))^alpha+(-ln(v))^alpha)^(1/alpha))+((-ln(u))^alpha+(-ln(v))^alpha )^(1/alpha)*(-ln(u))^alpha/u/ln(u)/((-ln(u))^alpha+(-ln(v))^alpha)^ 2*exp(-((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha))*(-ln(v))^alpha* alpha/v/ln(v)+(((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha))^2*(-ln(u) )^alpha/u/ln(u)/((-ln(u))^alpha+(-ln(v))^alpha)^2*(-ln(v))^alpha/v/ ln(v)*exp(-((-ln(u))^alpha+(-ln(v))^alpha)^(1/alpha)) } if (type == "galambos") { alpha = param[1] # Maple Generated Output: c.uv = exp(((-ln(u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha))+((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^(-1/alpha)*(-ln(v))^(-alpha)/ln(v)/((-ln( u))^(-alpha)+(-ln(v))^(-alpha))*exp(((-ln(u))^(-alpha)+(-ln(v))^(- alpha))^(-1/alpha))+((-ln(u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha )*(-ln(u))^(-alpha)/ln(u)/((-ln(u))^(-alpha)+(-ln(v))^(-alpha))*exp( ((-ln(u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha))+((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^(-1/alpha)*(-ln(v))^(-alpha)/ln(v)/((-ln( u))^(-alpha)+(-ln(v))^(-alpha))^2*(-ln(u))^(-alpha)/ln(u)*exp(((-ln (u))^(-alpha)+(-ln(v))^(-alpha))^(-1/alpha))+((-ln(u))^(-alpha)+(- ln(v))^(-alpha))^(-1/alpha)*(-ln(u))^(-alpha)/ln(u)/((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^2*exp(((-ln(u))^(-alpha)+(-ln(v))^(-alpha ))^(-1/alpha))*(-ln(v))^(-alpha)*alpha/ln(v)+(((-ln(u))^(-alpha)+(- ln(v))^(-alpha))^(-1/alpha))^2*(-ln(u))^(-alpha)/ln(u)/((-ln(u))^(- alpha)+(-ln(v))^(-alpha))^2*(-ln(v))^(-alpha)/ln(v)*exp(((-ln(u))^( -alpha)+(-ln(v))^(-alpha))^(-1/alpha)) } if (type == "husler.reiss") { # Maple Generated Output: c.uv = (-.2500000000/u/Pi^(1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(u)/ln(v)) )^2)*alpha/v/ln(v)*2^(1/2)+.1250000000/Pi^(1/2)*(1/alpha+.5*alpha* ln(ln(u)/ln(v)))*alpha^2/v/ln(v)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(u )/ln(v)))^2)/u*2^(1/2)-.2500000000/v/Pi^(1/2)*exp(-1/2*(1/alpha+.5* alpha*ln(ln(v)/ln(u)))^2)*alpha/u/ln(u)*2^(1/2)+.1250000000/Pi^(1/2 )*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))*alpha^2/v*exp(-1/2*(1/alpha+.5 *alpha*ln(ln(v)/ln(u)))^2)/u/ln(u)*2^(1/2))*exp(.5*ln(u)*(erf(1/2*( 1/alpha+.5*alpha*ln(ln(u)/ln(v)))*2^(1/2))+1)+.5*ln(v)*(erf(1/2*(1/ alpha+.5*alpha*ln(ln(v)/ln(u)))*2^(1/2))+1))+(.5/u*(erf(1/2*(1/ alpha+.5*alpha*ln(ln(u)/ln(v)))*2^(1/2))+1)+.2500000000/Pi^(1/2)* exp(-1/2*(1/alpha+.5*alpha*ln(ln(u)/ln(v)))^2)*alpha/u*2^(1/2)-.25* ln(v)/Pi^(1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))^2)* alpha/u/ln(u)*2^(1/2))*(-.2500000000*ln(u)/Pi^(1/2)*exp(-1/2*(1/ alpha+.5*alpha*ln(ln(u)/ln(v)))^2)*alpha/v/ln(v)*2^(1/2)+.5/v*(erf( 1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))*2^(1/2))+1)+.2500000000/Pi^( 1/2)*exp(-1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))^2)*alpha/v*2^(1/2) )*exp(.5*ln(u)*(erf(1/2*(1/alpha+.5*alpha*ln(ln(u)/ln(v)))*2^(1/2)) +1)+.5*ln(v)*(erf(1/2*(1/alpha+.5*alpha*ln(ln(v)/ln(u)))*2^(1/2))+1 )) } if (type == "tawn") { # 0 <= alpha, beta <= 1, 1 <= r < Inf b = param[1] a = param[2] r = param[3] # Maple Generated Output: c.uv = (-(b-a)/u/ln(u*v)^2/v+2*(b-a)*ln(u)/ln(u*v)^3/u/v+(a^r*(ln(u)/ln(u* v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)/r^2*(-a^r*(ln(u)/ln(u*v))^r*r/ ln(u*v)/v+b^r*(1-ln(u)/ln(u*v))^r*r*ln(u)/ln(u*v)^2/v/(1-ln(u)/ln(u *v)))/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^2*(a^r*(ln(u) /ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln(u)*ln(u*v)+b^r*(1- ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)/(1-ln(u)/ln(u*v )))+(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)/r*(-a^r*( ln(u)/ln(u*v))^r*r^2/v*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln(u)+a^r*( ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)^2/v+2*ln(u)/ln(u*v)^3/u/v)/ln(u)* ln(u*v)+a^r*(ln(u)/ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln( u)/v+b^r*(1-ln(u)/ln(u*v))^r*r^2*ln(u)/ln(u*v)^2/v/(1-ln(u)/ln(u*v) )^2*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)+b^r*(1-ln(u)/ln(u*v))^r*r*(1/u /ln(u*v)^2/v-2*ln(u)/ln(u*v)^3/u/v)/(1-ln(u)/ln(u*v))-b^r*(1-ln(u)/ ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)/(1-ln(u)/ln(u*v))^2* ln(u)/ln(u*v)^2/v)/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)- (a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)/r*(a^r*(ln(u) /ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ln(u)*ln(u*v)+b^r*(1- ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v)^2/u)/(1-ln(u)/ln(u*v )))/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^2*(-a^r*(ln(u)/ ln(u*v))^r*r/ln(u*v)/v+b^r*(1-ln(u)/ln(u*v))^r*r*ln(u)/ln(u*v)^2/v/ (1-ln(u)/ln(u*v))))*exp(ln(u*v)-b+(b-a)*ln(u)/ln(u*v)+(a^r*(ln(u)/ ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r))+(1/u+(b-a)/u/ln(u*v)-(b- a)*ln(u)/ln(u*v)^2/u+(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r )^(1/r)/r*(a^r*(ln(u)/ln(u*v))^r*r*(1/u/ln(u*v)-ln(u)/ln(u*v)^2/u)/ ln(u)*ln(u*v)+b^r*(1-ln(u)/ln(u*v))^r*r*(-1/u/ln(u*v)+ln(u)/ln(u*v) ^2/u)/(1-ln(u)/ln(u*v)))/(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v ))^r))*(1/v-(b-a)*ln(u)/ln(u*v)^2/v+(a^r*(ln(u)/ln(u*v))^r+b^r*(1- ln(u)/ln(u*v))^r)^(1/r)/r*(-a^r*(ln(u)/ln(u*v))^r*r/ln(u*v)/v+b^r*( 1-ln(u)/ln(u*v))^r*r*ln(u)/ln(u*v)^2/v/(1-ln(u)/ln(u*v)))/(a^r*(ln( u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r))*exp(ln(u*v)-b+(b-a)*ln(u)/ ln(u*v)+(a^r*(ln(u)/ln(u*v))^r+b^r*(1-ln(u)/ln(u*v))^r)^(1/r)) } if (type == "bb5") { # delta > 0, theta >= 1 delta = param[1] theta = param[2] # Maple Generated Output: c.uv = -((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^( -theta*delta))^(-1/delta))^(1/theta)/theta^2*((-ln(v))^theta*theta/ v/ln(v)-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta )*(-ln(v))^(-theta*delta)*theta/v/ln(v)/((-ln(u))^(-theta*delta)+(- ln(v))^(-theta*delta)))/((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(- theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))^2*((-ln(u))^theta *theta/u/ln(u)-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(- 1/delta)*(-ln(u))^(-theta*delta)*theta/u/ln(u)/((-ln(u))^(-theta* delta)+(-ln(v))^(-theta*delta)))*exp(-((-ln(u))^theta+(-ln(v))^ theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)) ^(1/theta))-((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta) +(-ln(v))^(-theta*delta))^(-1/delta))^(1/theta)/theta*(-((-ln(u))^( -theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)*(-ln(v))^(-theta* delta)*theta^2/v/ln(v)/((-ln(u))^(-theta*delta)+(-ln(v))^(-theta* delta))^2*(-ln(u))^(-theta*delta)/u/ln(u)-((-ln(u))^(-theta*delta)+ (-ln(v))^(-theta*delta))^(-1/delta)*(-ln(u))^(-theta*delta)*theta^2 /u/ln(u)/((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^2*(-ln(v ))^(-theta*delta)*delta/v/ln(v))/((-ln(u))^theta+(-ln(v))^theta-((- ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))*exp(-((- ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^(- theta*delta))^(-1/delta))^(1/theta))+((-ln(u))^theta+(-ln(v))^theta -((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))^(1/ theta)/theta*((-ln(u))^theta*theta/u/ln(u)-((-ln(u))^(-theta*delta) +(-ln(v))^(-theta*delta))^(-1/delta)*(-ln(u))^(-theta*delta)*theta/ u/ln(u)/((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta)))/((-ln(u) )^theta+(-ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta* delta))^(-1/delta))^2*exp(-((-ln(u))^theta+(-ln(v))^theta-((-ln(u)) ^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta))^(1/theta))*((- ln(v))^theta*theta/v/ln(v)-((-ln(u))^(-theta*delta)+(-ln(v))^(- theta*delta))^(-1/delta)*(-ln(v))^(-theta*delta)*theta/v/ln(v)/((- ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta)))+(((-ln(u))^theta+(- ln(v))^theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/ delta))^(1/theta))^2/theta^2*((-ln(u))^theta*theta/u/ln(u)-((-ln(u) )^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)*(-ln(u))^(- theta*delta)*theta/u/ln(u)/((-ln(u))^(-theta*delta)+(-ln(v))^(- theta*delta)))/((-ln(u))^theta+(-ln(v))^theta-((-ln(u))^(-theta* delta)+(-ln(v))^(-theta*delta))^(-1/delta))^2*((-ln(v))^theta*theta /v/ln(v)-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/ delta)*(-ln(v))^(-theta*delta)*theta/v/ln(v)/((-ln(u))^(-theta* delta)+(-ln(v))^(-theta*delta)))*exp(-((-ln(u))^theta+(-ln(v))^ theta-((-ln(u))^(-theta*delta)+(-ln(v))^(-theta*delta))^(-1/delta)) ^(1/theta)) } # Result: attr(c.uv, "control") <- unlist(list(param = param, type = type)) # As List ? if (output[1] == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .devContourSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively contour plots of density # FUNCTION: # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 12) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) nlev = .sliderMenu(no = 11) ncol = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: n = N/2 F = (2*1.0e-2)^(1/n) x = 0.5*F^(1:n) x = c(rev(x), 0.5, 1-x) uv = grid2d(x = (1:(N-1))/N) D = .dev1Copula(u = uv, type = type, param = param, output = "list") image(D, col = heat.colors(ncol) ) contour(D, nlevels = nlev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula","N", C), #gal hr tawn bb5 nlev ncol minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, 5, 12), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 100, 256), resolutions = c(1, 5, .05, .05, .05, .01, .01, .1, .1, .1, 5, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, 10, 12)) } # ------------------------------------------------------------------------------ .devPerspSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively contour plots of density #FUNCTION: # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 12) return () # Sliders: Type = evList() Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) if (Copula <= 3) param = c(delta = .sliderMenu(no = Copula + 2)) if (Copula == 4) param = c(alpha = .sliderMenu(no = 6), beta = .sliderMenu(no = 7), r = .sliderMenu(no = 8)) if (Copula == 5) param = c(delta = .sliderMenu(no = 9), theta = .sliderMenu(no = 10)) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Title: type = Type[Copula] subTitle = paste(paste(names(param) , "="), param, collapse = " | " ) Title = paste(" ", type, "\n", subTitle) # Plot: n = N/2 F = (2*1.0e-2)^(1/n) x = 0.5*F^(1:n) x = c(rev(x), 0.5, 1-x) uv = grid2d(x = x) D = .dev1Copula(u = uv, type = type, param = param, output = "list") persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 12) C = c("1 Gumbel: delta", "2 Galambos: delta", "3 Husler-Reis: delta", "4 Tawn: alpha", "... beta", "... r", "5 BB5: delta", "... theta", "Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C), #gal hr tawn bb5 theta phi minima = c(1, 10, 1, 0, 0, 0, 0, 1, 0, 1, -180, 0), maxima = c(5, 100, B, B, B, 1, 1, B, B, B, 180, 360), resolutions = c(1, 5, .05, .05, .05, .01, .01, .1, .1, .1, 1, 1), starts = c(1, 25, 2, 1, 1, .5, .5, 2, 1, 2, -40, 30)) } ################################################################################ fCopulae/R/EmpiricalCopulae.R0000644000176000001440000001336211370220745015610 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EMPIRICAL COPULAE PROBABILIY: # pempiricalCopula Computes empirical copula probability # FUNCTION: EMPIRICAL COPULAE DENSITY: # dempiricalCopula Computes empirical copula density # FUNCTION: DEBYE FUNCTION: # .Debye Returns the value of the Debye function of order k # .Debye1 Returns the value of the Debye function of order 1 # FUNCTION: # .pmoCopula # .dmoCopula ################################################################################ ################################################################################ # FUNCTION: EMPIRICAL COPULAE PROBABILIY: # pempiricalCopula Computes empirical copula probability pempiricalCopula = function(u, v, N = 10) { # A function implemented by Diethelm Wuertz # Description # Computes the empirical copula probability # Source: # bouye02a.pdf # FUNCTION: # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Probability: p = q = (0:N)/N h = matrix(rep(0, times = (N+1)^2), N+1) for ( i in (0:N) ) { for ( j in (0:N) ) { z = Heaviside(u, p[i+1]) + Heaviside(v, q[j+1]) h[j+1, i+1] = length(z[z == 0]) } } h = h/length(u) # Return Value: list(x = p, y = q, z = h) } ################################################################################ # FUNCTION: EMPIRICAL COPULAE DENSITY: # dempiricalCopula Computes empirical copula density dempiricalCopula = function(u, v, N = 10) { # A function implemented by Diethelm Wuertz # Description # Computes the empirical copula probability # Source: # bouye02a.pdf # FUNCTION: # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Probability: ans = pempiricalCopula(u, v, N) X = ans$x Y = ans$y C = ans$z # Density: M = N+1 x = X[-1] - diff(X)/2 y = Y[-1] - diff(Y)/2 c = C[-1,-1]+C[-M,-M]-C[-1,-M]-C[-M,-1] # Return Value: list(x = x, y = y, z = c) } ################################################################################ # FUNCTION: DEBYE FUNCTION: # .Debye Returns the value of the Debye function of order k # .Debye1 .Debye = function(x, k = 1) { # A function implemented by Diethelm Wuertz # Description: # Returns the value of the Debye function of order k # Arguments: # x - a numeric value or vector # k - the order of the Debye function, a positive integer value # FUNCTION: # Check: if (!is.integer(k) | k <= 0) stop("k must be a positive integer") # Loop: D = NULL error = NULL for ( i in 1:length(x) ) { nextD = .Debye1(x[i],k) D = c(D, nextD[[1]]) error = c(error, nextD[[2]]) } # Add error attribute: attr(D, "error") = error # Return Value: D } # ------------------------------------------------------------------------------ .Debye1 = function(x, k = 1) { # A function implemented by Diethelm Wuertz # FUNCTION: # Function to be integrated: d = function(x, lambda) { x^lambda / ( exp(x) - 1 ) } # Integrate: u = abs(x) if (x == 0) { D = 1 error = 0 } else { ans = integrate(f = d, lower = 0, upper = u, lambda = k) D = k * ans[[1]] / u^k error = ans[[2]] } if (x < 0) { D = D + k*u/(k+1) } # Return Value: list(D = D, error = error) } ################################################################################ # FUNCTION: # .pmoCopula # .dmoCopula .pmoCopula = function(u = 0.5, v = u, alpha = NULL) { if (is.null(alpha)) alpha = c(0.5, 0.5) alpha1 = alpha[1] alpha2 = alpha[2] U = u^(1-alpha1) * v V = u * v^(1-alpha2) UV = cbind(U,V) apply(UV, 1, max) } # ------------------------------------------------------------------------------ .dmoCopula = function(u = 0.5, v = u, alpha = NULL) { if (is.null(alpha)) alpha = c(0.5, 0.5) alpha1 = alpha[1] alpha2 = alpha[2] U = u^(1-alpha1) * v V = u * v^(1-alpha2) UV = cbind(U,V) apply(UV, 1, max) } ################################################################################ fCopulae/R/EllipticalModelling.R0000644000176000001440000001356011370220745016307 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL COPULAE PARAMETER FITTING: # ellipticalCopulaSim Simulates bivariate elliptical copula # ellipticalCopulaFit Fits the paramter of an elliptical copula ################################################################################ ################################################################################ # FUNCTION: ELLIPTICAL COPULAE PARAMETER FITTING: # ellipticalCopulaSim Simulates bivariate elliptical copula # ellipticalCopulaFit Fits the paramter of an elliptical copula ellipticalCopulaSim = function (n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) { # A function implemented by Diethelm Wuertz # Description: # Simulates bivariate elliptical Copula # Match Arguments: type = match.arg(type) # "norm" Random Deviates: if (type == "norm") { ans = .rnormCopula(n = n, rho = rho) } # "cauchy" Random Deviates: if (type == "cauchy") { ans = .rcauchyCopula(n = n, rho = rho) } # "t" Random Deviates: if (type == "t") { if (is.null(param)) { param = c(nu = 4) } else { param = c(nu = param[1]) } ans = .rtCopula(n = n, rho = rho, nu = param) } # "logistic" Random Deviates: # NOT YET IMPLEMENTED ... # "laplace" Random Deviates: # NOT YET IMPLEMENTED ... # "kotz" Random Deviates: # NOT YET IMPLEMENTED ... # "epower" Random Deviates: # NOT YET IMPLEMENTED ... # Control: control = list(rho = rho, param = param, type = type) attr(ans, "control") = unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalCopulaFit = function(u, v = NULL, type = c("norm", "cauchy", "t"), ...) { # A function implemented by Diethelm Wuertz # Description: # Fits the paramter of an elliptical copula # Note: # The upper limit for nu is 100 # FUNCTION: # Match Arguments: type = match.arg(type) # Settings: U = u V = v if (is.list(u)) { u = u[[1]] v = u[[2]] } if (is.matrix(u)) { U = u[, 1] V = u[, 2] } U <<- u V <<- v # Estimate Rho from Kendall's tau for all types of Copula: tau = cor(x = U, y = V, method = "kendall") #[1, 2] Rho = rho = sin((pi*tau/2)) # Estimate "norm" Copula: if (type == "norm") { fun = function(x) { -mean( log(.dnormCopula(u = U, v = V, rho = x)) ) } fit = nlminb(start = rho, objective = fun, lower = -1, upper = 1, ...) } # Estimate "cauchy" Copula: if (type == "cauchy") { fun = function(x) { -mean( log(.dcauchyCopula(u = U, v = V, rho = x)) ) } fit = nlminb(start = rho, objective = fun, lower = -1, upper = 1, ...) } # Estimate "t" Copula: if (type == "t") { fun = function(x) { -mean( log(.dtCopula(u = U, v = V, rho = x[1], nu = x[2])) ) } fit = nlminb(start = c(rho = rho, nu = 4), objective = fun, lower = c(-1, 1), upper = c(1, Inf), ...) fit$Nu = 4 } # Estimate "logistic" Copula: if (type == "logistic") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = -1, NA), upper = c(rho = 1, NA), ...) } # Estimate "laplace" Copula: if (type == "laplace") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = -1, NA), upper = c(rho = 1, NA), ...) } # Estimate "kotz" Copula: if (type == "kotz") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = -1, NA), upper = c(rho = 1, NA), ...) } # Estimate "epower" Copula: if (type == "epower") { # NOT YET IMPLEMENTED ... fun = function(x) { -mean( log(dellipticalCopula(u = U, v = V, ...)) ) } fit = nlminb(start = c(), objective = fun, lower = c(rho = -1, NA), upper = c(rho = 1, NA), ...) } # Keep Start Value: # fit$Rho = Rho # Return Value: fit } ################################################################################ fCopulae/R/EllipticalGenerator.R0000644000176000001440000014640611370220745016331 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: UTILITY FUNCTIONS: # ellipticalList Returns list of implemented Elliptical copulae # ellipticalParam Sets default parameters for an elliptical copula # ellipticalRange Returns the range of valid rho values # ellipticalCheck Checks if rho is in the valid range # FUNCTION: ELLIPTICAL GENERATOR AND RELATED FUNCTIONS: # gfunc Generator function for elliptical distributions # gfuncSlider Slider for generator, density and probability # .pelliptical Univariate elliptical distribution probability # .delliptical Univariate elliptical distribution density # .qelliptical Univariate elliptical distribution quantiles # .qlogistic Fast tabulated logistic quantile function # .qlogisticData Table generator for logistic quantiles # .qlogisticTable Table for logistic quantiles ################################################################################ ################################################################################ # UTILITY FUNCTIONS: # ellipticalParam Sets Default parameters for an elliptical copula # ellipticalList Returns list of implemented Elliptical copulae # ellipticalRange Returns the range of valid rho values # ellipticalCheck Checks if rho is in the valid range ellipticalList = function() { # A function implemented by Diethelm Wuertz # Description: # Returns list of implemented elliptical copulae # Arguments: # FUNCTION: # Compose List: ans = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalParam = function(type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Sets default parameters for elliptical copulae # Arguments: # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Value: # returns a list with two elements, 'param' sets the parameters # which may be a vector, 'range' the range with minimum and # maximum values for each of the parameters. # Example: # ellipticalParam("norm"); ellipticalParam("t") # FUNCTION: # Settings: type = match.arg(type) # Parameter Values: # ("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") lower = c( -1, -1, -1, -1, -1, -1, -1) upper = c( +1, +1, +1, +1, +1, +1, +1) rho = c(3/4, 3/4, 3/4, 3/4, 3/4, 3/4, 3/4) param1 = c( NA, NA, 4, NA, NA, 1, 1) param2 = c( NA, NA, NA, NA, NA, NA, 1) # Create Parameter List: ans = list(type = type) if (type == "norm") { ans$param = c(rho = rho[1]) ans$range = c(lower = lower[1], upper = upper[1]) } if (type == "cauchy") { ans$param = c(rho = rho[2]) ans$range = c(lower = lower[2], upper = upper[2]) } if (type == "t") { ans$param = c(rho = rho[3], nu = param1[3]) ans$range = c(lower = lower[3], upper = upper[3]) } if (type == "logistic") { ans$param = c(rho = rho[4]) ans$range = c(lower = lower[4], upper = upper[4]) } if (type == "laplace") { ans$param = c(rho = rho[5]) ans$range = c(lower = lower[5], upper = upper[5]) } if (type == "kotz") { ans$param = c(rho = rho[6], r = param1[6]) ans$range = c(lower = lower[6], upper = upper[6]) } if (type == "epower") { ans$param = c(rho = rho[7], r = param1[7], s = param2[7]) ans$range = c(lower = lower[7], upper = upper[7]) } # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalRange = function(type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Returns the range of valid alpha values # Arguments: # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Example: # ellipticalRange("norm"); ellipticalRange("t") # FUNCTION: # Type: type = match.arg(type) # Range: ans = ellipticalParam(type)$range attr(ans, "control") <- type # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalCheck = function(rho = 0.75, param = NULL, type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Checks if alpha is in the valid range # Arguments: # rho - correlation coefficient # param - currently not used # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Example: # ellipticalCheck(0.5, NULL, "norm") # ellipticalCheck(1.5, NULL, "t") # FUNCTION: # Type: type = match.arg(type) # Range: range = as.vector(ellipticalRange(type)) if (rho < range[1] | rho > range[2]) { print(c(rho = rho)) print(c(range = range)) stop("rho is out of range") } # Return Value: invisible() } ################################################################################ # FUNCTION: ELLIPTICAL GENERATOR AND RELATED FUNCTIONS: # gfunc Generator function for elliptical distributions # gfuncSlider Slider for generator, density and probability # .pelliptical Univariate elliptical distribution probability # .delliptical Univariate elliptical distribution density # .qelliptical Univariate elliptical distribution quantiles # .qlogistic Fast tabulated logistic quantile function # .qlogisticData Table generator for logistic quantiles # .qlogisticTable Table for logistic quantiles gfunc = function(x, param = NULL, type = ellipticalList()) { # A function implemented by Diethelm Wuertz # Description: # Generator function for elliptical distributions # Arguments: # x - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution # Value: # Returns a numeric vector "g(x)" for the generator computed at # the x values taken from the input vector. If x is missing, # the normalizing constant "lambda" will be returned. # FUNCTION: # Match Arguments: type = match.arg(type) # Handle Missing x: if (missing(x)) { x = NA output = "lambda" } else { output = "g" } # Get Type: type = type[1] # Get Parameters: # if (is.null(param)) param = ellipticalParam$param # Create Generator: if (type == "norm") { g = exp(-x/2) lambda = 1 / (2*pi) param = NULL } if (type == "cauchy") { g = ( 1 + x )^ (-3/2 ) lambda = 1 / (2*pi) param = NULL } if (type == "t") { if (is.null(param)) { nu = 4 } else { nu = param[[1]] } g = ( 1 + x/nu )^ ( -(nu+2)/2 ) lambda = 1/(2*pi) param = c(nu = nu) } if (type == "logistic"){ g = exp(-x/2)/(1+exp(-x/2))^2 # lambda: # integrate(function(x) { exp(-x)/(1+exp(-x))^2}, 0, Inf, # subdivision = 10000, rel.tol = .Machine$double.eps^0.8) # 0.5 with absolute error < 2.0e-13 lambda = 1 / pi param = NULL } if (type == "laplace") { # or "double exponential" # epower - with r = 1, s = 1 # g = exp(-r*(x/2)^s) # lambda = s * r^(1/s) / ( 2 * pi * gamma(1/s) ) g = exp(-sqrt(x)) lambda = 1/(2*pi) param = NULL } if (type == "kotz") { # epower - with s = 1 if (is.null(param)) { r = 1 } else { r = param } g = exp(-r*(x/2)) lambda = r/(2*pi) param = c(r = r) } if (type == "epower") { if (is.null(param)) { r = 1 s = 1 } else { r = param[[1]] s = param[[2]] } g = exp(-r*(x/2)^s) lambda = s * r^(1/s) / ( 2 * pi * gamma(1/s) ) param = c(r = r, s = s) } # Output: output = output[1] if (output == "g") { ans = g } else if (output == "lambda") { ans = lambda } # Add Control: if (output == "g") { attr(ans, "control") <- c(copula = "elliptical", type = type, lambda = as.character(lambda)) } else if (output == "lambda") { if (is.null(param)) { attr(ans, "control") <- unlist(list(copula = "elliptical", type = type)) } else { attr(ans, "control") <- unlist(list(copula = "elliptical", type = type, param = param)) } } # Return Value: ans } # ------------------------------------------------------------------------------ gfuncSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Slider for generator function, density and probability # FUNCTION: # Graphic Frame: par(mfrow = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- setRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 6) return () # Sliders: Copula = as.integer(.sliderMenu(no = 1)) type = ellipticalList() type = type[Copula] Type = c("Normal", "Cauchy", "Student-t", "Logistic", "Laplace", "Kotz", "Exponential Power") Type = Type[Copula] N = .sliderMenu(no = 2) nu = .sliderMenu(no = 3) r = .sliderMenu(no = 4) s = .sliderMenu(no = 5) rho = .sliderMenu(no = 6) L = 6.5 # Parameters: param = NULL if (Copula == 3) param = nu if (Copula == 6) param = r if (Copula == 7) param = c(r, s) prefactor = gfunc(param = param, type = type)[[1]] Lambda = as.character(round(prefactor, digits = 3)) Nu = R = S = NA if (Copula == 3) Nu = as.character(round(nu, digits = 1)) if (Copula >= 6) R = as.character(round(r, digits = 1)) if (Copula == 7) S = as.character(round(s, digits = 1)) delta = 10/N # Bivariate Density: x = y = seq(-4, 4, length = 101) D = delliptical2d(grid2d(x), rho = rho, param = param, type = type, output = "list") # Plot 1: Limit = "" if (Copula == 3 & nu == 1) Limit = "| [Cauchy]" if (Copula == 6 & r == 1) Limit = "| [Normal]" if (Copula == 7 & s == 1) Limit = "| [Kotz]" if (Copula == 7 & r == 1 & s == 1) Limit = "| [Normal]" lambda = gfunc(param = param, type = type) x = seq(0, L, length = N) y = gfunc(x, param = param, type = type) y.norm = gfunc(x, type = "norm") plot(x, y, type = "l", ylab = "g", ylim = c(0, 1)) abline(h = 0, lty = 3, col = "grey") lines(x, y.norm, lty = 3, col = "red") title(main = paste("Generator:", Type, Limit, "\nPre-Factor:", Lambda)) mtext("Dotted Curve: Normal Generator", side = 4, col = "grey", cex = 0.7) # Plot 2 - Density: x = seq(-L, L, length = N) y = .delliptical(x, param = param, type = type) y.norm = .delliptical(x, type = "norm") plot(x, y, type = "l", ylab = "Density", ylim = c(0, 0.65)) abline(h = 0, lty = 3, col = "grey") abline(v = 0, lty = 3, col = "grey") lines(x, y.norm, lty = 3, col = "red") Y = 2*integrate(.delliptical, 0, Inf, param = param, type = type)[[1]] Y = as.character(round(Y, 2)) .velliptical = function(x, param, type) x^2*.delliptical(x, param, type) V = 2*integrate(.delliptical, 0, Inf, param = param, type = type)[[1]] V = as.character(round(V, 2)) mtext(paste("Normalization Test:", Y, " | Variance Test:", V), side = 4, col = "grey", cex = 0.7) if (type == "t") { title(main = paste(Type, "Density\n nu =", Nu)) } else if (type == "kotz") { title(main = paste(Type, "Density\n r =", R)) } else if (type == "epower") { title(main = paste(Type, "Density\n r =", R, "s =", S)) } else { title(main = paste(Type, "Density\n ")) } # Plot 3 - Probability: x = seq(-L, L, length = N) y = .pelliptical(x, param = param, type = type) y.norm = .pelliptical(x, type = "norm") plot(x, y, type = "l", ylab = "Probability", ylim = c(0, 1)) abline(h = 0, lty = 3, col = "grey") abline(h = 1, lty = 3, col = "grey") abline(h = 0.5, lty = 3, col = "grey") lines(x, y.norm, lty = 3, col = "red") p95 = .qelliptical(0.95, param = param, type = type) P95 = as.character(round(p95, digits = 2)) abline(v = p95, lty = 3) abline(v = -p95, lty = 3) q95 = .pelliptical(p95, param = param, type = type) points(+p95, q95, pch = 19, cex = 0.5) points(-p95, 1-q95, pch = 19, cex = 0.5) mtext("Dots: Probability(Quantile(0.95)) Test", side = 4, col = "grey", cex = 0.7) Title = paste(Type, "Probability\n 95% =", P95) title(main = Title) # Plot 4 - Bivariate Density: contour(D, levels = c(0.001, 0.01, 0.025, 0.05, 0.1), xlab = "x", ylab = "y") title(main = paste("Bivariate Density\nrho = ", as.character(rho))) grid() # Reset Frame: par(mfrow = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 0) .sliderMenu(refresh.code, names = c("Copula", "N", "3: nu", "6|7: r", "7: s", "rho"), minima = c( 1, 50, 1, 0.1, 0.1, -0.95), maxima = c( 7, 2000, B, B, B, 0.95), resolutions = c( 1, 50, 0.1, 0.1, 0.1, 0.05), starts = c( 1, 100, 4, 1, 1, 0.00)) } # ------------------------------------------------------------------------------ .pelliptical = function(q, param = NULL, type = ellipticalList(), alternative = TRUE, subdivisions = 100) { # A function implemented by Diethelm Wuertz # Description: # Probability function for univariate elliptical distributions # Arguments: # q - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution. # Details: # The probability is computed by integration using the generator # function. If an alternative faster algorithm is available, # this one is used by default. # FUNCTION: # Type: type = match.arg(type) # Alternative Available? if (type == "logistic") alternative = FALSE if (type == "laplace") alternative = FALSE if (type == "kotz") alternative = FALSE if (type == "epower") alternative = FALSE # Original Function: # Fq1 = function (x, Q, param, type) { # acos(abs(Q)/sqrt(x)) * gfunc(x, param, type) } # Transformed Function: u = exp(-x+Q^2) Fq2 = function (x, Q, param, type) { Q^2 * acos(sqrt(x))/x^2 * gfunc(Q^2/x, param, type) } # Add Default Parameters: if (is.null(param)) { if (type == "t") param = c(nu = 4) if (type == "kotz") param = c(r = 1) if (type == "epower") param = c(r = 1, s = 1) } # Probability: ans = NULL if (alternative) { ans = NA if (type[1] == "norm") ans = pnorm(q) if (type[1] == "cauchy") ans = pt(q, df = 1) # pcauchy(q) if (type[1] == "t") ans = pt(q, df = param[[1]]) if (type[1] == "kotz") ans = dnorm(q, sd = 1/sqrt(param[[1]])) } else { lambda = gfunc(param = param, type = type)[[1]] ans = NULL for ( Q in q ) { # More Precise Adaptive Rule: # p = lambda * integrate(Fq1, lower = Q^2, upper = Inf, Q = Q, # param = param, type = type, subdivisions = subdivisions)[[1]] p = lambda*integrate(Fq2, lower = .Machine$double.eps^0.5, upper = 1, Q = Q, param = param, type = type, stop.on.error = FALSE, subdivisions = subdivisions)[[1]] if (Q > 0) p = 1 - p if (abs(Q) < .Machine$double.eps^0.5) p = 0.5 ans = c(ans, p) } } # Return Value: ans } # ------------------------------------------------------------------------------ .delliptical = function(x, param = NULL, type = ellipticalList(), alternative = TRUE, subdivisions = 100) { # A function implemented by Diethelm Wuertz # Description: # Density function for univariate elliptical distributions # Arguments: # x - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution. # alternative - a logical flag. Should alternatively used a # faster algorithm if available? By default TRUE. # Details: # The density is computed by integration using the generator # function. If an alternative faster algorithm is available, # this one is used by default. # FUNCTION: # Type: type = match.arg(type) # Alternative Available? if (type == "logistic") alternative = FALSE if (type == "laplace") alternative = FALSE if (type == "kotz") alternative = FALSE if (type == "epower") alternative = FALSE # Original Function: # fq1 = function (x, Q, param, type) { # gfunc(x, param, type) / ( sqrt(x - Q^2) ) } # Transformed Function: log(x)^2 = x - Q^2 fq2 = function (x, Q, param, type) { 2 * gfunc(log(x)^2+Q^2, param, type) / x } # Add Default Parameters: if (is.null(param)) { if (type == "t") param = c(nu = 4) if (type == "kotz") param = c(r = 1) if (type == "epower") param = c(r = 1, s = 1) } # Normalizing constant lambda: lambda = gfunc(param = param, type = type)[[1]] # Density: ans = NULL if (alternative) { ans = NA if (type[1] == "norm") ans = dnorm(x) if (type[1] == "cauchy") ans = dt(x, df = 1) # dcauchy(x) if (type[1] == "t") ans = dt(x, df = param[[1]]) if (type[1] == "kotz") ans = dnorm(x, sd = 1/sqrt(param[[1]])) } else { lambda = gfunc(param = param, type = type)[[1]] ans = NULL for ( Q in x ) { # More Precise Adaptive Rule: # p = lambda*integrate(fq1, lower = Q^2, upper = Inf, Q = Q, # param = param, type = type)[[1]] p = lambda*integrate(fq2, lower = 0, upper = 1, Q = Q, param = param, type = type, stop.on.error = FALSE, subdivisions = subdivisions)[[1]] ans = c(ans, p) } } # Return Value: ans } # ------------------------------------------------------------------------------ .qelliptical = function(p, param = NULL, type = ellipticalList(), alternative = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Quantile function for univariate elliptical distributions # Arguments: # p - a numeric vector # param - NULL, a numeric value, or a numeric vector adding. # additional parameters to the generator function. # type - a character string denoting the type of distribution. # This may be either # "norm" for the normal distribution, or # "cauchy" for the Cauchy distribution, or # "t" for the Student-t distribution, or # "logistic" for the logistic distribution, or # "laplace" for the distribution, or # "kotz" for the original Kotz distribution, or # "epower" for the exponential power distribution. # alternative - a logical flag. Should be an alternative # faster algorithm used and not the standard algorithm? # Details: # The probability is computed by integration using the generator # function. If an alternative faster algorithm is available, # this one is used by default. # FUNCTION: # Type: type = match.arg(type) # Alternative Available? if (type == "laplace") alternative = FALSE if (type == "kotz") alternative = FALSE if (type == "epower") alternative = FALSE # Add Default Parameters: if (is.null(param)) { if (type == "t") param = c(nu = 4) if (type == "kotz") param = c(r = 1) if (type == "epower") param = c(r = 1, s = 1) } # Probability: ans = NULL if (alternative) { ans = NA if (type[1] == "norm") ans = qnorm(p) if (type[1] == "cauchy") ans = qcauchy(p) if (type[1] == "t") ans = qt(p, df = param[[1]]) if (type[1] == "logistic") ans = .qlogistic(p) if (type[1] == "kotz") ans = dnorm(p, sd = 1/sqrt(param[[1]])) } else { froot <- function(x, p, param, type) { .pelliptical(q = x, param = param, type = type) - p } ans = NULL for (pp in p) { if (pp < .Machine$double.eps) { ans = c(ans, -Inf) } else if (pp > 1 - .Machine$double.eps) { ans = c(ans, Inf) } else { lower = -1 upper = +1 counter = 0 iteration = NA while (is.na(iteration)) { iteration = .unirootNA(f = froot, interval = c(lower, upper), param = param, type = type, p = pp) counter = counter + 1 lower = lower - 2^counter upper = upper + 2^counter } ans = c(ans, iteration) } } } # Return Value: ans } # ------------------------------------------------------------------------------ .qlogistic = function(p) { # A function implemented by Diethelm Wuertz # Description: # Fast Quantile function for the logistic distribution # FUNCTION: # Table: data = .qlogisticTable # Quantiles: P = (sign(p-1/2)+1)/2 - sign(p-1/2)*p ans = sign(0.5-p) * approx(x = data[, 2], y = data[, 1], xout = P)$y # p Boundary: index = which(p < 0.001 & p > 0) if (length(index) > 0) { ans[index] = .qelliptical(p[index], type = "logistic", alternative = FALSE) } index = which(p > 1-0.001 & p < 1) if (length(index) > 0) { ans[index] = .qelliptical(p[index], type = "logistic", alternative = FALSE) } ans[p == 0.5] = 0 ans[p == 0] = -Inf ans[p == 1] = Inf # Return Value: ans } # ------------------------------------------------------------------------------ .qlogisticData = function (dump = FALSE ) { # A function implemented by Diethelm Wuertz # FUNCTION: # Range: p = seq(0.001, 0.500, by = 0.001) # Quantiles by Integration: froot = function(x, p) { .pelliptical(x, type = "logistic") - p } X = NULL for (P in p) { lower = -1 upper = +1 counter = 0 iteration = NA while (is.na(iteration)) { iteration = .unirootNA(f = froot, interval = c(lower, upper), p = P) counter = counter + 1 lower = lower - 2^counter upper = upper + 2^counter } X = c(X, iteration) } Y = .pelliptical(X, type = "logistic") .qlogisticTable = data.frame(cbind(X = X, Y = Y)) # Dump: if (dump) dump(".qlogisticTable", "qlogisticTable.R") # Return Value: invisible(.qlogisticTable) } # ------------------------------------------------------------------------------ .qlogisticTable = structure(list( X = c( -3.28961095698868, -3.08838952917050, -2.96495324742154, -2.87441959067841, -2.80235793855428, -2.74216585623189, -2.69027685632636, -2.64454429353653, -2.60362855984489, -2.56644066721983, -2.53234562858188, -2.50082506289166, -2.47148229772502, -2.44400686160488, -2.41815107184679, -2.39371408491880, -2.37053072103299, -2.34846344243532, -2.32739647429067, -2.30723141378254, -2.28791218251300, -2.26930432832626, -2.25137887299253, -2.23407971956745, -2.21735785753918, -2.20116988800091, -2.18547719458243, -2.17024525936846, -2.15544310253510, -2.14104280951074, -2.12701913726668, -2.11334918152059, -2.1000120943421, -2.08698884326631, -2.07426200479765, -2.06181558657013, -2.04963487351506, -2.03770629424047, -2.02601730451810, -2.01455628530110, -2.00331245315227, -1.99227557959128, -1.98143672734491, -1.97078698069461, -1.96031819468915, -1.95002274531123, -1.93989348557452, -1.92992370611904, -1.92010709998667, -1.91043773071894, -1.90091000365456, -1.89151863995147, -1.88225865304357, -1.87312532726254, -1.86411419838938, -1.85522103592924, -1.84644182692950, -1.83777276118156, -1.82921021766652, -1.82074871277337, -1.81238487394136, -1.80411802330877, -1.79594515630526, -1.78786340687312, -1.77987003898311, -1.77196243800415, -1.76413810662673, -1.75639465334193, -1.74872978943490, -1.7412023575414, -1.73368818564377, -1.7262462929639, -1.71887474483312, -1.71157168326167, -1.70433532304102, -1.69716394791141, -1.69005590701564, -1.68300961157971, -1.67602353180290, -1.66909619394163, -1.66222617757269, -1.65541211302264, -1.64865267895148, -1.64194660007940, -1.63529264504669, -1.62868962439725, -1.62213638867753, -1.61563182664270, -1.60917486356300, -1.60276445962361, -1.59639952641875, -1.59007925325713, -1.58380261455573, -1.57756869582143, -1.57137660985193, -1.56522549889593, -1.55911452857102, -1.55304289016109, -1.54700979879211, -1.54101449249394, -1.53505623130807, -1.52915261112904, -1.52326458881694, -1.51741167285209, -1.5115931890518, -1.50580848264567, -1.50005691749585, -1.49433787536073, -1.48865075519602, -1.48299497249102, -1.47736995863785, -1.47177516036924, -1.46621003903524, -1.4606740702944, -1.4551667434371, -1.44968756093365, -1.4442360379646, -1.43881170197258, -1.43341409223487, -1.42804275945499, -1.42269726537273, -1.41737718239130, -1.41208209321679, -1.40681159053369, -1.40156527665306, -1.39634276321712, -1.39114367089538, -1.38596762909750, -1.38081427569799, -1.37568325677215, -1.37057422634254, -1.36548684613562, -1.36042078534799, -1.35537572042174, -1.35035133482848, -1.34534731886170, -1.34036336943694, -1.33539918989953, -1.33045448983943, -1.32552898491301, -1.32062239667119, -1.31573445239396, -1.31086488493075, -1.30601343254650, -1.30117983877317, -1.29636385226647, -1.29156522666752, -1.28678372046926, -1.28201909688745, -1.27727112373605, -1.27253957330672, -1.26782422225068, -1.26312485147296, -1.25844124601302, -1.25377319494646, -1.24912049128124, -1.24448293185896, -1.23986031725926, -1.23525245170728, -1.23065914298397, -1.22608020233923, -1.22151544440770, -1.21696225226631, -1.21242200176641, -1.20789558040343, -1.20338280567676, -1.19888349860929, -1.19439748365017, -1.18992458855333, -1.18546464439883, -1.18101748533607, -1.17658294861366, -1.17216087446918, -1.16775110605060, -1.16341452449662, -1.15902890823835, -1.15465514386589, -1.15029304960735, -1.14594255361642, -1.14160347928037, -1.13727568813146, -1.13295904407152, -1.12865341331407, -1.12435866432809, -1.12007466778373, -1.11580129649967, -1.11153842461814, -1.10728593065946, -1.10304369280653, -1.09881159197813, -1.09458951100203, -1.09037733457144, -1.08617494920272, -1.08198224319439, -1.07779910658730, -1.07362543112605, -1.06946111022151, -1.06528196623425, -1.06113353941502, -1.05699432071886, -1.05286419954172, -1.04874306739911, -1.04463081785862, -1.04058838163140, -1.0364935858852, -1.03240736512243, -1.02832962049820, -1.02426025492196, -1.02019917300514, -1.01614628101095, -1.01210148680617, -1.00806469981498, -1.00403583097456, -1.00001479269255, -0.995987692143912, -0.99198188126047, -0.987982882923126,-0.983990646036694,-0.980005119840238, -0.976026253905185,-0.972053998133449,-0.968088302755545,-0.964129118328723, -0.96023743089134, -0.956291121335992,-0.952351176345156,-0.948417547764324, -0.944491447079358,-0.940578633091236,-0.936672395329904,-0.932772667777382, -0.928879385227229,-0.924992483271505,-0.921111898287973,-0.917237567427541, -0.913369428601936,-0.909507420471605,-0.905651482433843,-0.901801554611138, -0.89795757783973, -0.894119493658381,-0.890287244297353,-0.886460772667583, -0.882640022350059,-0.878824937585387,-0.875015463263552,-0.871211544913856, -0.867413128695051,-0.863620161385636,-0.859832590374336,-0.856050363650754, -0.852273429796184,-0.848501737974597,-0.844735237923773,-0.840973879946612, -0.837217614902577,-0.833466394199305,-0.82972016978436, -0.825978894137128, -0.82224252026086, -0.81851100167485, -0.81478429240676, -0.81106234698506, -0.807345120431618,-0.803632568254409, -0.799924646440352, -0.796221311448274, -0.79252252020199, -0.788828230083503, -0.785138398926326, -0.781452985008911, -0.777771947048196,-0.774095244193254, -0.770422836019059, -0.766754682520353, -0.763090744605994,-0.759430982092061, -0.755775356696648, -0.752123830034272, -0.748476364110065,-0.744832921314231, -0.741193464432255, -0.737557956577102, -0.733926361277322,-0.730298642409806, -0.726674764210157, -0.723054691267668, -0.719438388520393,-0.715825821250292, -0.712216955078455, -0.708611755960407, -0.705010190181483,-0.701412224352282, -0.697817825404193, -0.69422696058499, -0.690639597454501,-0.687055703880342, -0.68347524803372, -0.679898198385306, -0.676324523701167,-0.672754193038763, -0.669187175743011, -0.665623441442406, -0.662062960045204,-0.658505701735664, -0.654951636970346, -0.651400736474472, -0.647852971238333,-0.644308312513762, -0.640766731810652, -0.637228200893533, -0.633692691778194,-0.630160176728364, -0.626630628252438, -0.623104019100251, -0.619580322259904,-0.616059510954638, -0.612541558639745, -0.60902643899954, -0.60551412594436, -0.602004593607625, -0.598497816342926, -0.594993768721168, -0.591492425527744,-0.587993761759759, -0.584497752623287, -0.581004373530672, -0.577513600097867,-0.574025408141805, -0.570539773677817, -0.567056672917079, -0.563576082264099,-0.560097978314237, -0.55662233785126, -0.553149137844933, -0.549678355448641,-0.546209967997043, -0.542743953003765, -0.539280288159113, -0.53581895132783, -0.532359920546873, -0.528903174023226, -0.525448690131743, -0.521996447413011,-0.518546424571258, -0.515098600472271, -0.511652954141354, -0.508209464761305,-0.504768111670429, -0.501328874360566, -0.497891732475152, -0.494456665807302,-0.491023654297919, -0.487592678033829, -0.484163717245933, -0.480736752307392,-0.477311763731828, -0.473888732171551, -0.470467638415803, -0.467048463389035,-0.463631188149193, -0.460215793886032, -0.45680226191945, -0.453390573697839,-0.449980710796464, -0.44657265491585, -0.443166387880198, -0.43976189163582, -0.436359148249581, -0.432958139907375, -0.429558848912609, -0.426161257684707,-0.422765348757635, -0.419371104778434, -0.415978508505784, -0.41258754280857, -0.409198190664474, -0.405810435158577, -0.402424259481984, -0.399039646930456,-0.395656580903062, -0.392275044900847, -0.388895022525509, -0.385516497478098,-0.382139453557724, -0.378763874660278, -0.375389744777172, -0.372017047994090,-0.368645768489747, -0.36527589053467, -0.361907398489987, -0.358540276806227,-0.355174510022136, -0.351810082763504, -0.348446979742001, -0.345085185754029,-0.341724685679586, -0.338365464481134, -0.335007507202486, -0.331650798967702,-0.328295324979995, -0.324941070520646, -0.321588020947929, -0.318236161696055,-0.314885478274112, -0.311535956265027, -0.308187581324529, -0.304840339180130,-0.301494152790354, -0.298149133027608, -0.294805203648722, -0.291462350657759,-0.28812056012555, -0.284779814605342, -0.281440107419829, -0.278101421295547,-0.274763742560770, -0.271427057605776, -0.268091352881914, -0.264756614900680,-0.261422830232804, -0.258089985507338, -0.254758067410761, -0.251427062686079,-0.248096958131943, -0.244767740601768, -0.241439397002857, -0.238111914295537,-0.234785279492298, -0.231459479656942, -0.228134501903726, -0.224810333396537,-0.221486961348039, -0.218164373018853, -0.214842555716734, -0.21152149679575, -0.208201183655463, -0.204881603740137, -0.201562744537922, -0.198244593580064,-0.194927138440111, -0.191610366733128, -0.188294266114916, -0.184978824281230,-0.181664028967013, -0.178349867945625, -0.175036329028080, -0.171723400062291,-0.168411068932309, -0.165099323557576, -0.161788151892181, -0.158477541924117,-0.15516748167454, -0.151857959197035, -0.148548962576890, -0.145240479930364,-0.141932499403962, -0.138625009173723, -0.135317997444490, -0.132011452449203,-0.128705362448187, -0.125399715728434, -0.122094500602899, -0.118789705409793,-0.115485318511868, -0.112181328295712, -0.108877723171037, -0.105574491569969, -0.102271621946344, -0.0989691027749957, -0.0956669225510829, -0.0923650697894468, -0.0890635330240574, -0.0857623008076265, -0.0824613617115197, -0.0791607043262014, -0.0758603172625963, -0.0725601891549516, -0.069260308666142, -0.0659606644967098, -0.0626612453993505, -0.0593620402006167, -0.0560630378306748, -0.0527642273584164, -0.0494655980205171, -0.0461671392155751, -0.0428688404062201, -0.0395706908379783, -0.0362726789608858, -0.0329747914456716, -0.0296770116896015, -0.0263793175678826, -0.0230816777192755, -0.0197840449696766, -0.0164872991738574, -0.0132014769537292, -0.0099153529555198, -0.00656807273015348,-0.00328316565264927, 0), Y = c(0.000999989790249075, 0.00199997659631066,0.0030000533744429, 0.00400032302535487, 0.00500028183011033,0.00600024440622486, 0.00700036400791461, 0.00800057651215374,0.00899926075702241, 0.00999936918645765, 0.0109994715833541,0.0119995614818643,0.0129996374478306,0.0139997002917028, 0.0149997517033347,0.0159997935471271,0.0169998275539801,0.0179998552300887, 0.0189998778128955,0.0199998963093886,0.0209984200243254,0.0219986195324741, 0.0229987985092580,0.0239989556602773,0.0249990929774641,0.0259992125331238, 0.0269993163154686,0.0279994063127642,0.028999484230876, 0.0299995516446606, 0.0309996099536415,0.0319996603894939,0.0329997040283535,0.033999741805388, 0.034999774530007, 0.0359998029007155,0.0369998275190071,0.0379998489022468, 0.0389998674948231,0.0399998836784007,0.0409998977807025,0.0419999100844623, 0.0429999208323128,0.0439999302262356,0.0449999384488791,0.0459999456542143, 0.0469999519731455,0.0479999575239014,0.0489999624033934,0.0499999666971179, 0.050999970479087, 0.0519999738134476,0.0529999767558638,0.0539999793547017, 0.0549999816520199,0.0559999836844612,0.0569999854839726,0.0579999870784435, 0.0589999884922518,0.0600002322660306,0.0610007382842464,0.0620012176556511, 0.0630016721028811,0.0640021032232844,0.0650025124989912,0.0660029014066227, 0.0670032710226466,0.0680036226385918,0.0690039573610388,0.0699961909442808, 0.0709964157890431,0.0719966272564782,0.0729968261635939,0.0739970132882051, 0.074997189351493, 0.075997355027219, 0.076997510945194, 0.0779976576944622, 0.0789977958262262,0.0799979258565364,0.0809980482687644,0.0819981635158824, 0.0829982720225615,0.0839983741871086,0.0849984703832535,0.0859985609618, 0.0869986462521522,0.0879987265637271,0.0889988021872626,0.0899988733960295, 0.0909989402880648,0.0919990034241728,0.0929990628713735,0.0939991188435381, 0.0949991716757273,0.0959992212888924,0.0969992679961586,0.0979993119655162, 0.0989993533551862,0.0999993923142102,0.100999428983003, 0.101996361340610, 0.102996667458178, 0.103996948294911, 0.104997205893694, 0.105997442136406, 0.106997658756622, 0.107997857350875, 0.108998039389096, 0.109998206224314, 0.110998359101641, 0.111998499159902, 0.112998627466711, 0.113998744983746, 0.114998852601866, 0.115998951139948, 0.116999041350541, 0.117999123925120, 0.118999199498883, 0.119999268655243, 0.120999331929934, 0.121999389814826, 0.122999442762193, 0.123999491184829, 0.124999535463806, 0.125999575947988, 0.126999612957384, 0.127999646785496, 0.12899967770146, 0.129999705952036, 0.13099973176343, 0.131999755342970, 0.132999776880658, 0.133999796550584, 0.134999814512239, 0.135999830911716, 0.136999845882814, 0.137999859548057, 0.138999872019624, 0.139999883400211, 0.140999893783817, 0.141999903256468, 0.142999911896882, 0.143999919777082, 0.144999926962952, 0.145999933514754, 0.146999939487602, 0.147999944931889, 0.148999949893692, 0.149999954415129, 0.150999958534699, 0.151999962287943, 0.152999965706274, 0.153999968819446, 0.154999971654293, 0.155999974235324, 0.156999976584922, 0.157999978723527, 0.158999980669799, 0.159999982440775, 0.160999984052003, 0.161999985517674, 0.163000522714305, 0.164001257335553, 0.165001955709628, 0.166002619635127, 0.167003250824463, 0.168003850907805, 0.169004421443053, 0.170004963894409, 0.171005479673739, 0.17200597011836, 0.173006436500641, 0.174006880031024, 0.174993398219765, 0.175993761862996, 0.176994106194154, 0.177994440428791, 0.178994740610310, 0.179995032746045, 0.180995309240802, 0.181995570901728, 0.182995818495872, 0.183996052752091, 0.184996274362880, 0.185996483986112, 0.186996682428530, 0.187996869918613, 0.188997047203267, 0.189997214817756, 0.190997373270305, 0.191997523043414, 0.192997664595105, 0.193997798360121, 0.194997924751063, 0.195998044159472, 0.196998156956866, 0.198004064106562, 0.199004781577514, 0.200005456363768, 0.201006090989097, 0.202006687834809, 0.203007249147298, 0.203992879823315, 0.204993345345794, 0.205993781542165, 0.20699419018612, 0.207994572949000, 0.208994931405369, 0.209995267038304, 0.210995581244424, 0.211995875338658, 0.212996150558767, 0.213996408069636, 0.215000093310879, 0.216000369275620, 0.217000821976959, 0.218001445611404, 0.219002234487624, 0.220003183024853, 0.221004285751305, 0.222005537302608, 0.223006932420246, 0.223992987554550, 0.22499462733946, 0.225996395713614, 0.226998287825741, 0.227999977350380, 0.228999972825903, 0.229999967831223, 0.230999962364020, 0.231999956424305, 0.232999950014237, 0.233999943137955, 0.234999935801416, 0.235999928012238, 0.236999919779558, 0.237999911113890, 0.238999902026997, 0.23999989253177, 0.240999882642106, 0.241999872372804, 0.242999861739457, 0.243999850758354, 0.244999839446394, 0.245999827820992, 0.246999815900002, 0.247999803701641, 0.248999791244413, 0.249999778547048, 0.250999765628433, 0.251999752507560, 0.252999739203466, 0.253999725735183, 0.254999712121693, 0.255999698381881, 0.256999684534495, 0.257999670598112, 0.258999656591096, 0.259999642531572, 0.260999628437393, 0.261999614326116, 0.262999600214975, 0.263999586120861, 0.264999572060296, 0.265999558049426, 0.266999544103992, 0.267999530239325, 0.268999516470329, 0.269999502811470, 0.270999489276768, 0.271999475879788, 0.272999462633633, 0.273999449550939, 0.274999436643870, 0.275999423928137, 0.276999411406967, 0.277999399095057, 0.278999387002665, 0.279999375139568, 0.280999363515069, 0.281999352133693, 0.282999341012350, 0.283999330154682, 0.284999319568118, 0.285999309259627, 0.286999299235725, 0.287999289502482, 0.288999280065525, 0.289999270930049, 0.290999262100821, 0.291999253582187, 0.292999245378082, 0.293999237492035, 0.294999229927180, 0.295999222686262, 0.296999215771647, 0.297999209185332, 0.298999202928950, 0.299999197003782, 0.300999191410765, 0.301999186150503, 0.302999181223271, 0.303999176629033, 0.304999172367443, 0.305999168437859, 0.306999164839350, 0.307999161570707, 0.308999158630451, 0.309999156016846, 0.3109991537279, 0.311999151761384, 0.312999150114833, 0.313999148785561, 0.314999147770665, 0.315999147067038, 0.316999146671377, 0.317999146580187, 0.318999146789796, 0.319999147296359, 0.320999148095870, 0.321999149184165, 0.322999150556936, 0.323999152209734, 0.324999154137979, 0.325999156336969, 0.326999158801883, 0.327999161527793, 0.328999164509669, 0.329999167742386, 0.330999171220733, 0.331999174939416, 0.332999178893067, 0.333999183076251, 0.334999187483469, 0.335999192109171, 0.336999196947752, 0.337999201993567, 0.338999207240932, 0.33999921268413, 0.340999218317417, 0.341999224135028, 0.342999230131179, 0.343999236300076, 0.344999242635916, 0.345999249132897, 0.346999255785214, 0.347999262587073, 0.348999269532686, 0.349999276616284, 0.350999283832112, 0.351999291174441, 0.352999298637566, 0.353999306215812, 0.354999313903537, 0.355999321695133, 0.356999329585035, 0.357999337567717, 0.3589993456377, 0.359999353789552, 0.360999362017892, 0.361999370317391, 0.362999378682777, 0.363999387108836, 0.364999395590413, 0.365999404122415, 0.366999412699814, 0.367999421317649, 0.368999429971024, 0.369999438655116, 0.37099944736517, 0.371999456096506, 0.372999464844517, 0.373999473604672, 0.374999482372517, 0.375999491143676, 0.376999499913850, 0.377999508678821, 0.378999517434455, 0.379999526176695, 0.380999534901569, 0.381999543605189, 0.382999552283749, 0.383999560933529, 0.384999569550893, 0.38599957813229, 0.386999586674258, 0.387999595173416, 0.388999603626474, 0.389999612030226, 0.390999620381554, 0.391999628677426, 0.392999636914899, 0.393999645091113, 0.394999653203298, 0.395999661248771, 0.396999669224934, 0.397999677129276, 0.398999684959373, 0.399999692712886, 0.400999700387563, 0.401999707981236, 0.402999715491823, 0.403999722917325, 0.40499973025583, 0.405999737505508, 0.406999744664612, 0.407999751731479, 0.408999757699432, 0.409999764564645, 0.410999771332861, 0.411999778002731, 0.412999784572988, 0.413999792115251, 0.414999798496769, 0.415999804775648, 0.416999810950938, 0.417999817021771, 0.41899982298735, 0.419999828846956, 0.420999834599940, 0.421999840245729, 0.422999845783821, 0.423999851213786, 0.424999856535265, 0.425999861747966, 0.42699986685167, 0.427999871846223, 0.428999876731538, 0.429999881507595, 0.43099988617444, 0.431999890732181, 0.432999895180991, 0.433999899521106, 0.434999903752824, 0.435999907876499, 0.436999911892552, 0.437999915801457, 0.438999919603749, 0.439999923300017, 0.440999926890908, 0.441999930377125, 0.442999933759421, 0.443999937038606, 0.444999940215541, 0.445999943291138, 0.446999946266358, 0.447999949142211, 0.448999951919758, 0.449999954600106, 0.450999957184407, 0.45199995967386, 0.452999962069707, 0.453999964373235, 0.454999966585772, 0.455999968708689, 0.456999970743396, 0.457999972691344, 0.458999974554023, 0.45999997633296, 0.460999978029718, 0.461999979645896, 0.462999981183131, 0.46399998264309, 0.464999984027476, 0.465999985338022, 0.466999986576494, 0.467999987744687, 0.468999988844425, 0.469999989877562, 0.470999990845976, 0.471999991751573, 0.472999992596279, 0.473999993382044, 0.474999994110834, 0.47599999478463, 0.476999995405422, 0.477999995975202, 0.478999996495962, 0.479999996969683, 0.480999997398343, 0.481999997783931, 0.48299999812849, 0.483999998434203, 0.484999998703553, 0.485999998939509, 0.486999999145696, 0.487999999326349, 0.488999999485856, 0.489999999628004, 0.490999999755448, 0.49199999986999, 0.492999999973083, 0.494000000064158, 0.494999711104453, 0.495996057848887, 0.496992418350526, 0.49800732088262, 0.499003719695633, 0.499999999819624)), .Names = c("X", "Y"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", "30", "31", "32", "33", "34", "35", "36", "37", "38", "39", "40", "41", "42", "43", "44", "45", "46", "47", "48", "49", "50", "51", "52", "53", "54", "55", "56", "57", "58", "59", "60", "61", "62", "63", "64", "65", "66", "67", "68", "69", "70", "71", "72", "73", "74", "75", "76", "77", "78", "79", "80", "81", "82", "83", "84", "85", "86", "87", "88", "89", "90", "91", "92", "93", "94", "95", "96", "97", "98", "99", "100", "101", "102", "103", "104", "105", "106", "107", "108", "109", "110", "111", "112", "113", "114", "115", "116", "117", "118", "119", "120", "121", "122", "123", "124", "125", "126", "127", "128", "129", "130", "131", "132", "133", "134", "135", "136", "137", "138", "139", "140", "141", "142", "143", "144", "145", "146", "147", "148", "149", "150", "151", "152", "153", "154", "155", "156", "157", "158", "159", "160", "161", "162", "163", "164", "165", "166", "167", "168", "169", "170", "171", "172", "173", "174", "175", "176", "177", "178", "179", "180", "181", "182", "183", "184", "185", "186", "187", "188", "189", "190", "191", "192", "193", "194", "195", "196", "197", "198", "199", "200", "201", "202", "203", "204", "205", "206", "207", "208", "209", "210", "211", "212", "213", "214", "215", "216", "217", "218", "219", "220", "221", "222", "223", "224", "225", "226", "227", "228", "229", "230", "231", "232", "233", "234", "235", "236", "237", "238", "239", "240", "241", "242", "243", "244", "245", "246", "247", "248", "249", "250", "251", "252", "253", "254", "255", "256", "257", "258", "259", "260", "261", "262", "263", "264", "265", "266", "267", "268", "269", "270", "271", "272", "273", "274", "275", "276", "277", "278", "279", "280", "281", "282", "283", "284", "285", "286", "287", "288", "289", "290", "291", "292", "293", "294", "295", "296", "297", "298", "299", "300", "301", "302", "303", "304", "305", "306", "307", "308", "309", "310", "311", "312", "313", "314", "315", "316", "317", "318", "319", "320", "321", "322", "323", "324", "325", "326", "327", "328", "329", "330", "331", "332", "333", "334", "335", "336", "337", "338", "339", "340", "341", "342", "343", "344", "345", "346", "347", "348", "349", "350", "351", "352", "353", "354", "355", "356", "357", "358", "359", "360", "361", "362", "363", "364", "365", "366", "367", "368", "369", "370", "371", "372", "373", "374", "375", "376", "377", "378", "379", "380", "381", "382", "383", "384", "385", "386", "387", "388", "389", "390", "391", "392", "393", "394", "395", "396", "397", "398", "399", "400", "401", "402", "403", "404", "405", "406", "407", "408", "409", "410", "411", "412", "413", "414", "415", "416", "417", "418", "419", "420", "421", "422", "423", "424", "425", "426", "427", "428", "429", "430", "431", "432", "433", "434", "435", "436", "437", "438", "439", "440", "441", "442", "443", "444", "445", "446", "447", "448", "449", "450", "451", "452", "453", "454", "455", "456", "457", "458", "459", "460", "461", "462", "463", "464", "465", "466", "467", "468", "469", "470", "471", "472", "473", "474", "475", "476", "477", "478", "479", "480", "481", "482", "483", "484", "485", "486", "487", "488", "489", "490", "491", "492", "493", "494", "495", "496", "497", "498", "499", "500"), class = "data.frame" ) ################################################################################ fCopulae/R/EllipticalDependency.R0000644000176000001440000002657211370220745016462 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL COPULAE DEPENDENCE MASURES: # ellipticalTau Computes Kendall's tau for elliptical copulae # ellipticalRho Computes Spearman's rho for elliptical copulae # FUNCTION: ELLIPTICAL COPULAE TAIL COEFFICIENT: # ellipticalTailCoeff Computes tail dependence for elliptical copulae # ellipticalTailPlot Plots tail dependence function ################################################################################ ################################################################################ # FUNCTION: ELLIPTICAL COPULAE DEPENDENCE MASURES: # ellipticalTau Computes Kendall's tau for elliptical copulae # ellipticalRho Computes Spearman's rho for elliptical copulae ellipticalTau = function(rho) { # A function implemented by Diethelm Wuertz # Description: # Computes Kendall's tau for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Compute Kendall's Tau: ans = 2 * asin(rho) / pi if (length(rho) == 1) { names(ans) = "Tau" } else { names(ans) = paste("Tau", 1:length(rho), sep = "") } # Add Control Attribute: attr(ans, "control") = c(rho = rho) # Return Value: ans } # ------------------------------------------------------------------------------ .ellipticalRho = function(rho, param = NULL, type = ellipticalList(), subdivisions = 500) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Settings: Type = c("Normal Copula", "Cauchy Copula", "Student-t Copula", "Logistic Copula", "Laplace Copula", "Kotz Copula", "Exponential Power Copula") names(Type) = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") type = type[1] Type = Type[type] # Compute Spearman's Rho: ans.norm = round(6 * asin(rho/2) / pi, 2) # Spearman's Rho: N = subdivisions Pi = pfrechetCopula(u = grid2d((1:(N-1))/N), type = "pi", output = "list") D = .dellipticalCopulaGrid(N = N, rho = rho, param = param, type = type, border = FALSE) ans = round(12*mean(Pi$z*D$z)-3, 2) names(ans) = NULL # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalRho = function(rho, param = NULL, type = ellipticalList(), subdivisions = 500) { # A function implemented by Diethelm Wuertz # Description: # Computes Spearman's rho for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Match Arguments: type = match.arg(type) # For all Values of rho: ans = NULL for (i in 1:length(rho)) { ans = c(ans, .ellipticalRho(rho[i], param, type, subdivisions)) } # Add Control Attribute: control = c( rho = rho, param = param, type = type, tau = round(2*asin(rho)/pi, 4)) attr(ans, "control")<-unlist(control) if (length(rho) == 1) { names(ans) = "Rho" } else { names(ans) = paste("Rho", 1:length(rho), sep = "") } # Return Value: ans } ################################################################################ # FUNCTION: ELLIPTICAL COPULAE TAIL COEFFICIENT: # ellipticalTailCoeff Computes tail dependence for elliptical copulae # ellipticalTailPlot Plots tail dependence function ellipticalTailCoeff = function(rho, param = NULL, type = c("norm", "cauchy", "t")) { # A function implemented by Diethelm Wuertz # Description: # Computes tail dependence for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # Note: # type = c("logistic", "laplace", "kotz", "epower") # not yet implemented # FUNCTION: # Check: stopifnot(length(rho) == 1) # Match Arguments: type = match.arg(type) # Compute Tail Dependence: if (type == "norm") { lambda = 0 param = NULL } if (type == "cauchy") { nu = 1 arg = sqrt(nu+1) * sqrt(1-rho) / sqrt(1+rho) lambda = 2 * (1 - pt(arg, df = nu+1)) param = NULL } if (type == "t") { nu = param if (is.null(nu)) nu = 4 arg = sqrt(nu+1) * sqrt(1-rho) / sqrt(1+rho) lambda = 2 * (1 - pt(arg, df = nu+1)) param = c(nu = nu) } if (type == "logistic") { lambda = NA param = NULL } if (type == "laplace") { lambda = NA param = NULL } if (type == "kotz") { lambda = NA param = NULL } if (type == "epower") { lambda = NA param = NULL } # Result: ans = c(lambda = lambda) attr(ans, "control") = c(rho = rho, type = type, param = param) # Return Value: ans } # ------------------------------------------------------------------------------ ellipticalTailPlot = function(param = NULL, type = c("norm", "cauchy", "t"), tail = c("Lower", "Upper")) { # A function implemented by Diethelm Wuertz # Description: # Plots tail dependence for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # Note: # type = c("logistic", "laplace", "kotz", "epower") # not yet implemented # FUNCTION: # Match Arguments: type = match.arg(type) tail = match.arg(tail) # Settings: Title = c("Normal", "Cauchy", "Student-t", "Logistic", "Laplace", "Kotz", "Exponential Power") Title = paste(Title, "Copula") names(Title) = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower") Title = Title[type] tail = tail[1] N = 1000; Points = 20 # don't change these values! u = (0:N)/N SHOW = N+1 # Parameters: if (type == "t" & is.null(param)) { param = c(nu = 4) } if (type == "kotz" & is.null(param)) { param = c(r = 1) } if (type == "epower" & is.null(param)) { param = c(r = 1, s = 1) } # Plot Frame: if (type == "t") Title = paste(Title, "| nu =", as.character(param)) if (type == "t") Title = paste(Title, "| r =", as.character(param)) if (type == "epower") Title = paste(Title, "| r =", as.character(param[1]), " s =", as.character(param[2])) plot(c(0,1), c(0,1), type = "n", main = Title, xlab = "u", ylab = paste(tail, "Tail Dependence")) # Cauchy Tail dependence: if (type == "cauchy") { type = "t" param = c(nu = 1) } # Iterate rho: Rho = c(-0.99, seq(-0.9, 0.9, by = 0.3), 0.99) for (rho in Rho) { # Compute Tail Coefficient: lambda = ellipticalTailCoeff(rho = rho, param = param, type = type) # Compute Copula Cross Section C(u,u)" if (type == "norm") C.uu = pellipticalCopula(u, rho = rho, type = type) if (type == "t") C.uu = .ptCopula(u = u, v = u, rho = rho, nu = param) if (type == "logistic" | type == "laplace" | type == "kotz" | type == "epower") C.uu = .pellipticalCopulaDiag(N, rho = rho, param = param, type = type)$y # Compute Copula Tail dependence lambda: if (tail == "Upper") { lambdaTail = (1-2*u+C.uu)/(1-u) } else if (tail == "Lower") { lambdaTail = C.uu/u } # Define Plot Elements: if (abs(rho) < 0.05) { color = "black" linetype = 1 } else if (abs(rho) > 0.95) { color = "blue" linetype = 1 } else { color = "black" linetype = 3 } # Normal Tail Dependence: if (type == "norm") { lines(u, lambdaTail, lty = linetype, col = color) } # Cauchy and Student-t Tail Dependence: if (type == "t") { if (tail == "Upper") lines(u[u < 0.99], lambdaTail[u < 0.99], lty = linetype, col = color) if (tail == "Lower") lines(u[u > 0.01], lambdaTail[u > 0.01], lty = linetype, col = color) } # Logistic Tail dependence: if (type == "logistic" | type == "laplace" | type == "kotz") { if (tail == "Lower") { SHOW = which.min(lambdaTail[-1]) ## lines(u[SHOW:(N+1)], lambdaTail[SHOW:(N+1)], type = "l", lty = linetype, col = color) } if (tail == "Upper") { SHOW = which.min(lambdaTail[-(N+1)]) lines(u[1:SHOW], lambdaTail[1:SHOW], type = "l", lty = linetype, col = color) } } # Add rho Labels text(x = 0.5, y = lambdaTail[floor(N/2)]+0.05, col = "red", cex = 0.7, labels = as.character(round(rho, 2))) # Add Points to Curves: if (tail == "Upper") { M = min(SHOW, N) Index = seq(1, M, by = Points) X = 1 } else if (tail == "Lower") { M = max(51, SHOW) Index = rev(seq(N+1, M, by = -Points)) X = 0 } points(u[Index], lambdaTail[Index], pch = 19, cex = 0.7) # Add Tail Coefficient: points(x = X, y = lambda[1], pch = 19, col = "red") } points(1, 0, pch = 19, col = "red") abline(h = 0, lty = 3, col = "grey") abline(v = X, lty = 3, col = "grey") # Return Value: invisible() } ################################################################################ fCopulae/R/EllipticalCopulae.R0000644000176000001440000012275211370220745015771 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ELLIPTICAL COPULAE RANDOM DEVIATES: # rellipticalCopula Generates elliptical copula variates # rellipticalSlider Generates interactive plots of random variates # .rnormCopula Generates normal copula random variate # .rcauchyCopula Generates Cauchy copula random variate # .rtCopula Generates Student-t copula random variate # FUNCTION: ELLIPTICAL COPULAE PROBABILITY: # pellipticalCopula Computes elliptical copula probability # pellipticalSlider Generates interactive plots of probability # .pnormCopula Computes normal copula probability # .pcauchyCopula Computes Cauchy copula probability # .ptCopula Computes Student-t copula probability # .pellipticalCopulaGrid Fast equidistant grid version # .pellipticalCopulaDiag Fast diagonal cross section version # .pellipticalPerspSlider Interactive perspective plots of probability # .pellipticalContourSlider Interactive contour plots of probability # FUNCTION: ELLIPTICAL COPULAE DENSITY: # dellipticalCopula Computes elliptical copula density # dellipticalSlider Generates interactive plots of density # .dnormCopula Computes normal copula density # .dcauchyCopula Computes Cauchy copula density # .dtCopula Computes Student-t copula density # .dellipticalCopulaGrid Fast grid version for elliptical copula density # .dellipticalPerspSlider Interactive perspective plots of density # .dellipticalContourSlider Interactive contour plots of density ################################################################################ ################################################################################ # FUNCTION: ELLIPTICAL COPULAE RANDOM DEVIATES: # rellipticalCopula Generates elliptical copula variates # rellipticalSlider Generates interactive plots of random variates # .rnormCopula Generates normal copula random variate # .rcauchyCopula Generates Cauchy copula random variate # .rtCopula Generates Student-t copula random variate rellipticalCopula = function(n, rho = 0.75, param = NULL, type = c("norm", "cauchy", "t")) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # n - number of deviates to be generated. # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # nu - the number of degrees of freedom, only required for # Student-t copulae. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: pnormCopula((0:10)/10) # persp(pnormCopula(u = grid2d(), output = "list")) # FUNCTION: # Settings: type = match.arg(type) # Parameters: if (type == "t") { if(is.null(param)) { param = c(nu = 4) } else { param = c(nu = param) } names(param) = "nu" } # Copula: if (type == "norm") ans = .rnormCopula(n = n, rho = rho) if (type == "cauchy") ans = .rcauchyCopula(n = n, rho = rho) if (type == "t") ans = .rtCopula(n = n, rho = rho, nu = param) # Add Control Attribute: control = list(rho = rho, param = param, type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ rellipticalSlider = function(B = 100) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of random variates #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) seed = .sliderMenu(no = 5) size = .sliderMenu(no = 6) col = .sliderMenu(no = 7) Names = c("- Normal", "- Cauchy", "- Student t") Type = c("norm", "cauchy", "t") eps = 1.0e-6 if (rho == +1) rho = rho - eps if (rho == -1) rho = rho + eps # Tau and Rho: Tau = ellipticalTau(rho) Rho = ellipticalRho(rho) # Plot: Title = paste("Elliptical Copula No:", as.character(Copula), Names[Copula], "\nrho =", as.character(rho), "|") if (Copula == 2) Title = paste(Title, "nu =", as.character(nu), "|") Title = paste(Title, "Kendall = ", as.character(round(Tau, digits = 3)), "|", "Spearman = ", as.character(round(Rho, digits = 3)) ) set.seed(seed) R = rellipticalCopula(n = N, rho = rho, param = nu, type = Type[Copula]) plot(x = R[, 1], y = R[, 2], xlim = c(0, 1), ylim = c(0, 1), xlab = "u", ylab = "v", pch = 19, col = col, cex = size) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - size", "... color") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "t: nu", "seed", plot.names), minima = c( 1, 1000, -1, 1, 1000, 0, 1), maxima = c( 3, 10000, +1, B, 9999, 1, 16), resolutions = c( 1, 500, 0.01, 1, 1, 0.1, 1), starts = c( 1, 1000, 0, 4, 4711, 0.5, 1)) } # ------------------------------------------------------------------------------ .rnormCopula = function(n, rho = 0.75) { # A function implemented by Diethelm Wuertz # Description: # Generates normal copula random variate # Example: # UV = rnormCopula(n = 10000); plot(UV[,1], UV[,2], cex = 0.25) # FUNCTION: # Use: X = .rnorm2d(n, rho) or alternatively: X = .rnorm2d(n = n, rho = rho) # Generate Z <- NULL for(i in (1:n)) Z <- rbind(Z, pnorm(X [i,])) # Return Value: Z } # ------------------------------------------------------------------------------ .rcauchyCopula = function(n, rho = 0.75) { # A function implemented by Diethelm Wuertz # Description: # Generates Student-t copula random variate # Example: # UV = rtCopula(n = 10000); plot(UV[,1], UV[,2], cex = 0.25) # FUNCTION: # Cauchy Deviates: Z = .rtCopula(n = n, rho = rho, nu = 1) # Return Value: Z } # ------------------------------------------------------------------------------ .rtCopula = function(n, rho = 0.75, nu = 4) { # A function implemented by Diethelm Wuertz # Description: # Generates Student-t copula random variate # Example: # UV = rtCopula(n = 10000); plot(UV[,1], UV[,2], cex = 0.25) # FUNCTION: # Use: X = .rnorm2d(n, rho) or alternatively: X = rt2d(n = n, rho = rho, nu = nu) # Generate Z = NULL for (i in (1:n)) Z = rbind(Z, pt(X [i,], df = nu)) # Return Value: Z } ################################################################################ # FUNCTION: ELLIPTICAL COPULAE PROBABILITY: # pellipticalCopula Computes elliptical copula probability # pellipticalSlider Generates interactive plots of probability # .pnormCopula Computes normal copula probability # .pcauchyCopula Computes Cauchy copula probability # .ptCopula Computes Student-t copula probability # .pellipticalCopulaGrid Fast equidistant grid version # .pellipticalCopulaDiag Fast diagonal cross section version # .pellipticalPerspSlider Interactive perspective plots of probability # .pellipticalContourSlider Interactive contour plots of probability pellipticalCopula = function(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # param - distributional parameters, the number of degrees of # freedom for the Student-t copulae. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # FUNCTION: # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: subdivisions = 100 if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } if (length(u) == 1 & u[1] > 1) { return(.pellipticalCopulaGrid(N = u, rho, param, type, border = border)) } # Parameters: if (type == "t") if (is.null(param)) param = c(nu = 4) if (type == "kotz") if (is.null(param)) param = c(r = 1) if (type == "epower") if (is.null(param)) param = c(r = 1, s = 1) # Specical Copulae: if (type == "norm") { if (rho == -1) { ans = pfrechetCopula(u = u, v = v, type = "m", output = output) return(ans) } else if (rho == +1) { ans = pfrechetCopula(u = u, v = v, type = "w", output = output) return(ans) } else { ans = .pnormCopula(u = u, v = v, rho = rho, output = output) return(ans) } } else if (type == "cauchy") { ans = .pcauchyCopula(u = u, v = v, rho = rho, output = output) return(ans) } else if (type == "t") { if (is.null(param)) param = 4 ans = .ptCopula(u = u, v = v, rho = rho, nu = param, output = output) return(ans) } # The remaining Copulae - Compute Density on Regular Grid: N = subdivisions x = (0:N)/N c.uv = .dellipticalCopulaGrid(N = N, rho, param, type, border = TRUE) c.uv$z[is.na(c.uv$z)] = 0 # Integrate to get Probability: C.uv = 0*c.uv$z for (i in 1:(N+1)) { D = matrix(rep(0, times = (N+1)^2), ncol = N+1) for (j in 1:i) { D[1:i, j] = 1 C.uv[i,j] = C.uv[j,i] = sum(D*c.uv$z) } } C.uv = C.uv/N^2 # Take care about the Boundary on the Unit Square: C.uv[1, ] = C.uv[, 1] = 0 C.uv[N+1, ] = C.uv[, N+1] = c.uv$x # Interpolate for the desired Values on the grid: U0 = trunc(u*N) V0 = trunc(v*N) P = (u - U0/N) Q = (v - V0/N) U0 = U0 + 1 U1 = U0 + 1 V0 = V0 + 1 V1 = V0 + 1 C.vec = rep(NA, times = length(u)) for ( i in 1:length(u) ) { p = P[i] q = Q[i] if (p == 0 & q == 0) { C.vec[i] = C.uv[U0[i], V0[i]] } else if (p == 0 & q > 0) { C.vec[i] = (1-q)*C.uv[U0[i], V0[i]] + q*C.uv[U0[i], V1[i]] } else if (p > 0 & q == 0) { C.vec[i] = (1-p)*C.uv[U0[i], V0[i]] + p*C.uv[U1[i], V0[i]] } else { C.vec[i] = (1-p)*(1-q)*C.uv[U0[i], V0[i]] + p*(1-q)*C.uv[U1[i], V0[i]] + (1-p)*q*C.uv[U0[i], V1[i]] + p*q*C.uv[U1[i], V1[i]] } } C.uv = round(C.vec, digits = 3) attr(C.uv, "control") <- c(rho = rho) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] names(x) = names(y) = NULL C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ pellipticalSlider = function(type = c("persp", "contour"), B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Settings: type = match.arg(type) # Plot: if (type == "persp") .pellipticalPerspSlider(B = B) if (type == "contour") .pellipticalContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .pnormCopula = function(u = 0.5, v = u, rho = 0.75, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes normal copula probability # Arguments: # see function 'pellipticalCopula' # FUNCTION: # Type: output = match.arg(output) # Settings: type = "norm" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Probability: C.uv = pnorm2d(qnorm(u), qnorm(v), rho = rho) names(C.uv) = NULL # Simulates Max function: C.uv = (C.uv + abs(C.uv))/2 # On Boundary: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Result: attr(C.uv, "control") <- c(rho = rho) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ .pcauchyCopula = function(u = 0.5, v = u, rho = 0.75, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula probability # Arguments: # see function 'pellipticalCopula' # FUNCTION: # Cauchy Probability: C.uv = .ptCopula(u = u, v = v, rho = rho, nu = 1, output = output) attr(C.uv, "control") <- c(rho = rho) # Return Value: C.uv } # ------------------------------------------------------------------------------ .ptCopula = function(u = 0.5, v = u, rho = 0.75, nu = 4, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula probability # Arguments: # see function 'pellipticalCopula' # FUNCTION: # Match Arguments: output = match.arg(output) # Settings: type = "t" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Probability: C.uv = pt2d(qt(u, df = nu), qt(v, df = nu), rho = rho, nu = nu) names(C.uv) = NULL # Simulates Max function: C.uv = (C.uv + abs(C.uv))/2 # On Boundary: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Result: attr(C.uv, "control") <- c(rho = rho, nu = nu) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ .pellipticalCopulaGrid = function(N, rho = 0.75, param = NULL, type = ellipticalList(), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes elliptical copula probability on a 2d grid # Arguments: # see function pellipticalCopula() # FUNCTION: # Settings: U = (0:N)/N V = (1:(N-1))/N # Compute Density on Regular Grid: c.uv = .dellipticalCopulaGrid(N, rho, param, type, border = TRUE) c.uv$z[is.na(c.uv$z)] = 0 # Integrate to get Probability: if (TRUE) { C.uv = 0*c.uv$z for (i in 1:(N+1)) { for (j in 1:i) { C.uv[i,j] = C.uv[j,i] = sum(c.uv$z[1:i, 1:j]) } } C.uv = C.uv/N^2 } if (FALSE) { # This is much slower ! IJ = grid2d(1:(N+1)) X = cbind(IJ$x, IJ$y) fun = function(X, C) sum(C[1:X[1], 1:X[2]]) C.uv = apply(X, MARGIN=1, FUN = fun, C = c.uv$z) C.uv = matrix(C.uv, byrow = TRUE, ncol = N+1) / N^2 } # Probability - Take care about the Boundary on the Unit Square: C.uv[1, ] = C.uv[, 1] = 0 C.uv[N+1, ] = C.uv[, N+1] = c.uv$x names(C.uv) = NULL attr(C.uv, "control") <- c(rho = rho) C.uv = list(x = U, y = U, z = matrix(C.uv, ncol = length(U))) if (!border) { C.uv$z = C.uv$z[-1, ] C.uv$z = C.uv$z[-N, ] C.uv$z = C.uv$z[, -1] C.uv$z = C.uv$z[, -N] C.uv$x = C.uv$y = V } # Return Value: C.uv } # ------------------------------------------------------------------------------ .pellipticalCopulaDiag = function(N, rho = 0.75, param = NULL, type = ellipticalList(), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes elliptical diagonal cross section copula probability # Arguments: # see function pellipticalCopula() # FUNCTION: # Settings: U = (0:N)/N V = (1:(N-1))/N # Compute Density on Regular Grid: c.uv = .dellipticalCopulaGrid(N, rho, param, type[1], border = TRUE) c.uv$z[is.na(c.uv$z)] = 0 # Integrate to get Probability: C.uu = 0*U for (i in 1:(N+1)) { C.uu[i] = sum(c.uv$z[1:i, 1:i]) } C.uu = C.uu/N^2 names(C.uu) = NULL attr(C.uu, "control") <- c(rho = rho) if (border) { C.uu = list(x = U, y = C.uu) } else { C.uu = list(x = V, y = C.uu[c(-1,-(N+1))]) } # Return Value: C.uu } # ------------------------------------------------------------------------------ .pellipticalPerspSlider = function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # Arguments: # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) theta = .sliderMenu(no = 6) phi = .sliderMenu(no = 7) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: Type = c("norm", "t", "logistic", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 4) param = c(r, s) P = .pellipticalCopulaGrid(N = N, rho = rho, param = param, type = Type[Copula], border = TRUE) persp(P, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u, v)", xlim = c(0, 1), ylim = c(0, 1), zlim = c(0, 1) ) title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, line = 3, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "2: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, -180, 0), maxima = c( 4, 100, 0.95, B, 5, 180, 360), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 1, 1), starts = c( 1, 20, 0.50, 4, 1, -40, 30)) } # ------------------------------------------------------------------------------ .pellipticalContourSlider = function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # Arguments: # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) nlev = .sliderMenu(no = 6) ncol = .sliderMenu(no = 7) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: Type = c("norm", "t", "logistic", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 4) param = c(r, s) P = .pellipticalCopulaGrid(N = N, rho = rho, param = param, type = Type[Copula], border = FALSE) image(P, col = heat.colors(ncol), ylab = "v") mtext("u", side = 1, line = 2, cex = 0.7) contour(P, nlevels = nlev, add = TRUE) title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, line = 3, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "2: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, 5, 12), maxima = c( 4, 100, 0.95, B, 5, 100, 256), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 5, 4), starts = c( 1, 20, 0.50, 4, 1, 10, 32)) } ################################################################################ # FUNCTION: ELLIPTICAL COPULAE DENSITY: # dellipticalCopula Computes elliptical copula density # dellipticalSlider Generates interactive plots of density # .dnormCopula Computes normal copula density # .dcauchyCopula Computes Cauchy copula density # .dtCopula Computes Student-t copula density # .dellipticalCopulaGrid Fast grid version for elliptical copula density # .dellipticalPerspSlider Interactive perspective plots of density # .dellipticalContourSlider Interactive contour plots of density dellipticalCopula = function(u = 0.5, v = u, rho = 0.75, param = NULL, type = ellipticalList(), output = c("vector", "list"), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # param - additional distributional parameters. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: pnormCopula((0:10)/10) # persp(pnormCopula(u = grid2d(), output = "list")) # FUNCTION: # Use Grid Version? if (is.numeric(u)) { if (length(u) == 1 & u[1] > 1) { ans = .dellipticalCopulaGrid(N = u, rho = rho, param = param, type = type, border = border) return(ans) } } # Match Arguments: type = match.arg(type) output = match.arg(output) # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } if (length(u) == 1 & u[1] > 1) { return(.pellipticalCopulaGrid(N = u, rho, param, type, border = border)) } # Parameters: if (type == "t") if (is.null(param)) param = c(nu = 4) if (type == "kotz") if (is.null(param)) param = c(r = 1) if (type == "epower") if (is.null(param)) param = c(r = 1, s = 1) # Density: x = .qelliptical(u, param = param, type = type) y = .qelliptical(v, param = param, type = type) c.uv = delliptical2d(x, y, rho = rho, param = param, type = type) / ( .delliptical(x, param = param, type = type) * .delliptical(y, param = param, type = type) ) if (rho == 0 & type == "norm") c.uv[!is.na(c.uv)] = 1 names(c.uv) = NULL attr(c.uv, "control") <- c(rho = rho) if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ dellipticalSlider = function(type = c("persp", "contour"), B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of density # Description: # Displays interactively plots of density # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Settings: type = match.arg(type) # Plot: if (type == "persp") .dellipticalPerspSlider(B = B) if (type == "contour") .dellipticalContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .dnormCopula = function(u = 0.5, v = u, rho = 0.75, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes normal copula density # Arguments: # see function 'dellipticalCopula' # FUNCTION: # Type: output = match.arg(output) # Settings: type = "norm" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Density: x = qnorm(u) y = qnorm(v) c.uv = dnorm2d(x, y, rho)/(dnorm(x) * dnorm(y)) names(c.uv) = NULL # Result: attr(c.uv, "control") <- c(rho = rho) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dtCopula = function(u = 0.5, v = u, rho = 0.75, nu = 4, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula density # Arguments: # see function 'dellipticalCopula' # FUNCTION: # Match Arguments: output = match.arg(output) # Settings: type = "t" if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 2] u = u[, 1] } # Copula Probability: x = qt(u, df = nu) y = qt(v, df = nu) c.uv = dt2d(x, y, rho, nu)/(dt(x, nu) * dt(y, nu)) names(c.uv) = NULL # Result: attr(c.uv, "control") <- c(rho = rho, nu = nu) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dcauchyCopula = function(u = 0.5, v = u, rho = 0.75, nu = 4, output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Computes Student-t copula density # Arguments: # see function 'dellipticalCopula' # FUNCTION: # Cauchy Density: c.uv = .dtCopula(u = u, v = v, rho = rho, nu = 1, output = output) attr(c.uv, "control") <- c(rho = rho) # Return Value: c.uv } # ------------------------------------------------------------------------------ .dellipticalCopulaGrid = function(N, rho = 0.75, param = NULL, type = ellipticalList(), border = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density # Arguments: # N - the number of grid points is (N+1)*(N+1) # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # param - additional distributional parameters. # type - the type of the elliptical copula. Either "norm" or # "t" denoting the normal or Student-t copula, respectively. # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Note: # Made for the Sliders. # FUNCTION: # Settings: type = type[1] U = (0:N)/N V = (1:(N-1))/N # Reduce to Grid - speeds up the computation: M = N%/%2 + 1 X = .qelliptical(U[1:M], param = param, type = type) if (N%%2 == 0) { X = c(X, rev(-X)[-1]) } else { X = c(X, rev(-X)) } NX = length(X) x = rep(X, times = NX) y = rep(X, each = NX) D = .delliptical(X, param = param, type = type) DX = rep(D, times = NX) DY = rep(D, each = NX) # Density: c.uv = delliptical2d(x, y, rho = rho, param = param, type = type) / (DX*DY) if (rho == 0 & type == "norm") c.uv[!is.na(c.uv)] = 1 c.uv[is.na(c.uv)] = 0 names(c.uv) = NULL attr(c.uv, "control") <- c(rho = rho) c.uv = list(x = U, y = U, z = matrix(c.uv, ncol = N+1)) if (!border) { c.uv$z = c.uv$z[-1, ] c.uv$z = c.uv$z[-N, ] c.uv$z = c.uv$z[, -1] c.uv$z = c.uv$z[, -N] c.uv = list(x = V, y = V, z = matrix(c.uv$z, ncol = N-1)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .dellipticalPerspSlider = function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) theta = .sliderMenu(no = 6) phi = .sliderMenu(no = 7) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula Density No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: uv = grid2d(x = (1:(N-1))/N) Type = c("norm", "t", "logistic", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 4) param = c(r, s) D = .dellipticalCopulaGrid(N, rho = rho, param = param, type = Type[Copula], border = FALSE) Integrated = as.character(round(mean(D$z),2)) Var = var(as.vector(D$z), na.rm = TRUE) if (Var < 1.0e-6) { # A flat perspective plot fails, if zlim is not specified! Mean = round(1.5*mean(as.vector(D$z), na.rm = TRUE), 2) persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlim = c(0, Mean), zlab = "C(u,v)" ) } else { persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u,v)" ) } title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Mean: ", Integrated, " | Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "3: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, -180, 0), maxima = c( 4, 100, 0.95, B, 5, 180, 360), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 1, 1), starts = c( 1, 20, 0.50, 4, 1, -40, 30)) } # ------------------------------------------------------------------------------ .dellipticalContourSlider = function(B = 20) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 7) return () # Sliders: Copula = .sliderMenu(no = 1) N = .sliderMenu(no = 2) rho = .sliderMenu(no = 3) nu = .sliderMenu(no = 4) s = .sliderMenu(no = 5) nlev = .sliderMenu(no = 6) ncol = .sliderMenu(no = 7) if (rho == 0 & Copula == 1) return(invisible()) r = 1 # Title: Names = c("- Normal", "- Student t", "- Logistic", "- Exponential Power") if (nu == 1) Names[2] = "- Student-t [Cauchy]" if (s == 0.5) Names[4] = "- Exponential Power [Laplace]" if (s == 1) Names[4] = "- Exponential Power [Kotz|Normal]" Title = paste("Elliptical Copula Density No:", as.character(Copula), Names[Copula], "\nrho = ", as.character(rho)) if (Copula == 2) Title = paste(Title, "nu =", as.character(nu)) if (Copula == 4) Title = paste(Title, "s =", as.character(s)) # Plot: uv = grid2d(x = (0:N)/N) Type = c("norm", "t", "logistic", "laplace", "kotz", "epower") param = NULL if (Copula == 2) param = nu if (Copula == 5) param = r if (Copula == 6) param = c(r, s) D = .dellipticalCopulaGrid(N, rho = rho, param = param, type = Type[Copula], border = FALSE) Integrated = as.character(round(mean(D$z),2)) image(D, col = heat.colors(ncol), ylab = "v", xlim = c(0,1), ylim = c(0,1) ) mtext("u", side = 1, line = 2, cex = 0.7) contour(D, nlevels = nlev, add = TRUE) title(main = Title) Tau = as.character(round(2*asin(rho)/pi, 2)) mTitle = paste("Mean: ", Integrated, " | Tau", Tau) mtext(mTitle, side = 4, col = "grey", cex = 0.7) mTitle = paste("1: Normal | 2: Student-t [Cauchy] | 3: Logistic |", "4: Exponential Power [Laplace|Kotz]") mtext(mTitle, side = 1, line = 3, col = "grey", cex = 0.7) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: setRmetricsOptions(.counter = 0) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", "rho", "2: nu", "4: s", plot.names), minima = c( 1, 10, -0.95, 1, 0.1, 5, 12), maxima = c( 4, 100, 0.95, B, 5, 100, 256), resolutions = c( 1, 10, 0.05, 0.1, 0.1, 5, 4), starts = c( 1, 20, 0.50, 4, 1, 10, 32)) } ################################################################################ fCopulae/R/CopulaeClass.R0000644000176000001440000001736711370220745014761 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: COPULA SPECIFICATION: # fCOPULA S4 class representation # show S4 print method for copula specification # FUNCTION: FRECHET COPULA: # pfrechetCopula Computes Frechet copula probability # FUNCTION: SPEARMAN'S RHO: # .copulaRho Spearman's rho by integration for "ANY" copula ################################################################################ # moved to zzz.R # setRmetricsOptions(.counter = NA) ################################################################################ # Specifying and creating copula objects setClass("fCOPULA", # Copula Representation: representation( call = "call", copula = "character", param = "list", title = "character", description = "character") ) # ------------------------------------------------------------------------------ setMethod("show", "fCOPULA", function(object) { # A function implemented by Diethelm Wuertz # Description: # Print and Summary method for fCOPULA # Source: # This function copies code from base:print.htest # FUNCTION: # Unlike print the argument for show is 'object'. x = object # Title: cat("\nTitle:\n ", x@title, "\n", sep = "") # Call: cat("\nCall:\n ") cat(paste(deparse(x@call), sep = "\n", collapse = "\n"), "\n", sep = "") # Copula Type: cat("\nCopula:\n ", x@copula, "\n", sep = "") # Model Parameter: if (length(x@param) != 0) { cat("\nModel Parameter(s):\n ") print(unlist(x@param), quote = FALSE) } # Description: cat("\nDescription:\n ", x@description, sep = "") cat("\n\n") # Return Value: invisible(object) }) ################################################################################ # Frechet Copulae: pfrechetCopula = function(u = 0.5, v = u, type = c("m", "pi", "w"), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes Frechet copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # type - the type of the Frechet copula. A character # string selected from: "m", "pi", or "w". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # Examples: # persp(pfrechetCopula(u=grid2d(), output="list", type = "m")) # persp(pfrechetCopula(u=grid2d(), output="list", type = "pi")) # persp(pfrechetCopula(u=grid2d(), output="list", type = "w")) # FUNCTION: # Match Arguments: type = type[1] # Allow for "psp" ... # type = match.arg(type) output = match.arg(output) # Settings: if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Compute Copula Probability: if (type == "m") { # C(u,v) = min(u,v) C.uv = apply(cbind(u, v), 1, min) } if (type == "pi") { # C(u, v) = u * v C.uv = u * v } if (type == "w") { # C(u,v) = max(u+v-1, 0) C.uv = apply(cbind(X = u+v-1, Y = rep(0, length = length(u))), 1, max) } if (type == "psp") { # C(u,v) = u*v/(u+v-u*v) C.uv = u*v/(u+v-u*v) } # Add Control: attr(C.uv, "control") <- unlist(list(type = type)) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } ################################################################################ .copulaRho = function(rho = NULL, alpha = NULL, param = NULL, family = c("elliptical", "archm", "ev", "archmax"), type = NULL, error = 1e-3, ...) { # A function implemented by Diethelm Wuertz # Description: # Spearman's rho by integration for "ANY" copula # Notes: # pellipticalCopula(u, v, rho, param, type, output, border) # parchmCopula (u, v, alpha, type, output, alternative) # pevCopula (u, v, param, type, output, alternative) # parchmaxCopula (u, v, param, type, output ) # Examples: # .copulaRho(rho = 0.5, family = "elliptical", type = "norm") # .copulaRho(alpha = 1, family = "archm", type = "1") # .copulaRho(param = 2, family = "ev", type = "galambos") # FUNCTION: # Match Arguments: family = match.arg(family) # Type: if (is.null(type)) { family = "elliptical" type = "norm" } else { type = as.character(type) } # 2D Function to be integrated: rho <<- rho alpha <<- alpha param <<- param type <<- type if (family == "elliptical") { dCopulaRho <- function(x, y) { C = pellipticalCopula(x, y, rho = rho, param = param, type = type) 12 * (C - x*y ) } } else if (family == "archm") { if (is.null(alpha)) alpha <<- archmParam(type)$param check = archmCheck(alpha, type) dCopulaRho <- function(x, y) { C = parchmCopula(x, y, alpha = alpha, type = type) 12 * (C - x*y ) } } else if (family == "ev") { dCopulaRho <- function(x, y) { C = pevCopula(x, y, param = param, type = type) 12 * (C - x*y ) } } # else if (family == "archmax") { # dCopulaRho <- function(x, y) { # C = parchmaxCopula(x, y, param = param, type = type) # 12 * (C - x*y ) # } # } # Integrate: ans = integrate2d(dCopulaRho, error = error) Rho = ans$value error = ans$error # Result: control = list(rho = rho, alpha = alpha, param = param, family = family, type = type, error = signif(error, 3)) attr(Rho, "control") <- unlist(control) # Return Value: Rho } ################################################################################ fCopulae/R/ArchimedeanSlider.R0000644000176000001440000013216511370220745015740 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE SLIDERS: # rarchmSlider Displays interactively Archimedean probability # parchmSlider Displays interactively Archimedean probability # .parchmPerspSlider Perspective Archimedean probability slider # .parchmContourSlider Contour Archimedean probability slider # darchmSlider Displays interactively archimedean density # .darchmPerspSlider Perspective Archimedean density slider # .darchmContourSlider Contour Archimedean density slider ################################################################################ rarchmSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: # 1 5 10 15 20 Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) # There is no known Copula for the following bounds: eps = 1.0e-6 if (Copula == 11) if (alpha == 0.5) alpha = 0.5 - eps if (Copula == 13) if (alpha == 0.0) alpha = eps # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\nalpha = ", as.character(alpha)) # Plot: R = rarchmCopula(n = N, alpha = alpha, type = as.character(Copula)) plot(R, xlab = "U", ylab = "V", pch = 19, col = "steelblue") grid() title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: C2 = "2-4-6-8-12-14-15-21" C = c("1", C2, "3", "5-17", "7-9-10-22", "11", "13-16-19-20","18") L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c(0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.1, 8) .sliderMenu(refresh.code, names = c("Copula", "N", C), minima = c( 1, 100, L), maxima = c( 22, 1000, U), resolutions = c( 1, 100, V), starts = c( 1, 100, A)) } parchmSlider = function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of probability # Description: # Displays interactively plots of probability # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Match Arguments: type = match.arg(type) # Plot: if (type[1] == "persp") .parchmPerspSlider(B = B) if (type[1] == "contour") .parchmContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .parchm1Copula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Compute Maximum Extreme Value Copulae # Arguments: # see function: parchmCopula # Example: # Diagonal Value: .parchm1Copula((0:10)/10) # persp(.parchm1Copula(u = grid2d(), output = "list")) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[,1] u = u[,2] } # Consider Special Copulae: if (alpha == 0 & Type == 1) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 3) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 1 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 9) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 10) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 11) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 13) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 19) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 20) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 21) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 0 & Type == 22) { C.uv = pfrechetCopula(u, v, type = "pi") } else { C.uv = .invPhi(.Phi(u, alpha, type) + .Phi(v, alpha, type), alpha, type) } # Require special attention for No. 20: if (type == "20") { C.uv = C.uv + (1-sign(C.uv)) * pfrechetCopula(u, v, type = "m") } # Simulate max function: C.uv = (C.uv + abs(C.uv))/2 # Correct C(u,v) on Boundary of Unit Square: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(C.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ .parchm2Copula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # see function: parchmCopula # Example: # Diagonal Value: .parchm2Copula((0:10)/10) # persp(.parchm2Copula(u = grid2d(), output = "list")) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Consider Special Copulae: if (alpha == 0 & Type == 1) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 3) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 1 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 9) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 10) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 11) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 13) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 19) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 20) { C.uv = pfrechetCopula(u, v, type = "pi") } else { if (Type == 1) {# Clayton Copula C.uv = (u^(-alpha)+v^(-alpha)-1)^(-1/alpha) } if (Type == 2) { X = 1-((1-u)^alpha+(1-v)^alpha)^(1/alpha) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 3) { C.uv = u*v/(1-alpha*(1-u)*(1-v)) } if (Type == 4) { # Gumbel Copula C.uv = exp( -((-log(u))^(alpha)+(-log(v))^(alpha))^(1/alpha)) } if (Type == 5) { # Frank Copula C.uv = -1/alpha*log(1+(exp(-alpha*u)-1)* (exp(-alpha*v)-1)/(exp(-alpha)-1)) } if (Type == 6) { C.uv = 1-((1-u)^alpha+(1-v)^alpha-(1-u)^alpha* (1-v)^alpha)^(1/alpha) } if (Type == 7) { X = alpha*u*v+(1-alpha)*(u+v-1) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 8) { X = (alpha^2*u*v-(1-u)*(1-v))/(alpha^2-(alpha-1)^2*(1-u)*(1-v)) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 9) { C.uv = u*v*exp(-alpha*log(u)*log(v)) } if (Type == 10) { C.uv = u*v/(1+(1-u^alpha)*(1-v^alpha))^(1/alpha) } if (Type == 11) { X = (u^alpha*v^alpha-2*(1-u^alpha)*(1-v^alpha))^(1/alpha) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 12) { C.uv = (1+((u^(-1)-1)^alpha+(v^(-1)-1)^alpha)^(1/alpha))^(-1) } if (Type == 13) { C.uv = exp(1-((1-log(u))^alpha+(1-log(v))^alpha-1)^(1/alpha)) } if (Type == 14) { C.uv = (1+((u^(-1/alpha)-1)^alpha + (v^(-1/alpha)-1)^alpha)^(1/alpha))^(-alpha) } if (Type == 15) { X = (1-((1-u^(1/alpha))^alpha + (1-v^(1/alpha))^alpha )^(1/alpha) )^alpha Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 16) { C.uv = 1/2*((u+v-1-alpha*(1/u+1/v-1))+ sqrt((u+v-1-alpha*(1/u+1/v-1))^2+4*alpha)) } if (Type == 17) { C.uv = (1+((1+u)^(-alpha)-1)* ((1+v)^(-alpha)-1)/(2^(-alpha)-1))^(-1/alpha)-1 } if (Type == 18) { eps = 1/10^8 u = u - eps*(1-sign(1-u)) v = v - eps*(1-sign(1-v)) X = 1+alpha/log(exp(alpha/(u-1))+exp(alpha/(v-1))) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 19) { C.uv = alpha/log(exp(alpha/u)+exp(alpha/v)-exp(alpha)) } if (Type == 20) { a.range = "(0, Inf)" C.uv = (log(exp(1/u^alpha)+exp(1/v^alpha)-exp(1)))^(-1/alpha) C.uv = C.uv + (1-sign(C.uv)) * pfrechetCopula(u, v, type = "m") } if (Type == 21) { # NOT YET IMPLEMENTED warning("No. 21 alternative not active") C.uv = NA # USE: C.uv = .parchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output ) return(C.uv) } if (Type == 22) { # NOT YET IMPLEMENTED warning("No. 22 alternative not active") C.uv = NA # USE: C.uv = .parchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output ) return(C.uv) } } # Simulate max function: C.uv = (C.uv + abs(C.uv))/2 # Correct C(u,v) on Boundary of Unit Square: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(C.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ .parchmPerspSlider = function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (0:N)/N) P = .parchm1Copula(u = uv, alpha = alpha, type = Copula, output = "list") persp(P, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u,v)" ) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: B = 5 C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 8) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, -180, 0), maxima = c( 22, 100, U, 180, 360), resolutions = c( 1, 10, V, 1, 1), starts = c( 1, 10, A, -40, 30)) } # ------------------------------------------------------------------------------ .parchmContourSlider = function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of probability #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: # 1 5 10 15 20 Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) n.lev = .sliderMenu(no = 11) n.col = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (0:N)/N) P = .parchm1Copula(u = uv, alpha = alpha, type = Copula, output = "list") image(P, col = heat.colors(n.col) ) contour(P, xlab = "u", ylab = "v", nlevels = n.lev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 8) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, 5, 12), maxima = c( 20, 100, U, 100, 256), resolutions = c( 1, 10, V, 5, 1), starts = c( 1, 10, A, 10, 12)) } ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE DENSITY: # darchmCopula Computes Archimedean copula density # darchmSlider Displays interactively archimedean density # .darchm1Copula Utility Function # .darchm2Copula Utility Function # .darchmPerspSlider Utility Function # .darchmContourSlider Utility Function darchmCopula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # alpha - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'archmParam'. # type - the type of the Archimedean copula. An integer or character # string selected from: "1", ..., "22". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the probability be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: darchmCopula((0:10)/10) # persp(darchmCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Copula: if (alternative) { ans = .darchm2Copula(u, v, alpha, type, output) } else { ans = .darchm1Copula(u, v, alpha, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ darchmSlider = function(type = c("persp", "contour"), B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively plots of density # Arguments: # type - a character string specifying the plot type. # Either a perspective plot which is the default or # a contour plot with an underlying image plot will # be created. # B - the maximum slider menu value when the boundary # value is infinite. By default this is set to 10. # FUNCTION: # Match Arguments: type = match.arg(type) # Plot: if (type == "persp") .darchmPerspSlider(B = B) if (type == "contour") .darchmContourSlider(B = B) # Return Value: invisible() } # ------------------------------------------------------------------------------ .darchm1Copula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes Density of Maximum Extreme Value Copulae # References: # Nelsen # Matteis, Diploma Thesis # Carmona, Evanesce # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Density: c.uv = .invPhiSecondDer( .Phi(u, alpha, type) + .Phi(v, alpha, type), alpha, type ) / ( .invPhiFirstDer(.Phi(u, alpha, type), alpha, type) * .invPhiFirstDer(.Phi(v, alpha, type), alpha, type) ) # c.uv[which(u*v == 0 | u*v == 1)] = 0 # Replace NAs: # c.uv[is.na(c.uv)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(c.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .darchm2Copula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Extreme Value Copulae # References: # Carmona, Evanesce # Matteis, Diploma Thesis # Notes: # "4" Gumbel(alpha->1) -> m-Copula min(u,v) # Example: # persp(z = matrix(.darchm1Copula(.gridCoord()$x, .gridCoord()$y, 1.1, "4"), 101)) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } a = alpha if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Density: if (Type == 1) { c.uv = (1 + a)*u^(-1 - a)*v^(-1 - a) * (-1 + u^(-a) + v^(-a))^(-2 - a^(-1)) } if (Type == 2) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 2 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 3) { c.uv = (-1 + a^2*(-1 + u + v - u*v) - a*(-2 + u + v + u*v)) / (-1 + a*(-1 + u)*(-1 + v))^3 } if (Type == 4) { # Matteis yields wrong results! # c.uv = ((-log(u))^(-1 + a)*(-1 + a + ((-log(u))^a + # (-log(v))^a)^a^(-1))*((-log(u))^a + # (-log(v))^a)^(-2 + a^(-1))*(-log(v))^(-1 + a))/ # (exp((-log(u))^a + (-log(v))^a)^a^(-1)*u*v) # Use instead: c.uv = exp(-((-log(u))^alpha+(-log(v))^alpha)^(1/alpha)) * (- (-log(u))^alpha*(-log(v))^alpha*((-log(u))^alpha + (-log(v))^alpha)^(1/alpha)+(-log(u))^alpha*(-log(v))^alpha * ( (-log(u))^alpha+(-log(v))^alpha)^(1/alpha)*alpha + (-log(u))^(3*alpha)*(-log(v))^alpha*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha)+2*(-log(u))^(2*alpha) * (-log(v))^(2*alpha)*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha)+(-log(u))^alpha * (-log(v))^(3*alpha)*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha))/log(v)/log(u)/v/u / ( (-log(u))^(2*alpha)+2*(-log(u))^alpha*(-log(v))^alpha + (-log(v))^(2*alpha)) } if (Type == 5) { c.uv = (a*exp(a*(1 + u + v))*(-1 + exp(a)))/(exp(a) - exp(a + a*u) + exp(a*(u + v)) - exp(a + a*v))^2 } if (Type == 6) { c.uv = (1 - u)^(-1 + a)*(a - (-1 + (1 - u)^a)*(-1 + (1 - v)^a)) * ((1 - u)^a + (1 - v)^a - (1 - u)^a * (1 - v)^a)^(-2 + a^(-1)) * (1 - v)^(-1 + a) } if (Type == 7) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 7 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 8) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 8 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 9) { c.uv = (1 - a - a*log(v) + a*log(u)*(-1 + a*log(v))) / exp(a*log(u)*log(v)) } if (Type == 10) { c.uv = (2 - v^a + u^a*(-1 + v^a))^(-2 - a^(-1)) * (4 - 2*v^a + u^a*(-2 - (-1 + a)*v^a)) } if (Type == 11) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 11 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 12) { c.uv = ((-1+u^(-1))^a*(-1+a+((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1)+a*((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1))*((-1+u^(-1))^a + (-1+v^(-1))^a)^(-2+a^(-1))*(-1+v^(-1))^a)/ ((-1+u)*u*(1+((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1))^3*(-1+v)*v) } if (Type == 13) { c.uv = (exp(1 - (-1 + (1 - log(u))^a + (1 - log(v))^a)^a^(-1)) * (1 - log(u))^(-1 + a)*(-1 + a + (-1 + (1 - log(u))^a + (1 - log(v))^a)^a^(-1))*(-1 + (1 - log(u))^a + (1 - log(v))^a)^(-2 + a^(-1)) * (1 - log(v))^(-1 + a))/(u*v) } if (Type == 14) { c.uv = ((-1+u^(-a^(-1)))^a*(-1+v^(-a^(-1)))^a * ((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^(-2+a^(-1)) * (1+((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^a^(-1))^(-2-a) * (-1+a+2*a*((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^a^(-1))) / (a*u*(-1+u^a^(-1))*v*(-1+v^a^(-1))) } if (Type == 15) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 15 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 16) { c.uv = (2*a*(a^2 + u^2*v^2 + a*(u^2 + v^2))) / (sqrt(4*a + (-1 + u - a*(-1 + u^(-1) + v^(-1)) + v)^2) * (u^2*v^2*(-1 + u + v)^2 + a^2*(u + v - u*v)^2 + 2*a*u*v*(u^2*(-1 + v) - (-1 + v)*v + u*(1 - v + v^2)))) } if (Type == 17) { c.uv = (2^a*((-1 + 2^a)*a*(1 + u)^a*(1 + v)^a + 2^a*(-1 + (1 + u)^a) * (-1 + (1 + v)^a)))/((1 + u)*(1 + v)*(2^a - 2^a*(1 + u)^a - 2^a*(1 + v)^a + (1 + u)^a*(1 + v)^a)^2 * (1 + ((-1 + (1 + u)^(-a)) * (-1 + (1 + v)^(-a))) / (-1 + 2^(-a)))^a^(-1)) } if (Type == 18) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 18 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 19) { c.uv = (a^3*exp(a*(u^(-1) + v^(-1)))*(2 + log(-exp(a) + exp(a/u) + exp(a/v))))/((-exp(a) + exp(a/u) + exp(a/v))^2*u^2*v^2*log(-exp(a) + exp(a/u) + exp(a/v))^3) } if (Type == 20) { c.uv = (exp(u^(-a) + v^(-a))*u^(-1 - a)*v^(-1 - a) * log(-exp(1) + exp(u^(-a)) + exp(v^(-a)))^(-2 - a^(-1)) * (1 + a + a*log(-exp(1) + exp(u^(-a)) + exp(v^(-a))))) / (-exp(1) + exp(u^(-a)) + exp(v^(-a)))^2 } if (Type == 21) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 21 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 22) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 22 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } # Replace NAs: # c.uv[is.na(c.uv)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(c.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .darchmPerspSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density # FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) theta = .sliderMenu(no = 11) phi = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (1:(N-1))/N) D = .darchm1Copula(u = uv, alpha = alpha, type = as.character(Copula), output = "list") persp(D, theta = theta, phi = phi, col = "steelblue", shade = 0.5, ticktype = "detailed", cex = 0.5, xlab = "u", ylab = "v", zlab = "C(u,v)" ) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: B = 5 C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.1, 8) plot.names = c("Plot - theta", "... phi") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, -180, 0), maxima = c( 22, 100, U, 180, 360), resolutions = c( 1, 10, V, 1, 1), starts = c( 1, 20, A, -40, 30)) } # ------------------------------------------------------------------------------ .darchmContourSlider = function(B = 10) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively perspective plots of density #FUNCTION: # Graphic Frame: par(mfrow = c(1, 1)) # Internal Function: refresh.code = function(...) { # Sliders: Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) Copula = as.integer(.sliderMenu(no = 1)) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) n.lev = .sliderMenu(no = 11) n.col = .sliderMenu(no = 12) # Skip: if (Copula == 11) if (alpha == 0.5) return(invisible()) if (Copula == 13) if (alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "[-1|Inf)", "[1|Inf)", "[-1|1)", "(-Inf|Inf)", "(0|1]", "(0|0.5]", "(0|Inf)", "[2|Inf)")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Tau/Rho: Tau = round(approx(.ALPHA[, Copula], .TAU[, Copula], xout = alpha)$y, digits = 3) Rho = round(approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y, digits = 3) # Title: Names = c( "- Clayton", "", "- Ali-Mikhail-Hag", "- Gumbel-Hougard", "- Frank", "- Joe-Frank", "", "", "- Gumbel-Barnett", "", "", "", "", "", "- Genest-Ghoudi", "", "", "", "", "", "", "") Title = paste("Archimedean Copula No:", as.character(Copula), Names[Copula], "\n", RANGE, " alpha =", as.character(alpha), " tau =", as.character(Tau), " rho =", as.character(Rho)) # Plot: uv = grid2d(x = (1:(N-1)/N)) D = .darchm1Copula(u = uv, alpha = alpha, type = as.character(Copula), output = "list") image(D, xlim = c(0, 1), ylim = c(0,1), col = heat.colors(n.col) ) contour(D, xlab = "u", ylab = "v", nlevels = n.lev, add = TRUE) title(main = Title) # Reset Frame: par(mfrow = c(1, 1)) } # Open Slider Menu: B = 5 C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, B, 1, B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.1, 8) plot.names = c("Plot - levels", "... colors") .sliderMenu(refresh.code, names = c("Copula", "N", C, plot.names), minima = c( 1, 10, L, 10, 12), maxima = c( 22, 100, U, 100, 256), resolutions = c( 1, 10, V, 10, 1), starts = c( 1, 30, A, 30, 64)) } ################################################################################ rgumbelCopula = function(n = 100, alpha = 2) { # A function implemented by Diethelm Wuertz # Description: # Generates fast gumbel random variates # FUNCTION: # Stable RVs: dim = 2 theta <- runif(n, 0, pi) w <- rexp(n) b = 1/alpha a <- sin((1-b)*theta)*(sin(b*theta))^(b/(1-b)) / (sin(theta))^(1/(1-b)) fr = (a/w)^((1-b)/b) fr <- matrix(fr, nrow = n, ncol = dim) val <- matrix(runif(dim * n), nrow = n) s = -log(val)/fr # Bivariate Gumbel RVs: ans = exp(-s^(1/alpha) ) # Return Value: ans } # ------------------------------------------------------------------------------ pgumbelCopula = function(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes bivariate Gumbel copula probability # FUNCTION: # Bivariate Gumbel Probability: ans = parchmCopula (u, v, alpha, type = "4", output, alternative = FALSE) # Return Value: ans } # ------------------------------------------------------------------------------ dgumbelCopula = function(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes bivariate Gumbel copula density # FUNCTION: # Bivariate Gumbel Density: ans = darchmCopula (u, v, alpha, type = "4", output, alternative = FALSE) # Return Value: ans } ################################################################################ fCopulae/R/ArchimedeanModelling.R0000644000176000001440000000666111370220745016431 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER FITTING: # archmCopulaSim Simulates bivariate elliptical copula # archmCopulaFit Fits the paramter of an elliptical copula ################################################################################ ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER FITTING: # archmCopulaSim Simulates bivariate elliptical copula # archmCopulaFit Fits the paramter of an elliptical copula archmCopulaSim = function (n, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Simulates bivariate elliptical Copula # Match Arguments: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) alpha = archmParam(type)$param # Random Variates: ans = rarchmCopula(n = n, alpha = alpha, type = type) # Control: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ archmCopulaFit = function(u, v = NULL, type = archmList(), ...) { # A function implemented by Diethelm Wuertz # Description: # Fits the paramter of an elliptical copula # Note: # The upper limit for nu is 100 # FUNCTION: # Match Arguments: type = match.arg(type) Type = as.integer(type) # Settings: U = u V = v if (is.list(u)) { U = u[[1]] V = u[[2]] } if (is.matrix(u)) { U = u[, 1] V = u[, 2] } # Estimate Rho from Kendall's tau for all types of Copula: alpha = archmParam(type)$param # Estimate Copula: fun = function(x, type, U, V) { -mean( log(darchmCopula(u = U, v = V, alpha = x, type = type)) ) } range = archmRange(type) fit = nlminb(start = alpha, objective = fun, lower = range[1], upper = range[2], type = type, U = U, V = V, ...) # Return Value: fit } ################################################################################ fCopulae/R/ArchimedeanGenerator.R0000644000176000001440000023071311370220745016442 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER: # archmList Returns list of implemented Archimedean copulae # archmParam Sets Default parameters for an Archimedean copula # archmRange Returns the range of valid alpha values # archmCheck Checks if alpha is in the valid range # FUNCTION: ARCHIMEDEAN COPULAE PHI GENERATOR: # Phi Computes Archimedean Phi, inverse and derivatives # PhiSlider Displays interactively generator function # .Phi Computes Archimedean generator Phi # .Phi0 Utility Function # .PhiFirstDer Computes first derivative of Phi # .PhiSecondDer Computes second derivative of Phi # .invPhi Computes inverse of Archimedean generator # .invPhiFirstDer Computes first derivative of inverse Phi # .invPhiSecondDer Computes second derivative of inverse Phi # FUNCTION: ARCHIMEDEAN DENSITY K GENERATOR: # Kfunc Computes Archimedean Density Kc and its Inverse # KfuncSlider Displays interactively the density and concordance # .Kfunc Computes Density for Archimedean Copulae # .invK Computes Inverse of Density # .invK2 Utility Function # .ALPHA Utility Function # .TAU Utility Function # .RHO Utility Function ################################################################################ ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PARAMETER: # archmList Returns list of implemented Archimedean copulae # archmParam Sets default parameters for an Archimedean copula # archmCheck Checks if alpha is in the valid range # archmRange Returns the range of valid alpha values archmList = function() { # A function implemented by Diethelm Wuertz # Description: # Returns list of implemented Archimedean copulae # Compose List: ans = paste(1:22) # Return Value: ans } # ------------------------------------------------------------------------------ archmParam = function(type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Sets default parameters for Archimedean copulae # Arguments: # type - a character string or integer value naming the copula. # By default the first copula will be chosen. # Value: # returns a list with two elements, 'param' sets the parameters # which may be a vector, 'range' the range with minimum and # maximum values for each of the parameters. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Parameter Values: B = Inf lower=c(-1, 1,-1, 1,-B, 1, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0,-B, 2, 0, 0, 1, 0) upper=c( B, B, 1, B, B, B, 1, B, 1, 1,.5, B, B, B, B, B, B, B, B, B, B, 1) Alpha=c( 1, 2,.5, 2, 1, 2, .5, 2,.5,.5,.2, 2, 1, 2, 2, 1,.5, 3, 1, 1, 2,.5) # Parameter List: ans = list(copula = type) ans$param = c(alpha = Alpha[Type]) ans$range = c(lower = lower[Type], upper = upper[Type]) # Return Value: ans } # ------------------------------------------------------------------------------ archmRange = function(type = archmList(), B = Inf) { # A function implemented by Diethelm Wuertz # Description: # Returns the range of valid alpha values # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Range: lower = c(-1, 1,-1, 1,-B, 1, 0, 1, 0, 0, 0, 1, 0, 1, 1, 0,-B, 2, 0, 0, 1, 0) upper = c( B, B, 1, B, B, B, 1, B, 1, 1,.5, B, B, B, B, B, B, B, B, B, B, 1) # Return Value: ans = cbind(lower[Type], upper[Type]) rownames(ans) = type colnames(ans) = c("lower", "upper") ans } # ------------------------------------------------------------------------------ archmCheck = function(alpha, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Checks if alpha is in the valid range # FUNCTION: # Type: type = match.arg(type) # Check: ans = TRUE range = as.vector(archmRange(type)) if (alpha < range[1] | alpha > range[2]) { print(c(alpha = alpha)) print(c(range = range)) stop("alpha is out of range") } # Return Value: invisible(TRUE) } ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PHI GENERATOR: # Phi Computes Archimedean Phi, inverse and derivatives # PhiSlider Displays interactively generator function # .Phi Computes Archimedean generator Phi # .Phi0 Utility Function # .PhiFirstDer Computes first derivative of Phi # .PhiSecondDer Computes second derivative of Phi # .invPhi Computes inverse of Archimedean generator # .invPhiFirstDer Computes first derivative of inverse Phi # .invPhiSecondDer Computes second derivative of inverse Phi Phi = function(x, alpha = NULL, type = archmList(), inv = FALSE, deriv = paste(0:2)) { # A function implemented by Diethelm Wuertz # Type: type = match.arg(type) Type = as.integer(type) deriv = match.arg(deriv) # Default alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Phi Generator: if (inv) { if (deriv == "0") { ans = .invPhi(x, alpha, type) names(ans) = "invPhi" } if (deriv == "1") { ans = .invPhiFirstDer(x, alpha, type) names(ans) = "invPhiFirstDer" } if (deriv == "2") { ans = .invPhiSecondDer(x, alpha, type) names(ans) = "invPhiSecondDer" } } else { if (deriv == "0") { ans = .Phi(x, alpha, type) names(ans) = "Phi" } if (deriv == "1") { ans = .PhiFirstDer(x, alpha, type) names(ans) = "PhiFirstDer" } if (deriv == "2") { ans = .PhiSecondDer(x, alpha, type) names(ans) = "PhiSecondDer" } } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame(alpha = alpha, type = type, inv = inv, deriv = deriv, row.names = "") # Return Value: ans } # ------------------------------------------------------------------------------ PhiSlider = function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively the dependence function # FUNCTION: # Graphic Frame: par(mfcol = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Copula = as.integer(.sliderMenu(no = 1)) Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) # Skip: if (Copula == 13 & alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "-1|Inf", "1|Inf", "-1|1", "-Inf|inf", "0|1", "0|0.5", "0|Inf", "2|Inf")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Plot phi: x = (0:N)/N Title = paste("Generator Phi - Copula No:", as.character(Copula), "\nalpha = ", as.character(alpha), " Strict = ", strict, limitTitle) phi.0 = .Phi(x = 0, alpha = alpha, type = as.character(Copula)) y = .Phi(x = x, alpha = alpha, type = as.character(Copula)) x = x[y < 1e6] y = y[y < 1e6] if (is.finite(y[1])) ylim = c(0, y[1]) else ylim = c(0, y[2]) plot(x = x, y = y, type = "l", ylim = ylim, main = Title[1], xlab = "t", ylab = paste("Phi |", RANGE)) if (N < 100) points(x = x, y = y, pch = 19, cex = 0.5) y.inv = .invPhi(x = y, alpha = alpha, type = as.character(Copula)) lines(x = y.inv, y = y, col = "red", lty = 3) abline(h = 0, lty = 3) points(0, phi.0, col = "red", pch = 19) # Plot phi first and second Derivative: y1 = .PhiFirstDer(x = x, alpha = alpha, type = as.character(Copula)) y2 = .PhiSecondDer(x = x, alpha = alpha, type = as.character(Copula)) r1 = max(abs(y1[is.finite(y1)])) r2 = max(abs(y2[is.finite(y2)])) if (r2 == 0) r2 = 1 plot(x = x, y = y1/r1, ylim = c(-1, 1), type = "l", xlab = "t", ylab = "Derivatives", main = "Phi first and second Derivative", col = "blue") if (N < 100) points(x = x, y = y1/r1, pch = 19, cex = 0.5) lines(x = x, y = y2/r2, col = "red") if (N < 100) points(x = x, y = y2/r2, pch = 19, cex = 0.5) abline(h = 0, lty = 3) mtext("First ", 4, col = "blue", cex = 0.75) mtext(" Second", 4, col = "red ", cex = 0.75) mtext(paste("x", as.character(round(r1, digits = 2))), 1, line = -2, col = "blue", cex = 0.75) mtext(paste("x", as.character(round(r2, digits = 2))), 3, line = -2, col = "red", cex = 0.75) # Plot invPhi: Title = paste( "Inverse Phi\n Phi(0) =", as.character(round(phi.0, digits = 3))) plot(x = y, y = y.inv, type = "l", main = Title, xlab = paste("Phi |", RANGE), ylab = "t") if (N < 100) points(x = y, y = y.inv, pch = 19, cex = 0.5) abline(h = 0, lty = 3) points(phi.0, 0, col = "red", pch = 19) # Plot invPhi first & second Derivative: y = y[y < .Phi0(alpha, Copula)] Title = "Inverse Phi 1st Derivative" y1.inv = .invPhiFirstDer(x = y, alpha = alpha, type = as.character(Copula)) y2.inv = .invPhiSecondDer(x = y, alpha = alpha, type = as.character(Copula)) r1 = max(abs(y1.inv[is.finite(y1.inv)])) r2 = max(abs(y2.inv[is.finite(y2.inv)])) if (r2 == 0) r2 = 1 plot(x = y, y = y1.inv/r1, ylim = c(-1, 1), type = "l", xlim = range(y), xlab = paste("Phi |", RANGE), ylab = "dewrivatives", main = "Inv Phi first and second Derivative", col = "blue") if (N < 100) points(x = y, y = y1.inv/r1, pch = 19, cex = 0.5) lines(x = y, y = y2.inv/r2, col = "red") if (N < 100) points(x = y, y = y2.inv/r2, pch = 19, cex = 0.5) abline(h = 0, lty = 3) mtext("First ", 4, col = "blue", cex = 0.75) mtext(" Second", 4, col = "red ", cex = 0.75) mtext(paste("x", as.character(round(r1, digits = 2))), 1, line = -2, col = "blue", cex = 0.75) mtext(paste("x", as.character(round(r2, digits = 2))), 3, line = -2, col = "red", cex = 0.75) # Reset Frame: par(mfcol = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 10) C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c(3*B/5, B, 1, B, 1, 0.5, B/2, 2*B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 20) .sliderMenu(refresh.code, names = c("Copula", "N", C), minima = c( 1, 10, L), maxima = c( 22, 1000, U), resolutions = c( 1, 10, V), starts = c( 1, 100, A)) } # ------------------------------------------------------------------------------ .Phi = function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Archimedean generator "phi" # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # As listed in Nelsen: N = length(x) Type = "NA" if (type == 1) if (alpha == -1) Type = "W" else if (alpha == 0) Type = "Pi" else if (alpha == 1) Type = "L" else f = 1/alpha*(x^(-alpha)-1) # Clayton if (type == 2) if (alpha == 1) Type = "W" else f = (1-x)^alpha if (type == 3) if (alpha == 0) Type = "Pi" else if (alpha == 1) Type = "L" else f = log((1-alpha*(1-x))/x) # Ali-Mikhail-Haq if (type == 4) if (alpha == 1) Type = "Pi" else f = (-log(x))^alpha # Gumbel-Hougard if (type == 5) if (alpha == 0) Type = "Pi" else f = -log((exp(-alpha*x)-1)/(exp(-alpha)-1)) # Frank if (type == 6) if (alpha == 1) Type = "Pi" else f = -log(1-(1-x)^alpha) # Joe if (type == 7) if (alpha == 0) Type = "W" else if (alpha == 1) Type = "Pi" else f = -log(alpha*x+(1-alpha)) if (type == 8) if (alpha == 0) Type = "Pi" else f = (1-x)/(1+x*(alpha-1)) if (type == 9) if (alpha == 0) Type = "Pi" else f = log(1-alpha*log(x)) # Gumbel-Barnett if (type == 10) if (alpha == 0) Type = "Pi" else f = log(2*x^(-alpha)-1) if (type == 11) if (alpha == 0) Type = "Pi" else f = log(2-x^alpha) if (type == 12) if (alpha == 1) Type = "L" else f = (1/x-1)^alpha if (type == 13) if (alpha == 1) Type = "Pi" else f = (1-log(x))^alpha-1 if (type == 14) if (alpha == 1) Type = "L" else f = (x^(-1/alpha)-1)^alpha if (type == 15) if (alpha == 1) Type = "W" else f = (1-x^(1/alpha))^alpha if (type == 16) if (alpha == 0) Type = "W" else f = (alpha/x+1)*(1-x) if (type == 17) if (alpha == -1) Type = "Pi" else f = -log(((1+x)^(-alpha)-1)/(2^(-alpha)-1)) if (type == 18) f = exp(alpha/(x-1)) if (type == 19) if (alpha == 0) Type = "L" else f = exp(alpha/x)-exp(alpha) if (type == 20) if (alpha == 0) Type = "Pi" else f = exp(x^(-alpha))-exp(1) if (type == 21) if (alpha == 1) Type = "W" else f = (1-(1-(1-x)^alpha)^(1/alpha)) if (type == 22) if (alpha == 0) Type = "Pi" else f = asin(1-x^alpha) if (Type == "Pi") f = -log(x) if (Type == "W") f = 1-x if (Type == "L") f = 1/x - 1 f[x == 0] = .Phi0(alpha, type) # Return Value: f } # ------------------------------------------------------------------------------ .Phi0 = function(alpha, type) { # A function implemented by Diethelm Wuertz # Phi(0): type = as.integer(type) if (type == 1) phi0 = if (alpha < 0) -1/alpha else Inf else if (type == 2) phi0 = 1 else if (type == 3) phi0 = Inf else if (type == 4) phi0 = Inf else if (type == 5) phi0 = Inf else if (type == 6) phi0 = Inf else if (type == 7) phi0 = if (alpha == 0) 1 else -log(1 - alpha) else if (type == 8) phi0 = 1 else if (type == 9) phi0 = Inf else if (type == 10) phi0 = Inf else if (type == 11) phi0 = if (alpha == 0) Inf else log(2) else if (type == 12) phi0 = Inf else if (type == 13) phi0 = Inf else if (type == 14) phi0 = Inf else if (type == 15) phi0 = 1 else if (type == 16) phi0 = if (alpha == 0) 1 else Inf else if (type == 17) phi0 = Inf else if (type == 18) phi0 = exp(-alpha) else if (type == 19) phi0 = Inf else if (type == 20) phi0 = Inf else if (type == 21) phi0 = 1 else if (type == 22) phi0 = if (alpha == 0) Inf else pi/2 # Return Value: phi0 } # ------------------------------------------------------------------------------ .PhiFirstDer = function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Derivative of Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # FUNCTION: # The functions were created by MAPLE: N = length(x) cType = "NA" if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else f1 = -x^(-alpha-1) if (Type == 2) if (alpha == 1) cType = "W" else f1 = -(1-x)^alpha*alpha/(1-x) if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else f1 = (alpha/x-(1-alpha*(1-x))/x^2)/(1-alpha*(1-x))*x if (Type == 4) if (alpha == 1) cType = "Pi" else f1 = (-log(x))^alpha*alpha/x/log(x) if (Type == 5) if (alpha == 0) cType = "Pi" else f1 = alpha*exp(-alpha*x)/(exp(-alpha*x)-1) if (Type == 6) if (alpha == 1) cType = "Pi" else f1 = -(1-x)^alpha*alpha/(1-x)/(1-(1-x)^alpha) if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) cType = "Pi" else f1 = -alpha/(alpha*x+1-alpha) if (Type == 8) if (alpha == 1) cType = "W" else f1 = -1/(1+x*(-1+alpha))-(1-x)/(1+x*(-1+alpha))^2*(-1+alpha) if (Type == 9) if (alpha == 0) cType = "Pi" else f1 = -alpha/x/(1-alpha*log(x)) if (Type == 10) if (alpha == 0) cType = "Pi" else f1 = -2*x^(-alpha)*alpha/x/(2*x^(-alpha)-1) if (Type == 11) if (alpha == 0) cType = "Pi" else f1 = -x^alpha*alpha/x/(2-x^alpha) if (Type == 12) if (alpha == 1) cType = "L" else f1 = -(1/x-1)^alpha*alpha/x^2/(1/x-1) if (Type == 13) if (alpha == 1) cType = "Pi" else f1 = -(1-log(x))^alpha*alpha/x/(1-log(x)) if (Type == 14) if (alpha == 1) cType = "L" else f1 = -(x^(-1/alpha)-1)^alpha*x^(-1/alpha)/x/(x^(-1/alpha)-1) if (Type == 15) if (alpha == 1) cType = "W" else f1 = -(1-x^(1/alpha))^alpha*x^(1/alpha)/x/(1-x^(1/alpha)) if (Type == 16) if (alpha == 0) cType = "W" else f1 = -alpha/x^2*(1-x)-alpha/x-1 if (Type == 17) if (alpha == -1) cType = "Pi" else f1 = (1+x)^(-alpha)*alpha/(1+x)/((1+x)^(-alpha)-1) if (Type == 18) f1 = -alpha/(-1+x)^2*exp(alpha/(-1+x)) if (Type == 19) if (alpha == 0) cType = "L" else f1 = -alpha/x^2*exp(alpha/x) if (Type == 20) if (alpha == 0) cType = "Pi" else f1 = -x^(-alpha)*alpha/x*exp(x^(-alpha)) if (Type == 21) if (alpha == 1) cType = "W" else f1 = -(1-(1-x)^alpha)^(-(-1+alpha)/alpha)*(1-x)^(-1+alpha) if (Type == 22) if (alpha == 0) cType = "Pi" else f1 = -x^(-1+alpha)*alpha/(2*x^alpha-x^(2*alpha))^(1/2) if (cType == "Pi") f1 = -1/x if (cType == "W") f1 = rep(-1, times = N) if (cType == "L") f1 = -1/x^2 # Return Value: f1 } # ------------------------------------------------------------------------------ .PhiSecondDer = function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Derivative of Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # FUNCTION: # The functions were created by MAPLE: a = alpha N = length(x) cType = "NA" if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else f2 = x^(-a-2)*a+x^(-a-2) if (Type == 2) if (alpha == 1) cType = "W" else f2 = (1-x)^(a-2)*a^2-(1-x)^(a-2)*a if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) Type = "L" else f2 = -1/x^2*(a-1)*(1-a+2*x)/(1-a+x)^2 if (Type == 4) if (alpha == 1) cType = "Pi" else f2 = a*((-log(x))^(a-2)*a+(-log(x))^(a-1)-(-log(x))^(a-2))/x^2 if (Type == 5) if (alpha == 0) cType = "Pi" else f2 = a^2*exp(-a*x)/(exp(-a*x)-1)^2 if (Type == 6) if (alpha == 1) cType = "Pi" else f2 = a*((1-x)^(a-2)*a-(1-x)^(a-2)+(1-x)^(2*a-2))/(-1+(1-x)^a)^2 if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) cType = "Pi" else f2 = alpha^2/(alpha*x+1-alpha)^2 if (Type == 8) if (alpha == 1) cType = "W" else f2 = 2*(a-1)*a/(1+a*x-x)^3 if (Type == 9) if (alpha == 0) cType = "Pi" else f2 = -a*(-1+a*log(x)+a)/x^2/(-1+a*log(x))^2 if (Type == 10) if (alpha == 0) cType = "Pi" else f2 = -2*a*(x^a*a-2+x^a)/(-2+x^a)^2/x^2 if (Type == 11) if (alpha == 0) cType = "Pi" else f2 = -a*(2*x^(a-2)*a-2*x^(a-2)+x^(2*a-2))/(-2+x^a)^2 if (Type == 12) if (alpha == 1) cType = "L" else f2 = -(-(x-1)/x)^a*a*(-a+2*x-1)/x^2/(x-1)^2 if (Type == 13) if (alpha == 1) cType = "Pi" else f2 = a*((1-log(x))^(a-2)*a+(1-log(x))^(a-1)-(1-log(x))^(a-2))/x^2 if (Type == 14) if (alpha == 1) cType = "L" else f2 = ((x^(-1/a)-1)^(a-2)*x^(-2*(a+1)/a)*a+(x^(-1/a)-1)^(a-1) * x^(-(1+2*a)/a)+(x^(-1/a)-1)^(a-1)*x^(-(1+2*a)/a) * a-(x^(-1/a)-1)^(a-2)*x^(-2*(a+1)/a))/a if (Type == 15) if (alpha == 1) cType = "W" else f2 = ((1-x^(1/a))^(a-2)*x^(-2*(a-1)/a)*a-(1-x^(1/a))^(a-1) * x^(-(-1+2*a)/a)+(1-x^(1/a))^(a-1)*x^(-(-1+2*a)/a) * a-(1-x^(1/a))^(a-2)*x^(-2*(a-1)/a))/a if (Type == 16) if (alpha == 0) cType = "W" else f2 = 2*a/x^3 if (Type == 17) if (alpha == -1) cType = "Pi" else f2 = a*((1+x)^(a-2)*a+2*(1+x)^(a-2)*a*x+(1+x)^(a-2)*a*x^2 - 1+(1+x)^(a-2)+2*(1+x)^(a-2)*x+(1+x)^(a-2)*x^2) / (-1+(1+x)^a)^2/(1+x)^2 if (Type == 18) f2 = a*exp(a/(x-1))*(2*x-2+a)/(x-1)^4 if (Type == 19) if (alpha == 0) cType = "L" else f2 = a*exp(a/x)*(2*x+a)/x^4 if (Type == 20) if (alpha == 0) cType = "Pi" else f2 = a*exp(x^(-a))*(x^(-a-2)*a+x^(-a-2)+x^(-2*a-2)*a) if (Type == 21) if (alpha == 1) cType = "W" else f2 = -(1-(1-x)^a)^(-(-1+2*a)/a)*(1-x)^(2*a-2) + (1-(1-x)^a)^(-(-1+a)/a)*(1-x)^(a-2)*a - (1-(1-x)^a)^(-(-1+a)/a)*(1-x)^(a-2) + (1-(1-x)^a)^(-(-1+2*a)/a)*(1-x)^(2*a-2)*a if (Type == 22) if (alpha == 0) cType = "Pi" else f2 = -a/x^2*(a*x^(2*a)-2*x^(2*a)+x^(3*a))/(2*x^a-x^(2*a))^(3/2) if (cType == "Pi") f2 = 1/x^2 if (cType == "W") f2 = rep(0, times = N) if (cType == "L") f2 = 2/x^3 # Return Value: f2 } # ------------------------------------------------------------------------------ .invPhi = function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes inverse of Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Inverse Generator: N = length(x) cType = "NA" if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv = exp(-log(1 + alpha*x)/alpha) if (Type == 2) if (alpha == 1) cType = "W" else finv = 1 - x^(1/alpha) if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv = (1-alpha) / (exp(x)-alpha) if (Type == 4) if (alpha == 1) cType = "Pi" else finv = exp(-x^(1/alpha)) if (Type == 5) if (alpha == 0) cType = "Pi" else finv = -log(1+exp(-x)*( exp(-alpha)-1 ) ) / alpha if (Type == 6) if (alpha == 1) cType = "Pi" else finv = 1 - (1 - exp(-x))^(1/alpha) if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) Type = "Pi" else finv = (1-exp(x)+alpha*exp(x))/alpha/exp(x) if (Type == 8) if (alpha == 1) cType = "W" else finv = (1-x) / ((alpha-1)*x+1) if (Type == 9) if (alpha == 0) cType = "Pi" else finv = exp((1-exp(x))/alpha) if (Type == 10) if (alpha == 0) cType = "Pi" else finv = ((1+exp(x))/2 )^(-1/alpha) if (Type == 11) if (alpha == 0) cType = "Pi" else finv = (2-exp(x))^(1/alpha) if (Type == 12) if (alpha == 1) cType = "L" else finv = 1/(1+x^(1/alpha)) if (Type == 13) if (alpha == 1) cType = "Pi" else finv = exp(1-(1+x)^(1/alpha)) if (Type == 14) if (alpha == 1) cType = "L" else finv = (1+x^(1/alpha))^(-alpha) if (Type == 15) if (alpha == 1) cType = "W" else finv = (1-x^(1/alpha))^alpha if (Type == 16) if (alpha == 0) cType = "W" else finv = (1-alpha-x)/2 + sqrt(((1-alpha-x)^2)/4+alpha) if (Type == 17) if (alpha == -1) cType = "Pi" else finv = (exp(-x)*(2^(-alpha)-1)+1)^(-1/alpha) - 1 if (Type == 18) finv = 1+alpha/log(x) if (Type == 19) if (alpha == 0) cType = "L" else finv = alpha / log(x+exp(alpha)) if (Type == 20) if (alpha == 0) cType = "Pi" else finv = exp( -log((log(x+exp(1))))/alpha) if (Type == 21) if (alpha == 1) cType = "W" else finv = 1-(1-(1-x)^alpha)^(1/alpha) if (Type == 22) if (alpha == 0) cType = "Pi" else finv = (1-sin(x))^(1/alpha) if (cType == "Pi") finv = exp(-x) if (cType == "W") finv = 1 - x if (cType == "L") finv = 1 / (x+1) # Large x Limit: finv[which(x >= .Phi0(alpha, type))] = 0 # Return Value: finv } # ------------------------------------------------------------------------------ .invPhiFirstDer = function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes first Derivative of inverse Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Generator: N = length(x) cType = "NA" a = alpha y = x ln = log if (Type == 1) if (alpha == -1) cType = "W" else if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv1 = -(1+y*a)^(-(a+1)/a) if (Type == 2) if (alpha == 1) cType = "W" else finv1 = -y^(-(a-1)/a)/a if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) cType = "L" else finv1 = (a-1)/(exp(y)-1)^2*exp(y) if (Type == 4) if (alpha == 1) cType = "Pi" else finv1 = -y^(-(a-1)/a)/a*exp(-y^(1/a)) if (Type == 5) if (alpha == 0) cType = "Pi" else finv1 = (-1+exp(a))/(-1+exp(a)-exp(y+a))/a if (Type == 6) if (alpha == 1) cType = "Pi" else finv1 = -exp(-(-ln(exp(y)-1)+y)/a)/(exp(y)-1)/a if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) Type = "Pi" else finv1 = (-exp(y)+a*exp(y))/a/exp(y)-(1-exp(y)+a*exp(y))/a/exp(y) if (Type == 8) if (alpha == 1) cType = "W" else finv1 = -a/(1+y*a-y)^2 if (Type == 9) if (alpha == 0) cType = "Pi" else finv1 = -1/a*exp((y*a-exp(y)+1)/a) if (Type == 10) if (alpha == 0) cType = "Pi" else finv1 = -1/(exp(y)+1)/a*exp((y*a+ln(2)-ln(exp(y)+1))/a) if (Type == 11) if (alpha == 0) cType = "Pi" else finv1 = -(-exp(y)+2)^(-(a-1)/a)/a*exp(y) if (Type == 12) if (alpha == 1) cType = "L" else finv1 = -1/(y^(1/a)+1)^2*y^(-(a-1)/a)/a if (Type == 13) if (alpha == 1) cType = "Pi" else finv1 = -(1+y)^(-(a-1)/a)/a*exp(-(1+y)^(1/a)+1) if (Type == 14) if (alpha == 1) cType = "L" else finv1 = -(y^(1/a)+1)^(-a-1)*y^(-(a-1)/a) if (Type == 15) if (alpha == 1) cType = "L" else finv1 = -(-y^(1/a)+1)^(a-1)*y^(-(a-1)/a) if (Type == 16) if (alpha == 0) cType = "W" else finv1 = -1/2+1/4/(a^2+2*a+2*a*y+1-2*y+y^2)^(1/2)*(2*a-2+2*y) if (Type == 17) if (alpha == -1) cType = "Pi" else finv1 = -(2^(-a)-1+exp(y))^(-1/a)*exp(1/a*y) * (-1+2^a)/a/(1-2^a+exp(y)*2^a) if (Type == 18) finv1 = -a/ln(y)^2/y if (Type == 19) if (alpha == 0) cType = "L" else finv1 = -a/ln(exp(a)+y)^2/(exp(a)+y) if (Type == 20) if (alpha == 0) cType = "Pi" else finv1 = -ln(exp(1)+y)^(-(a+1)/a)/a/(exp(1)+y) if (Type == 21) if (alpha == 1) cType = "W" else finv1 = -exp((log(1-y)*a^2+log(-(1-y)^a+1))/a)/(-1+y)/((1-y)^a-1) if (Type == 22) if (alpha == 0) cType = "Pi" else finv1 = -cos(y)*(1-sin(y))^(-(-1+a)/a)/a if (cType == "Pi") finv1 = -exp(-x) if (cType == "W") finv1 = rep(-1, times = N) if (cType == "L") finv1 = -1 / (x+1)^2 # Large x Limit: finv1[which(x >= .Phi0(a, type))] = 0 # Return Value: finv1 } # ------------------------------------------------------------------------------ .invPhiSecondDer = function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes first Derivative of inverse Archimedean generator. # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Generator: N = length(x) cType = "NA" a = alpha y = x ln = log if (Type == 1) if (alpha == 0) finv2 = exp(-y) else finv2 = finv2 = (1+y*a)^(-(2*a+1)/a)*(a+1) if (Type == 2) if (alpha == 1) cType = "W" else finv2 = y^(-(2*a-1)/a)*(a-1)/a^2 if (Type == 3) if (alpha == 0) cType = "Pi" else if (alpha == 1) Type = "L" else finv2 = -(a-1)*exp(y)*(exp(y)+1)/(exp(y)-1)^3 if (Type == 4) if (alpha == 1) cType = "Pi" else finv2 = exp(-y^(1/a))*(y^(-(2*a-1)/a)*a-y^(-(2*a-1)/a) + y^(-2*(a-1)/a))/a^2 if (Type == 5) if (alpha == 0) cType = "Pi" else finv2 = (-1+exp(a))/(-1+exp(a)-exp(y+a))^2/a*exp(y+a) if (Type == 6) if (alpha == 1) cType = "Pi" else finv2 = (-exp(-(-ln(exp(y)-1)+y)/a) + exp((ln(exp(y)-1)-y+y*a)/a)*a) / (exp(y)-1)^2/a^2 if (Type == 7) if (alpha == 0) cType = "W" else if (alpha == 1) Type = "Pi" else finv2 = -(-exp(y)+a*exp(y))/a/exp(y)+(1-exp(y)+a*exp(y))/a/exp(y) if (Type == 8) if (alpha == 1) cType = "W" else finv2 = 2*a/(1+y*a-y)^3*(a-1) if (Type == 9) if (alpha == 0) cType = "Pi" else finv2 = -1/a^2*(a-exp(y))*exp((y*a-exp(y)+1)/a) if (Type == 10) if (alpha == 0) cType = "Pi" else finv2 = -(exp((y*a+ln(2)-ln(exp(y)+1))/a)*a-exp((2*y*a+ln(2) - ln(exp(y)+1))/a))/(exp(y)+1)^2/a^2 if (Type == 11) if (alpha == 0) cType = "Pi" else finv2 = -exp(y)*((-exp(y)+2)^(-(2*a-1)/a)*exp(y)*a - (-exp(y)+2)^(-(2*a-1)/a)*exp(y)+(-exp(y)+2)^(-(a-1)/a)*a)/a^2 if (Type == 12) if (alpha == 1) cType = "L" else finv2 = (y^(-2*(a-1)/a)+y^(-2*(a-1)/a)*a+y^(-(2*a-1)/a)*a - y^(-(2*a-1)/a))/(y^(1/a)+1)^3/a^2 if (Type == 13) if (alpha == 1) cType = "Pi" else finv2 = exp(-(1+y)^(1/a)+1)*((1+y)^(1/a)*a-(1+y)^(1/a) + (1+y)^(-2*(a-1)/a)+2*(1+y)^(-2*(a-1)/a)*y + (1+y)^(-2*(a-1)/a)*y^2)/a^2/(1+2*y+y^2) if (Type == 14) if (alpha == 1) cType = "L" else finv2 = ((y^(1/a)+1)^(-a-2)*y^(-2*(a-1)/a)*a + (y^(1/a)+1)^(-a-2)*y^(-2*(a-1)/a)+(y^(1/a)+1)^(-a-1) * y^(-(2*a-1)/a)*a-(y^(1/a)+1)^(-a-1)*y^(-(2*a-1)/a))/a if (Type == 15) if (alpha == 1) cType = "L" else finv2 = (a-1)*((-y^(1/a)+1)^(a-2)*y^(-2*(a-1)/a) + (-y^(1/a)+1)^(a-1)*y^(-(2*a-1)/a))/a if (Type == 16) if (alpha == 0) cType = "W" else finv2 = 2*a/(a^2+2*a+2*a*y+1-2*y+y^2)^(3/2) if (Type == 17) if (alpha == -1) cType = "Pi" else finv2 = (2^(-a)-1+exp(y))^(-1/a)*(exp(y*(a+1)/a) - 2^(a+1)*exp(y*(a+1)/a)+exp(y*(a+1)/a)*4^a + exp(1/a*y)*2^(-a)-3*exp(1/a*y)+3*exp(1/a*y)*2^a - exp(1/a*y)*4^a-exp(y*(a+1)/a)*a+2^(a+1) * exp(y*(a+1)/a)*a- exp(y*(2*a+1)/a)*a*2^a - exp(y*(a+1)/a)*a*4^a+exp(y*(2*a+1)/a)*a*4^a)/a^2/(2^(-a)-1 + exp(y))/(1-2^a+exp(y)*2^a)^2 if (Type == 18) finv2 = a*(2+ln(y))/ln(y)^3/y^2 if (Type == 19) if (alpha == 0) cType = "L" else finv2 = a*(2+ln(exp(a)+y))/ln(exp(a)+y)^3/(exp(a)+y)^2 if (type == 20) if (alpha == 0) cType = "Pi" else finv2 = (ln(exp(1)+y)^(-(2*a+1)/a)*a + ln(exp(1)+y)^(-(2*a+1)/a) + ln(exp(1)+y)^(-(a+1)/a)*a)/a^2/(exp(1)+y)^2 if (Type == 21) if (alpha == 1) cType = "W" else finv2 = -(-(1-y)^a+1)^(1/a)*((1-y)^(2*a)-(1-y)^a - a*(1-y)^(2*a)+a*(1-y)^a+(1-y)^(2*a-2)*a - 2*(1-y)^(2*a-2)*a*y+(1-y)^(2*a-2)*a*y^2 -( 1-y)^(2*a-2)+2*(1-y)^(2*a-2)*y-(1-y)^(2*a-2)*y^2) / (-1+y)^2/(-(1-y)^(2*a)+2*(1-y)^a-1) if (Type == 22) if (alpha == 0) cType = "Pi" else finv2 = -(1-sin(y))^(1/a)*(cos(y)^2 + a*sin(y)-2*sin(y)+a-2)/cos(y)^2/a^2 if (cType == "Pi") finv2 = exp(-x) if (cType == "W") finv2 = rep(0, times = N) if (cType == "L") finv2 = 2 / (x+1)^3 # Large x Limit: finv2[which(x>=.Phi0(a, type))] = 0 # Return Value: finv2 } ################################################################################ # FUNCTION: ARCHIMEDEAN DENSITY K GENERATOR: # Kfunc Computes Archimedean Density Kc and its Inverse # KfuncSlider Displays interactively the density and concordance # .Kfunc Computes Density for Archimedean Copulae # .invK Computes Inverse of Density # .invK2 Utility Function # .ALPHA Utility Function # .TAU Utility Function # .RHO Utility Function Kfunc = function(x, alpha = NULL, type = archmList(), inv = FALSE, lower = 1.0e-8) { # A function implemented by Diethelm Wuertz # Description: # Computes density and its inverse for Archimedean Copulae # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Default alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Density or its inverse: if (!inv) { ans = .Kfunc(x, alpha, type) names(ans)<-"Kfunc" } else { ans = .invK(x, alpha, type, lower) names(ans)<-"invK" } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame(alpha = alpha, type = type, inv = inv, lower = lower, row.names = "") # Return Value: ans } # ------------------------------------------------------------------------------ KfuncSlider = function(B = 5) { # A function implemented by Diethelm Wuertz # Description: # Displays interactively the density and concordance # FUNCTION: # Graphic Frame: par(mfcol = c(2, 2), cex = 0.7) # Internal Function: refresh.code = function(...) { # Startup Counter: .counter <- getRmetricsOptions(".counter") + 1 setRmetricsOptions(.counter = .counter) if (.counter < 10) return () # Sliders: Copula = as.integer(.sliderMenu(no = 1)) Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) No = Counter[Copula] N = .sliderMenu(no = 2) alpha = .sliderMenu(no = No+2) # Skip: if (Copula == 13 & alpha == 0) return(invisible()) # Do we have a strict Copula? strict = c( "Yes","No","Yes","Yes","Yes","Yes","No","No","Yes","Yes", "No","Yes","Yes","Yes","No","Yes","Yes","No","Yes","Yes", "No","Yes")[Copula] if (alpha < 0 & Copula == 1) strict[1] = "No" if (alpha == 0 & Copula == 16) strict[16] = "No" # What is the Range? RANGE = c( "-1|Inf", "1|Inf", "-1|1", "-Inf|inf", "0|1", "0|0.5", "0|Inf", "2|Inf")[No] # Which one is the Limit Copula? limitTitle = rep("NA", times = 22) if (alpha == -1) limitTitle = c( "W ", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "Pi", "NA", "NA", "NA", "NA", "NA") if (alpha == 0) limitTitle = c( "Pi", "NA", "Pi", "NA", "Pi", "NA", "W ", "NA", "Pi", "Pi", "Pi", "NA", "NA", "NA", "NA", "W ", "NA", "NA", "L ", "Pi", "NA", "Pi") if (alpha == 1) limitTitle = c( "L ", "W ", "L ", "Pi", "NA", "Pi", "Pi", "W ", "NA", "NA", "NA", "L ", "Pi", "L ", "W ", "NA", "NA", "NA", "NA", "NA", "W ", "NA") limitTitle = limitTitle[Copula] if (limitTitle == "NA") { limitTitle = " " } else { limitTitle = paste(" Copula = ", limitTitle[1]) } # Plot 1 - Kfunc: x = (0:N)/N y = .Kfunc(x = x, alpha = alpha, type = as.character(Copula)) plot(x = x, y = y, ylim = c(0, 1), type = "l", xlab = "t", ylab = "K") title(main = paste("K - Archimedean Copula No:", as.character(Copula), "\nalpha = ", as.character(alpha), " Strict = ", strict, limitTitle)) if (N < 100) points(x = x, y = y, pch = 19, cex = 0.5) y10 = .Kfunc(x = (0:10)/10, alpha = alpha, type = as.character(Copula)) invK10 = .invK2(y10, alpha = alpha, type = as.character(Copula)) points(invK10, y10, col = "red") text(x = 0.8, y = 0.075, labels = "Test: invK[invK]", col = "red") # Plot 2 - archmTau: tau = .archmTau(alpha = alpha, type = as.character(Copula)) rho = approx(.ALPHA[, Copula], .RHO[, Copula], xout = alpha)$y plot(x = .ALPHA[, Copula], y = .TAU[, Copula], ylim = c(-1, 1), type = "l", col = "red", xlab = paste("alpha: ", RANGE, sep = ""), ylab = "Tau") # points(x = .ALPHA[, Copula], y = .TAU[, Copula], pch = 19, cex = 0.5) lines(x = .ALPHA[, Copula], y = .RHO[, Copula], col = "blue") # points(x = .ALPHA[, Copula], y = .RHO[, Copula], pch = 19, cex = 0.5) points(x = alpha, y = tau, pch = 19, col = "red") abline(h = .archmTauRange(type = as.character(Copula))[1], lty =3, col = "steelblue") abline(h = .archmTauRange(type = as.character(Copula))[2], lty =3, col = "steelblue") points(x = alpha, y = rho, col = "blue", pch = 19) mtext("rho ", 4, col = "blue", cex = 0.75) mtext(" tau", 4, col = "red ", cex = 0.75) title(main = paste("Concordance Measures", "\ntau = ", as.character(round(tau, digits = 2)), "rho = ", as.character(round(rho, digits = 2)) ) ) plot(x = y, y = x, xlim = c(0, 1), type = "l", xlab = "K", ylab = "t") title(main = "Inverse K") # Plot 3 - lambda U: # xTail = 1 - (1/2)^(1:20) # Tail = .archmTail(alpha = alpha, type = as.character(Copula)) # plot(x = xTail, y = Tail$lambdaU.Cuv, col = "blue", # xlim = c(0, 1), ylim = c(0, 1), main = "Tail Dependence") # points(x = xTail, y = Tail$lambdaU.Phi, col = "red", pch = 3) # Rho: # Rho = NULL # for ( a in Alpha) # Rho = c(Rho, archmRho(alpha = a, type = as.character(Copula))) # lines(x = Alpha, y = Rho, type = "l", col = "blue") # rho = archmRho(alpha = alpha, type = as.character(Copula)) # points(x = alpha, y = rho, col = "red", pty = 19) # plot(rnorm(100)) # plot(rnorm(100)) # Reset Frame: par(mfcol = c(2, 2), cex = 0.7) } # Open Slider Menu: setRmetricsOptions(.counter = 0) C1 = "1: [-1,Inf]" C2 = "2-4-6-8-12-14-15-21: [1,Inf)" C3 = "3: [-1,1)" C4 = "5-17: (-Inf,Inf)|{0}" C5 = "7-9-10-22: (0,1]" C6 = "11: (0, 1/2]" C7 = "13-16-19-20: (0,Inf)" C8 = "18: [2, Inf)" C = c( C1, C2, C3, C4, C5, C6, C7, C8 ) L = c( -1, 1, -1, -B, 0, 0, 0, 2 ) U = c( B, 5*B, 1, 5*B, 1, 0.5, B, B ) A = c( 0.5, 2, 0.5, 1, 0.5, 0.2, 1, 3 ) V = rep(0.01, 20) .sliderMenu(refresh.code, names = c("Copula", "N", C), minima = c( 1, 10, L), maxima = c( 22, 1000, U), resolutions = c( 1, 10, V), starts = c( 1, 100, A)) } # ------------------------------------------------------------------------------ .Kfunc = function(x, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes Density for Archimedean Copulae # Arguments: # x - a numeric vector # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Missing x: if (missing(x)) x = (0:10)/10 # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Density: Kfunc = x - .Phi(x, alpha, type) / .PhiFirstDer(x, alpha, type) # Take care from divergencies: Kfunc[is.na(Kfunc)] = 0 Kfunc[x == 1] = 1 # Return Value: Kfunc } # ------------------------------------------------------------------------------ .invK = function(x, alpha = NULL, type = archmList(), lower = 1.0e-8) { # A function implemented by Diethelm Wuertz # Description: # Computes Inverse of Density for Archimedean Copulae # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Compute Inverse: .fKC = function(x, p, alpha, type) { .Kfunc (x, alpha, type) - p } p = x z = NULL for (P in p) { if (P > 1 - lower/2) { res = 1 } else if (P < .Kfunc(0, alpha, type) + lower/2 ) { res = 0 } else { res = uniroot(.fKC, c(lower, 1), p = P, alpha = alpha, type = type)$root } z = c(z, res) } # Return Value: z } # ------------------------------------------------------------------------------ .invK2 = function(x, alpha, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Computes from tabulated values # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Tabulated Values: iK = NULL for (i in 1:length(x)) { Ord = order(abs(.Kfunc((0:1000)/1000, alpha, type)-x[i]))[1]/1000 iK = c(iK, Ord) } # Return Value: iK } # ------------------------------------------------------------------------------ .makeConcordanceTable = function(B = 5, dump = FALSE) { # A function implemented by Diethelm Wuertz # Make Table: Counter = c(1,2,3,2,4,2,5,2,5,5,6,2,7,2,2,7,4,8,7,7,2,5) L = c( -1, +1, -1, -5*B, 0, 0, 0, 2 ) U = c( B, 5*B, 1, 5*B, 1, 0.5, B, B ) Tau = Alpha = Rho = NULL for (i in 1:22) { print(i) No = Counter[i] lower = L[No] upper = U[No] alpha = seq(lower, upper, length = 25) Alpha = cbind(Alpha, alpha) tau = archmTau(alpha = alpha, type = i) rho = archmRho(alpha = alpha, type = i) Tau = cbind(Tau, tau) Rho = cbind(Rho, rho) } .ALPHA = data.frame(Alpha) .TAU = data.frame(Tau) .RHO = data.frame(Rho) colnames(.ALPHA) = colnames(.TAU) = colnames(.RHO) = as.character(1:22) # Dump: if (dump) { dump(".ALPHA", "alpha.R") dump(".TAU", "tau.R") dump(".RHO", "rho.R") } # Return Value: list(ALPHA = .ALPHA, TAU = .TAU, RHO = .RHO) } # ------------------------------------------------------------------------------ ".ALPHA" <- structure(list( "1" = c(-1, -0.75, -0.5, -0.25, 0, 0.25, 0.5, 0.75, 1, 1.25, 1.5, 1.75, 2, 2.25, 2.5, 2.75, 3, 3.25, 3.5, 3.75, 4, 4.25, 4.5, 4.75, 5), "2" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "3" = c(-1, -0.916666666666667, -0.833333333333333, -0.75, -0.666666666666667, -0.583333333333333, -0.5, -0.416666666666667, -0.333333333333333, -0.25, -0.166666666666667, -0.0833333333333334, 0, 0.0833333333333333, 0.166666666666667, 0.25, 0.333333333333333, 0.416666666666667, 0.5, 0.583333333333333, 0.666666666666667, 0.75, 0.833333333333333, 0.916666666666667, 1), "4" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "5" = c(-25, -22.9166666666667, -20.8333333333333, -18.75, -16.6666666666667, -14.5833333333333, -12.5, -10.4166666666667, -8.33333333333333, -6.25, -4.16666666666666, -2.08333333333333, 0, 2.08333333333334, 4.16666666666667, 6.25, 8.33333333333334, 10.4166666666667, 12.5, 14.5833333333333, 16.6666666666667, 18.75, 20.8333333333333, 22.9166666666667, 25), "6" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "7" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1), "8" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "9" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1), "10" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1), "11" = c(0, 0.0208333333333333, 0.0416666666666667, 0.0625, 0.0833333333333333, 0.104166666666667, 0.125, 0.145833333333333, 0.166666666666667, 0.1875, 0.208333333333333, 0.229166666666667, 0.25, 0.270833333333333, 0.291666666666667, 0.3125, 0.333333333333333, 0.354166666666667, 0.375, 0.395833333333333, 0.416666666666667, 0.4375, 0.458333333333333, 0.479166666666667, 0.5), "12" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "13" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "14" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "15" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "16" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "17" = c(-25, -22.9166666666667, -20.8333333333333, -18.75, -16.6666666666667, -14.5833333333333, -12.5, -10.4166666666667, -8.33333333333333, -6.25, -4.16666666666666, -2.08333333333333, 0, 2.08333333333334, 4.16666666666667, 6.25, 8.33333333333334, 10.4166666666667, 12.5, 14.5833333333333, 16.6666666666667, 18.75, 20.8333333333333, 22.9166666666667, 25), "18" = c(2, 2.125, 2.25, 2.375, 2.5, 2.625, 2.75, 2.875, 3, 3.125, 3.25, 3.375, 3.5, 3.625, 3.75, 3.875, 4, 4.125, 4.25, 4.375, 4.5, 4.625, 4.75, 4.875, 5), "19" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "20" = c(0, 0.208333333333333, 0.416666666666667, 0.625, 0.833333333333333, 1.04166666666667, 1.25, 1.45833333333333, 1.66666666666667, 1.875, 2.08333333333333, 2.29166666666667, 2.5, 2.70833333333333, 2.91666666666667, 3.125, 3.33333333333333, 3.54166666666667, 3.75, 3.95833333333333, 4.16666666666667, 4.375, 4.58333333333333, 4.79166666666667, 5), "21" = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), "22" = c(0, 0.0416666666666667, 0.0833333333333333, 0.125, 0.166666666666667, 0.208333333333333, 0.25, 0.291666666666667, 0.333333333333333, 0.375, 0.416666666666667, 0.458333333333333, 0.5, 0.541666666666667, 0.583333333333333, 0.625, 0.666666666666667, 0.708333333333333, 0.75, 0.791666666666667, 0.833333333333333, 0.875, 0.916666666666667, 0.958333333333333, 1)), .Names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25"), class = "data.frame") # ------------------------------------------------------------------------------ ".TAU" <- structure(list( "1" = c(-1, -0.6, -0.333333333333333, -0.142857142857143, 0, 0.111111111111111, 0.2, 0.272727272727273, 0.333333333333333, 0.384615384615385, 0.428571428571429, 0.466666666666667, 0.5, 0.529411764705882, 0.555555555555556, 0.578947368421053, 0.6, 0.619047619047619, 0.636363636363636, 0.652173913043478, 0.666666666666667, 0.68, 0.692307692307692, 0.703703703703704, 0.714285714285714 ), "2" = c(-1, 0, 0.333333333333333, 0.5, 0.6, 0.666666666666667, 0.714285714285714, 0.75, 0.777777777777778, 0.8, 0.818181818181818, 0.833333333333333, 0.846153846153846, 0.857142857142857, 0.866666666666667, 0.875, 0.88235294117647, 0.888888888888889, 0.894736842105263, 0.9, 0.904761904761905, 0.909090909090909, 0.91304347826087, 0.916666666666667, 0.92), "3" = c(-0.181725814826518, -0.168930151452714, -0.155798192853549, -0.142309156210049, -0.128440099024957, -0.114165590552606, -0.0994573153156502, -0.0842835904937131, -0.068608772818993, -0.0523925219034918, -0.0355888743571007, -0.0181450645517658, 0, 0.0189177438301371, 0.0386926132325796, 0.0594257680440222, 0.0812402882884418, 0.104288760957381, 0.128764787039966, 0.154921339236023, 0.183102048111355, 0.21379958230518, 0.247780252512751, 0.286418218456134, 0.333333333333333), "4" = c(0, 0.5, 0.666666666666667, 0.75, 0.8, 0.833333333333333, 0.857142857142857, 0.875, 0.888888888888889, 0.9, 0.909090909090909, 0.916666666666667, 0.923076923076923, 0.928571428571429, 0.933333333333333, 0.9375, 0.941176470588235, 0.944444444444444, 0.947368421052632, 0.95, 0.952380952380952, 0.954545454545455, 0.956521739130435, 0.958333333333333, 0.96), "5" = c(-0.85052757802554, -0.837983233335134, -0.823159712179848, -0.805382359321779, -0.78368703586404, -0.756652338202137, -0.722109024177686, -0.676626253020113, -0.61461896491917, -0.527006789744252, -0.400406496234527, -0.222118698154441, 0, 0.222118698154449, 0.400406496234539, 0.527006789744276, 0.614618964919029, 0.676626253020132, 0.722109024177453, 0.756652338200781, 0.783687035871101, 0.805382359356256, 0.823159712267863, 0.837983231749698, 0.850527554271354), "6" = c(0, 0.355065933151777, 0.517962498229816, 0.613705638974404, 0.677220914237255, 0.722592092430507, 0.756685017415291, 0.783274098241282, 0.80461673005689, 0.822148933158253, 0.836832638206725, 0.84932812611196, 0.860110789048376, 0.869526200860125, 0.877832575748863, 0.885224248904, 0.891855111133839, 0.897842192832803, 0.903279485909824, 0.90824351995753, 0.912795085448852, 0.91698501728904, 0.920858299365945, 0.924445190119985, 0.927779794217425), "7" = c(1, 0.971927944913947, 0.943246768509585, 0.913923522796783, 0.88392216030227, 0.853203097878133, 0.821722695867944, 0.789432631089395, 0.756279135134686, 0.722202059745913, 0.687133717127867, 0.65099742284623, 0.613705638880109, 0.575157568479307, 0.535235982291939, 0.493802937831557, 0.450693855665945, 0.40570906309108, 0.358601253084469, 0.309055967047944, 0.256659242461756, 0.200839120747762, 0.140745344631603, 0.0749411953484011, 0), "8" = c(-1, -0.333333333333333, -0.111111111111111, 0, 0.0666666666666667, 0.111111111111111, 0.142857142857143, 0.166666666666667, 0.185185185185185, 0.2, 0.212121212121212, 0.222222222222222, 0.230769230769231, 0.238095238095238, 0.244444444444444, 0.25, 0.254901960784314, 0.259259259259259, 0.263157894736842, 0.266666666666667, 0.26984126984127, 0.272727272727273, 0.275362318840580, 0.277777777777778, 0.28), "9" = c(0, -0.0204163452169608, -0.0400596555238257, -0.0590081036085306, -0.0773261331388824, -0.0950679058715638, -0.112279639253442, -0.129001262402105, -0.145267629233813, -0.161109431296128, -0.176553899922191, -0.191625356399165, -0.206345649900960, -0.220734510872628, -0.234809839618285, -0.24858794447726, -0.262083740255211, -0.275310914946985, -0.288282070892981, -0.301008845122611, -0.313502012606631, -0.325771575362601, -0.337826839765094, -0.349676483955214, -0.361328616888101), "10" = c(0, -0.0196066744396921, -0.0370221472721557, -0.0525703541709941, -0.0665070136005856, -0.0790393052012712, -0.0903383149316412, -0.100547418134766, -0.109788190716896, -0.118164725554978, -0.125766872846962, -0.132672728007605, -0.138950577833938, -0.144660447061511, -0.149855344023087, -0.154582275706178, -0.158883083359664, -0.162795136572255, -0.166351914405464, -0.16958349544035, -0.172516973673804, -0.175176813539516, -0.177585154568996, -0.179762074101597, -0.181725814826518), "11" = c(0, -0.0208398943709387, -0.0417175967562695, -0.0626672066307008, -0.083719725295789, -0.104903822366714, -0.126246401393688, -0.147773031839223, -0.169508288800322, -0.191476027240807, -0.213699608737601, -0.236202093256811, -0.259006404912340, -0.282135478276679, -0.305612390180847, -0.329460480799121, -0.353703467003579, -0.378365550391214, -0.403471521964720, -0.429046865142757, -0.455117858555391, -0.481711679925032, -0.50885651222745, -0.536581653261374, -0.564917629721708), "12" = c(0.333333333333333, 0.666666666666667, 0.777777777777778, 0.833333333333333, 0.866666666666667, 0.888888888888889, 0.904761904761905, 0.916666666666667, 0.925925925925926, 0.933333333333333, 0.93939393939394, 0.944444444444444, 0.948717948717949, 0.952380952380952, 0.955555555555556, 0.958333333333333, 0.96078431372549, 0.962962962962963, 0.964912280701754, 0.966666666666667, 0.968253968253968, 0.96969696969697, 0.971014492753623, 0.972222222222222, 0.973333333333333), "13" = c(-0.3613289, -0.269528030161219, -0.187585190523704, -0.114164377378166, -0.048139718340646, 0.0114414518639374, 0.0653882965033201, 0.114390646561491, 0.159038737349337, 0.199839382405940, 0.237229274320303, 0.271585960700895, 0.303236932556452, 0.332467174993497, 0.359525461142416, 0.384629615561405, 0.407970929923072, 0.42971787915222, 0.450019258484065, 0.469006839692804, 0.486797626862941, 0.503495777648588, 0.519194244288641, 0.533976179166497, 0.547916141985897), "14" = c(0.333333333333333, 0.6, 0.714285714285714, 0.777777777777778, 0.818181818181818, 0.846153846153846, 0.866666666666667, 0.88235294117647, 0.894736842105263, 0.904761904761905, 0.91304347826087, 0.92, 0.925925925925926, 0.93103448275862, 0.935483870967742, 0.93939393939394, 0.942857142857143, 0.945945945945946, 0.948717948717949, 0.951219512195122, 0.953488372093023, 0.955555555555556, 0.957446808510638, 0.959183673469388, 0.96078431372549), "15" = c(-1, 0.333333333333333, 0.6, 0.714285714285714, 0.777777777777778, 0.818181818181818, 0.846153846153846, 0.866666666666667, 0.88235294117647, 0.894736842105263, 0.904761904761905, 0.91304347826087, 0.92, 0.925925925925926, 0.93103448275862, 0.935483870967742, 0.93939393939394, 0.942857142857143, 0.945945945945946, 0.948717948717949, 0.951219512195122, 0.953488372093023, 0.955555555555556, 0.957446808510638, 0.959183673469388), "16" = c(-1, 0.0199469096156091, 0.129575836560517, 0.180662881950351, 0.210821233719316, 0.230868290892863, 0.245206353296857, 0.255989120788036, 0.264401763304115, 0.271152717969063, 0.276692429117510, 0.281321400174802, 0.285247984614676, 0.288621292351708, 0.291550902234041, 0.294119177987248, 0.296389240808115, 0.298410289410793, 0.300221244635643, 0.301853304387547, 0.303331771457812, 0.304677385016165, 0.305907306382662, 0.307035859574841, 0.308075095038758), "17" = c(-0.505322479883461, -0.495828713697966, -0.48454639378008, -0.470935203584076, -0.454226630515362, -0.433303941761343, -0.406516652894873, -0.371413076160088, -0.324429660012302, -0.26078346047423, -0.175313467887867, -0.0654880362471264, 3, 0.198425450290705, 0.322606327311886, 0.426990238062425, 0.510371695749375, 0.575835676725875, 0.627386508234144, 0.668494514582698, 0.701798032118806, 0.729213683422655, 0.752120712677402, 0.771518248976997, 0.78813985427463), "18" = c(0.333333333333333, 0.372549019607843, 0.407407407407407, 0.43859649122807, 0.466666666666667, 0.492063492063492, 0.515151515151515, 0.536231884057971, 0.555555555555556, 0.573333333333333, 0.58974358974359, 0.604938271604938, 0.619047619047619, 0.632183908045977, 0.644444444444444, 0.655913978494624, 0.666666666666667, 0.676767676767677, 0.686274509803922, 0.695238095238095, 0.703703703703704, 0.711711711711712, 0.719298245614035, 0.726495726495726, 0.733333333333333), "19" = c(0, 0.429836470415013, 0.492561142661991, 0.539699842175544, 0.577243238619945, 0.608200347675897, 0.634340746150618, 0.656827513885057, 0.676426663266239, 0.693706733577166, 0.709084640531406, 0.722877931761809, 0.735333844361156, 0.746648476889695, 0.756979782729611, 0.766456689701118, 0.775185755847842, 0.783255888758933, 0.790741999213658, 0.797707696363886, 0.80420742554753, 0.810288035370101, 0.815990188618369, 0.821349301247486, 0.826396408325272), "20" = c(0.333333333333333, 0.187581702849446, 0.336923464258114, 0.453621153661734, 0.544347004922251, 0.615306486593428, 0.671462346739915, 0.716591196240161, 0.753556906539465, 0.784548776018356, 0.811245341187264, 0.834925230324345, 0.856550987713366, 0.87682562788058, 0.896293707460173, 0.915293066771852, 0.934084281673088, 0.952832982671359, 0.97164182521641, 0.99056793780414, 1.00963608457645, 1.02884861875661, 1.04819318064612, 1.06764664223826, 1.0871818991606), "21" = c(-0.9999999996, 0.227411277761033, 0.475707247837903, 0.594420704044238, 0.666780283574186, 0.716296479239256, 0.752597708588034, 0.780474107458171, 0.80263551556664, 0.820709018127606, 0.835799583394556, 0.848581734688507, 0.859631891238008, 0.869228393597159, 0.877745364348898, 0.885267593021253, 0.8921031172938, 0.89816522529609, 0.903767761397344, 0.908803416914886, 0.913503328379058, 0.917746442778645, 0.921749156268669, 0.925374342563027, 0.92882540945077), "22" = c(8.88178419700125e-16, -0.0204403642205317, -0.0402325966459149, -0.0595398315924127, -0.0784852878388032, -0.09716610551268, -0.115661428244375, -0.134037489701166, -0.152350993933844, -0.170651459100329, -0.18898289917049, -0.207385066034675, -0.225894390250444, -0.244544709719205, -0.263367845858735, -0.282394068127122, -0.301652475612564, -0.321171316316645, -0.340978259249309, -0.361100630626295, -0.381565622756077, -0.402400482266088, -0.423632682913976, -0.445290087203517, -0.467401100271068)), .Names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25"), class = "data.frame") # ------------------------------------------------------------------------------ ".RHO" <- structure(list( "1" = c(-1.00148148148148, -0.738747613322986, -0.466622048681987, -0.211687707079451, 0, 0.165652020595619, 0.294857841987463, 0.396806275669875, 0.478390117460797, 0.544587799346395, 0.598994031361846, 0.644231561135091, 0.682240753560612, 0.714478294671625, 0.742053406185035, 0.765822053649082, 0.786452951364207, 0.80447447147138, 0.820308460074897, 0.83429494974631, 0.846710452420334, 0.85778166343474, 0.867695842924806, 0.876608762194626, 0.884650845307784), "2" = c(-1.00148148148148, 0.141567825309872, 0.533448886027939, 0.708244460527527, 0.800738510405266, 0.855438151990562, 0.89038551287057, 0.913977650156251, 0.930840822487669, 0.943140720229384, 0.952367340916965, 0.959636846016786, 0.965337805120064, 0.969884351339425, 0.973637657583298, 0.976727483348096, 0.979298582357153, 0.98146084822125, 0.983296560480555, 0.984868310083549, 0.986245587058835, 0.987459252328268, 0.988521705438795, 0.989457189777394, 0.990285276373145), "3" = c(-0.271064557642169, -0.252157028402899, -0.232714526887962, -0.212705548849901, -0.19209555265805, -0.170846533523001, -0.148916516723668, -0.12625894982673, -0.102821967656877, -0.078547495149129, -0.0533701410712804, -0.0272158181938728, 1.38263885937115e-18, 0.0283745141601889, 0.0580205123349336, 0.0890702417932126, 0.121680672987631, 0.156040852661039, 0.192382519137300, 0.230996069414554, 0.272255880785214, 0.316663434022027, 0.36492869505212, 0.418151365908671, 0.478390117460797), "4" = c(1.38263885937115e-18, 0.682189978639204, 0.848820654347913, 0.912515206140176, 0.943205695413621, 0.960245155358946, 0.970657019434397, 0.977474770619668, 0.982178751195054, 0.985559960479453, 0.98807177913133, 0.989989026203176, 0.99148606893177, 0.99267782385585, 0.993642497101149, 0.994434794399345, 0.99509390407114, 0.995648488592752, 0.996119899908012, 0.996524305455528, 0.99687412690816, 0.997179034157432, 0.99744664490479, 0.997683025382027, 0.997893054234396), "5" = c(-0.972111584358926, -0.967209491068637, -0.960903114161494, -0.952607108183223, -0.941402673140619, -0.925789337989117, -0.903206982408158, -0.869086491837814, -0.814968529644537, -0.725140930480804, -0.573066256464247, -0.328659597722, 1.38263885937115e-18, 0.328659597722, 0.573066256464246, 0.725140930480804, 0.814968529644528, 0.86908649183787, 0.903206982408021, 0.92578933798917, 0.941402673149305, 0.95260710822185, 0.960903114203512, 0.967209491448638, 0.972111584081945), "6" = c(1.38263885937115e-18, 0.504193253656214, 0.700093384009142, 0.798178467968907, 0.854636457142996, 0.890208596051013, 0.914104060707307, 0.930945457506372, 0.943268127871861, 0.952561541134428, 0.95968871558049, 0.966247582643763, 0.970782114931405, 0.976498903835584, 0.979560788569006, 0.98205552457824, 0.993861933959956, 0.99558219645679, 1.00597796784080, 1.00765676774247, 1.03633645236535, 1.03732862637663, 1.03805548919961, 1.05932394767550, 1.06079424267615), "7" = c(-1.00148148148148, -0.979072702331951, -0.956663923182448, -0.934255144032922, -0.910476817558297, -0.885980795610422, -0.86087901234568, -0.834111385459534, -0.806575582990396, -0.777481481481482, -0.747489711934157, -0.715582990397804, -0.682232098765431, -0.646978326474623, -0.60966803840878, -0.570271604938272, -0.528215089163238, -0.482955281207133, -0.434469135802469, -0.381630727023320, -0.323950617283951, -0.259980246913580, -0.187865020576132, -0.104024142661180, 1.38263885937115e-18), "8" = c(-1.00148148148148, -0.382286405036925, -0.114601585715482, 0.0310996982933278, 0.121547108159812, 0.182711347208507, 0.226564943368020, 0.259498634290694, 0.28500277910381, 0.305383082451978, 0.321951896975906, 0.335684240420725, 0.347297689031008, 0.35716340065043, 0.365682214112401, 0.373072635634355, 0.379610561045101, 0.385393549400538, 0.390535446981844, 0.395136786179741, 0.399301204243857, 0.403072768984719, 0.406501170036244, 0.409631031685417, 0.412499583816874), "9" = c(0, -0.0306009955864517, -0.0600171715566712, -0.0883435022143309, -0.115662851324462, -0.14204808424762, -0.167563722488530, -0.192267256145817, -0.216210197252217, -0.239438934387163, -0.261995433039874, -0.283917814885177, -0.305240840989756, -0.325996318037027, -0.346213442292882, -0.365919092784125, -0.385138082715462, -0.403893376291347, -0.422206276681155, -0.440096589759673, -0.457582767389748, -0.474682033331841, -0.4914104943232, -0.507783238435509, -0.523814422470025), "10" = c(0, -0.029390926055108, -0.0554838410175942, -0.0787567884244303, -0.0995948147001642, -0.118312849424028, -0.135171965480742, -0.150391128987132, -0.164155854619207, -0.176624701885803, -0.187934236009538, -0.198202876118343, -0.207533922658104, -0.216017969401489, -0.223734847121171, -0.230755205988202, -0.237141815823774, -0.24295064350982, -0.248231752581214, -0.253030059585575, -0.257385974070141, -0.261335943265486, -0.264912918148678, -0.268146754209015, -0.271064557642169), "11" = c(0, -0.0312337307463261, -0.0624885635341056, -0.0937774571924054, -0.125109119631511, -0.156488211337586, -0.187915529826987, -0.219388201730151, -0.250899897834131, -0.282441141124533, -0.313999597626781, -0.345560474009285, -0.377106883941072, -0.408620285268396, -0.440080745221534, -0.471467680629385, -0.502759810642414, -0.533935835408547, -0.564973896022694, -0.595854502689236, -0.626555877382724, -0.657058974751787, -0.687347683323, -0.717399152001416, -0.747202834006994), "12" = c(0.478390117460797, 0.847457484412861, 0.929514118116192, 0.959770189940577, 0.974091289816988, 0.98196494553155, 0.98674930920016, 0.989872618006014, 0.992024786623663, 0.99357184100672, 0.994722476491513, 0.995602679183581, 0.99629212083331, 0.996843164325584, 0.99729136172679, 0.99766153224032, 0.997971424587865, 0.998234001133303, 0.998458905801764, 0.998653432689402, 0.998823180355318, 0.998972503148868, 0.99910482845359, 0.99922288351134, 0.999328860123071), "13" = c(8.60444444444445, -0.396927340010433, -0.279041044592502, -0.170790656731972, -0.0721889092723266, 0.0171559644885065, 0.0978612488308676, 0.170645482690321, 0.236250585187531, 0.295396788789730, 0.34875879445432, 0.396954947814539, 0.440544088483541, 0.480026728592929, 0.515848521579894, 0.548404801961588, 0.578045482558421, 0.605079904444685, 0.629781421965416, 0.652391617354311, 0.673124105746233, 0.692167929492244, 0.709690561612045, 0.725840548723069, 0.740749828053321), "14" = c(0.478390117460797, 0.78697038487367, 0.88669651583035, 0.930158273783357, 0.952781313104883, 0.966001646844378, 0.97438037870724, 0.98001921761715, 0.983993663292466, 0.98689971728531, 0.989089008338032, 0.990779746538743, 0.992113107410875, 0.99318367420424, 0.99405672549771, 0.994778481699574, 0.995382405409204, 0.995893200807138, 0.996329424259493, 0.996705230895822, 0.9970315690086, 0.997317013020675, 0.99756835474172, 0.997791029818825, 0.997989429828517), "15" = c(-1.00148148148148, 0.483330421553014, 0.788592827249555, 0.887213491121673, 0.930351139068034, 0.952863855394297, 0.966040941166183, 0.974400661352683, 0.980030344652669, 0.984000050201677, 0.98690350529195, 0.989091305340107, 0.990781156959334, 0.992113975575947, 0.993184203332592, 0.99405703905789, 0.994778656516628, 0.995382490232112, 0.99589322707115, 0.996329412502773, 0.996705194678632, 0.9970315173572, 0.997316951978555, 0.997568288369395, 0.997790960846676), "16" = c(-1.00148148148148, 0.0399918107572716, 0.196922447742505, 0.269217972641498, 0.311479910536255, 0.339361834072764, 0.359187127162052, 0.374027186155748, 0.385561510047341, 0.394788531585647, 0.402340078994373, 0.408635928417183, 0.41396608392397, 0.418537431930041, 0.422501583532575, 0.425972210130218, 0.429036230512499, 0.431761254762484, 0.434200670669304, 0.436397200953502, 0.438385442597004, 0.440193712932073, 0.441845413865275, 0.443360054973381, 0.444754031079707), "17" = c(-0.644683937053512, -0.638242233699325, -0.63002248705626, -0.619327391403488, -0.605102498262373, -0.585717699732245, -0.558611529498344, -0.519748499835421, -0.462935375218991, -0.379451494373527, -0.259494676315209, -0.0980201065759068, -2.86814814814815, 0.294555695013013, 0.469764827999549, 0.606508141811551, 0.705924049580753, 0.776198676767287, 0.825867405611722, 0.86149149285161, 0.887580315101809, 0.907115201815617, 0.922057497657996, 0.933711847666972, 0.942961892529542), "18" = c(0.579165030761005, 0.612486124687689, 0.641987920637447, 0.668204867084776, 0.691471975626513, 0.712672417787934, 0.731485428240074, 0.748541425177017, 0.763998843765579, 0.7781439158238, 0.79107000000924, 0.802825120690881, 0.81347401988651, 0.823349095595444, 0.832637848646758, 0.841114775574677, 0.848922542682376, 0.85620758378877, 0.862952434000152, 0.869158594153996, 0.87492608635104, 0.880415774029804, 0.885630004240057, 0.890455816493047, 0.894963682434538), "19" = c(0.478390117460797, 0.593310952911897, 0.663998561233565, 0.71419945722106, 0.752174890526936, 0.782049472476609, 0.806205285404551, 0.826145083754451, 0.842875473608911, 0.857101027367348, 0.869331955302181, 0.87994792140256, 0.889237849471334, 0.897425790062242, 0.904688304851229, 0.911166484840908, 0.916974461375408, 0.922205560262668, 0.926936833441981, 0.931232450014748, 0.935146270324233, 0.938723825147773, 0.942003855222286, 0.9450195214372, 0.947799365319983), "20" = c(0, 0.276598221109225, 0.480091816919932, 0.62207813892774, 0.720105357077801, 0.788404490421694, 0.83684648649206, 0.871903512170082, 0.897785391284217, 0.917254967437719, 0.932155415374907, 0.94373844195542, 0.952871658197302, 0.960166062946691, 0.96606101324546, 0.970874376612312, 0.974843755028167, 0.978145796062885, 0.98091616915103, 0.983256097985314, 0.985247325406535, 0.986952155066644, 0.988421752891467, 0.98969341361155, 0.990800873367999), "21" = c(-1.00148148148148, 0.347129116118547, 0.65564069685479, 0.780803624460825, 0.846443027861398, 0.885838814250034, 0.911560842980429, 0.929365274007805, 0.942234840854385, 0.951833301777067, 0.96008770231504, 0.965881283889428, 0.97252949040583, 0.97634531326702, 0.979070799707118, 0.99154650629721, 0.993599496406914, 1.00432643751157, 1.00555767252712, 1.03505473383290, 1.03618596470961, 1.05759086565101, 1.05873221403231, 1.11481166665537, 1.11507652990229), "22" = c(0, -0.0306367173028787, -0.0602746511903028, -0.0891338848924438, -0.117379804930934, -0.145140408516369, -0.172516725392443, -0.199589475575909, -0.226423523248459, -0.253070965533168, -0.279573384360126, -0.30596355638433, -0.332266726350362, -0.358501732266778, -0.384681876941774, -0.410815779550173, -0.436907762333632, -0.462959276965944, -0.488968041367581, -0.514929666432483, -0.540839175128809, -0.566687136331552, -0.592466001518449, -0.618164814543992, -0.643774208533738)), .Names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22"), row.names = c("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25"), class = "data.frame") ################################################################################ fCopulae/R/ArchimedeanDependency.R0000644000176000001440000003727311370220745016600 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: KENDALL'S TAU AND SPEARMAN'S RHO: # archmTau Returns Kendall's tau for Archemedean copulae # archmRho Returns Spearman's rho for Archemedean copulae # .archmTauRange Returns range for Kendall's tau # .archm2Tau Alternative way to compute Kendall's tau # ### .archmGamma Returns Gini's gamma for Archimedean copulae # .archmTail Utility Function # FUNCTION: ARCHIMEDEAN COPULAE TAIL COEFFICIENT: # archmTailCoeff Computes tail dependence for Archimedean copulae # archmTailPlot Plots Archimedean tail dependence function # REQUIREMENT: DESCRIPTION: # adapt Contributed R package adapt ################################################################################ ################################################################################ # FUNCTION KENDALL'S TAU AND SPEARMAN'S RHO: # archmTau Returns Kendall's tau for Archemedean copulae # archmRho Returns Spearman's rho for Archemedean copulae # .archmTauRange Returns range for Kendall's tau # .archm2Tau Alternative way to compute Kendall's tau # .archmGamma Returns Gini's gamma for Archimedean copulae # .archmTail Utility Function archmTau = function(alpha = NULL, type = archmList(), lower = 1.0e-10) { # A function implemented by Diethelm Wuertz # Description: # Kendall's tau by integration for Archimedean copulae # FUNCTION: # Settings: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Compute tau: if (length(alpha) == 1) { ans = .archmTau(alpha, type, lower) names(ans) = "Tau" names(alpha) = "alpha" } else { ans = NULL for ( i in 1:length(alpha) ) ans = c(ans, .archmTau(alpha[i], type, lower)[1]) names(ans) = paste("Tau", 1:length(alpha), sep = "") names(alpha) = paste("alpha", 1:length(alpha), sep = "") } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame( t(alpha), type = type, lower = lower, row.names= "") # Return Value: ans } # ------------------------------------------------------------------------------ .archmTau = function(alpha = NULL, type = archmList(), lower = 1.0e-10) { # A function implemented by Diethelm Wuertz # Description: # Kendall's tau by integration for Archimedean copulae # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Select Type: if (Type == 1) { if (alpha == -1) return(-1) if (alpha == 0) return(0) tau = alpha/(alpha+2) return(tau) } else if (Type == 2) { if (alpha == 1) return(-1) tau = 1 - 2/alpha return(tau) } else if (Type == 3 & alpha == 0) { return(0) # tau numeric } else if (Type == 3 & alpha == 1) { return(1/3) # tau numeric } else if (Type == 4) { if (alpha == 1) return(0) tau = 1 - 1/alpha return(tau) } else if (Type == 5 & alpha == 0) { return(0) # tau numeric } else if (Type == 6 & alpha == 1) { return(0) } else if (Type == 7) { if (alpha == 0) return(1) if (alpha == 1) return(0) tau = 2*(1-alpha)*(alpha+log(1-alpha)-alpha*log(1-alpha))/alpha^2 return(tau) } else if (Type == 8) { if (alpha == 1) return(-1) tau = (-4+alpha)/(3*alpha) return(tau) } else if (Type == 9 & alpha == 0) { return(0) # tau numeric } else if (Type == 10 & alpha == 0) { return(0) # tau numeric } else if (Type == 11 & alpha == 0) { return(0) } else if (Type == 12) { tau = 1 - 2/(3*alpha) return(tau) } else if (Type == 13 & alpha == 1) { return(0) # tau numeric } else if (Type == 13 & alpha == 0) { return(-0.3613289) # 1e-8 value } else if (Type == 14) { tau = 1 - 4/(2+4*alpha) return(tau) } else if (Type == 15) { if (alpha == 1) return(-1) tau = 1 + 4/(2-4*alpha) return(tau) } else if (Type == 16 & alpha == 0) { return(-1) # tau numeric } else if (Type == 17 & alpha == -1) { return(0) # tau numeric } else if (Type == 18) { tau = 1 - 4/(3*alpha) return(tau) } else if (Type == 19 & alpha == 0) { return(0) # tau numeric } else if (Type == 20 & alpha == 0) { return(1/3) # tau numeric # } else if (Type == 21) { # tau numeric # } else if (Type == 22) { # tau numeric } else { # Integrate: ans = integrate( f = .Kfunc, lower = lower, upper = 1, alpha = alpha, type = type, stop.on.error = FALSE, rel.tol = .Machine$double.eps^0.5) tau = 3 - 4 * ans[[1]] attr(tau, "control")<-unlist(c(alpha, type = type, ans[2:4])) return(tau) } # Return Value: invisible() } # ------------------------------------------------------------------------------ .archmTauRange = function(type = archmList()) { # A function implemented by Diethelm Wuertz # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Range: range = matrix( c( 1, -1, 1, 2, -1, 1, 3, -0.182, 1/3, 4, 0, 1, 5, -1, 1, 6, 0, 1, 7, 0, 1, 8, -1, 1/3, 9, 0, 0.361, 10, 0, 0.182, 11, 0,-0.565, 12, 1/3, 1, 13, 0.361, NA, 14, 1/3, 1, 15, -1, 1, 16, NA, 1/3, 17, -1, 1, 18, 1/3, 1, 19, 1/3, 1, 20, 0, 1, 21, NA, NA, 22, NA, NA ), byrow = TRUE, ncol = 3 ) # Result: ans = range[Type, ][-1] names(ans) = c("tau.lower", "tau.upper") attr(ans, "control")<-c(type = type) # Return Value: ans } # ------------------------------------------------------------------------------ .archm2Tau = function (alpha = NULL, type = archmList(), lower = 1e-6) { # A function implemented by Diethelm Wuertz # Joe's [1997] alternative expression: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Integrate: K2func = function(x, alpha, type) { x * .invPhiFirstDer(x, alpha, type)^2 } upper = .Phi(0, alpha, type) - lower ans = integrate(f = K2func, lower = lower, upper = upper, alpha = alpha, type = type) tau = 1 - 4 * ans[[1]] attr(tau, "control") <- unlist(c(alpha, type = type, ans[2:4])) # Return Value: tau } # ------------------------------------------------------------------------------ archmRho = function(alpha = NULL, type = archmList(), method = c("integrate2d", "adapt"), error = 1.0e-5) { # A function implemented by Diethelm Wuertz # Description: # Spearman's Rho by integration for Archimedean copulae # FUNCTION: # Match Arguments: method = match.arg(method) # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Compute Rho: if (length(alpha) == 1) { ans = .archmRho(alpha, type, method, error) names(ans) = "Rho" names(alpha) = "alpha" } else { ans = NULL for ( i in 1:length(alpha) ) ans = c(ans, .archmRho(alpha[i], type, method, error)[1]) names(ans) = paste("Rho", 1:length(alpha), sep = "") names(alpha) = paste("alpha", 1:length(alpha), sep = "") } # Add Control Attribute: attr(ans, "control")<-cbind.data.frame( t(alpha), type = type, method = method, error = error, row.names= "") # Return Value: ans } # ------------------------------------------------------------------------------ .archmRho = function(alpha = NULL, type = archmList(), method = c("integrate2d", "adapt"), error = 1.0e-5) { # A function implemented by Diethelm Wuertz # Description: # Spearman's rho by integration for Archimedean copulae # Requirements: # Note, method="adapt" requires R-Package adapt # FUNCTION: # Match Arguments: method = match.arg(method) # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Global Parameters: ## alpha <<- alpha ## type <<- type # 2D Integration: if (method == "integrate2d" ) { # Internal Function : fun.integrate2d = function(x, y, alpha, type ) { 12 * (.parchm1Copula(x, y, alpha = alpha, type = type) - x*y ) } ans = integrate2d(fun.integrate2d, error = error, alpha = alpha, type = type) } else if (method == "adapt") { # Requires contributed package adapt ... fun.adapt = function(z, alpha, type) { x = z[1] y = z[2] 12 * (.parchm1Copula(x, y, alpha = alpha, type = type) - x*y) } ans = adapt(ndim = 2, lower = c(0, 0), upper = c(1, 1), minpts = 100, maxpts = NULL, functn = fun.adapt, eps = 0.01, alpha = alpha, type = type) } rho = ans$value # Result: control = list(alpha = alpha[[1]]) attr(rho, "control") <- unlist(control) # Return Value: rho } # ------------------------------------------------------------------------------ # .archmGamma = # function(alpha = 0.5, type = archmList()) # { # A function implemented by Diethelm Wuertz # # # Description: # # Gini's gamma by integration for Archimedean copulae # # # FUNCTION: # # # Type: # type = match.arg(type) # Type = as.integer(type) # # # Check alpha: # check = archmCheck(alpha, type) # # # Specification: # spec = copulaSpec("archm", model = list(alpha = alpha, type = type)) # # # Internal Function: # fun = function(x, spec) { # f = NULL # for ( y in x ) # f = c( f, 4*(pcopula(y, y, spec) + pcopula(y, 1-y, spec) - y) ) # f } # # # Integration: # ans = integrate(fun, c(0, 0), c(1, 1), spec = spec) # # # Result: # gamma = ans$value # attr(gamma, "control") <- unlist(ans[-1]) # # # Return Value: # gamma # } ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE TAIL COEFFICIENT: # archmTailCoeff Computes tail dependence for Archimedean copulae # archmTailPlot Plots Archimedean tail dependence function archmTailCoeff = function(alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Tail Dependence for Archimedean copulae # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) # Tail Coefficient: N = 20 x = 1 - (1/2)^(1:N) lambdaU.Cuv = ( 1 - 2*x + parchmCopula(u = x, v = x, alpha = alpha, type = type) ) / (1-x) lambdaU.Phi = 2 - 2 * .invPhiFirstDer(2*x, alpha = alpha, type = type) / .invPhiFirstDer(x, alpha = alpha, type = type) # Return Value: list(lambdaU.Cuv = lambdaU.Cuv, lambdaU.Phi = lambdaU.Phi) } # ------------------------------------------------------------------------------ archmTailPlot = function(alpha = NULL, type = archmList(), tail = c("Upper", "Lower")) { # A function implemented by Diethelm Wuertz # Description: # Plots tail dependence for elliptical copulae # Arguments: # rho - a numeric value setting the coorelation strength, ranging # between minus one and one. # FUNCTION: # Match Arguments: type = match.arg(type) Type = as.integer(type) tail = match.arg(tail) # Settings: Title = paste("Archimedean Copula No.", 1:22) names(Title) = paste(1:22) Title = Title[type] N = 1000; Points = 20 # don't change these values! u = (0:N)/N # Plot Frame: plot(c(0, 1), c(0, 1), type = "n", main = Title, xlab = "u", ylab = paste(tail, "Tail Dependence")) # Iterate alpha: B = 10 lower = max(archmRange(type)[1], -B) upper = min(archmRange(type)[2], B) # Select alpha: if (is.null(alpha)) { # from range: Alpha = seq(lower, upper, length = 5) } else { # from arguments: Alpha = alpha } # Do for all alpha: for (alpha in Alpha) { # Compute Copula Tail dependence lambda: C.uu = parchmCopula(u, alpha = alpha, type = type) if (tail == "Upper") { lambdaTail = (1-2*u+C.uu)/(1-u) } else if (tail == "Lower") { lambdaTail = C.uu/u } # Add Parameter Labels: text(x = 0.52, y = lambdaTail[floor(N/2)]+0.025, col = "red", cex = 0.7, labels = as.character(round(alpha, 2))) # Add Lines: lines(u, lambdaTail, lty = 3, col = "black") # Add Points to Curves: if (tail == "Upper") { Index = round(seq(1, N-1, length = Points)) X = 1 } else if (tail == "Lower") { Index = round(seq(1, N-1, length = Points)) + 1 X = 0 } points(u[Index], lambdaTail[Index], col = "steelblue", pch = 19, cex = 0.7) } abline(h = 0, lty = 3, col = "grey") abline(v = X, lty = 3, col = "grey") # Return Value: invisible() } ################################################################################ fCopulae/R/ArchimedeanCopulae.R0000644000176000001440000007357611370220745016120 0ustar ripleyusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE RANDOM VARIATES: # rarchmCopula Generates Archimedean copula random variates # .rNo1Copula Generates rv's for copulae No 1 # .rNo2Copula Generates rv's for copulae No 2 # FUNCTION: ARCHIMEDEAN COPULAE PROBABILITY: # parchmCopula Computes Archimedean copula probability # .parchm1Copula Utility Function # .parchm2Copula Utility Function # FUNCTION: ARCHIMEDEAN COPULAE DENSITY: # darchmCopula Computes Archimedean copula density # .darchm1Copula Utility Function # .darchm2Copula Utility Function # FUNCTION: SPECIAL BIVARIATE COPULA: # rgumbelCopula Generates fast gumbel random variates # pgumbelCopula Computes bivariate Gumbel copula probability # dgumbelCopula Computes bivariate Gumbel copula density ################################################################################ ################################################################################ # rarchmCopula Generates Archimedean copula random variates # .r1Copula Generates rv's for copulae No 1 # .r2Copula Generates rv's for copulae No 2 rarchmCopula = function(n, alpha = NULL, type = archmList()) { # A function implemented by Diethelm Wuertz # Description: # Generates Archimedean copula random variate # FUNCTION: # Type: type = match.arg(type) Type = as.integer(type) # Alpha: if (is.null(alpha)) alpha = archmParam(type)$param # Check alpha: check = archmCheck(alpha, type) if (Type == 1) { # Use faster Algorithm: ans = .rNo1Copula(n, alpha) } else { # Generate rv's for the remaining Copulae: X = runif(n) Y = runif(n) t = .invK(Y, alpha, type) U = .invPhi(X*.Phi(t, alpha, type), alpha, type) V = .invPhi((1-X)*.Phi(t, alpha, type), alpha, type) ans = cbind(U, V) # Add Control Attribute: colnames(ans) = NULL } # Add Control List: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ .rNo1Copula = function(n, alpha = NULL, alternative = FALSE, doplot = FALSE) { # A function implemented by Diethelm Wuertz # Description: # Generates rv's for copula No 1 # Default Parameter: if (is.null(alpha)) alpha = archmParam(1)$param # Clayton Random Variate: if (alternative) { # Source: aas04.pdf X = rgamma(n, 1/alpha) V1 = runif(n) U = (1-log(V1)/X)^(-1/alpha) V2 = runif(n) V = (1-log(V2)/X)^(-1/alpha) ans = cbind(U, V) } else { # Source: armstrong03.pdf U = runif(n) W = runif(n) # W = C(V|U) => V = ( W^(-alpha/(alpha+1)) * U^(-alpha) - U^(-alpha) + 1 )^(-1/alpha) ans = cbind(U, V) } # Optional Plot: if (doplot) { plot(U, V, cex = 0.25, main = "Copula No. 1") } # Add Attribute: colnames(ans) = NULL control = list(alpha = alpha[[1]], copula = "archm", type = "1") attr(ans, "control")<-unlist(control) # Return Value: ans } # ------------------------------------------------------------------------------ .rNo2Copula = function(n, alpha = NULL, doplot = FALSE) { # A function implemented by Diethelm Wuertz # HERE IS SOMETHING WRONG !!!! # Description: # Generates rv's for copula No 2 # Source: armstrong03.pdf # Default Parameter: if (is.null(alpha)) alpha = archmParam(2)$param # Random Variates: U = runif(n) W = runif(n) # W = C(V|U) => V = 1 - ( (1-U)^alpha * (W^(alpha/(1-alpha)) - 1 ) + 1 ) ^ (1/alpha) ans = cbind(U, V) # Optional Plot: if (doplot) { plot(U, V, cex = 0.25, main = "Copula No. 2") } # Add Attribute: colnames(ans) = NULL control = list(alpha = alpha[[1]], copula = "archm", type = "2") attr(ans, "control")<-unlist(control) # Return Value: ans } ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE PROBABILITY: # parchmCopula Computes Archimedean copula probability # .parchm1Copula Utility Function # .parchm2Copula Utility Function parchmCopula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula probability # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # alpha - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'eparchParam'. # type - the type of the Archimedean copula. An integer or character # string selected from: "1", ..., "22". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the probability be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: parchmCopula((0:10)/10) # persp(parchmCopula(u = grid2d(), output = "list")) # FUNCTION: # Copula: if (alternative) { ans = .parchm2Copula(u, v, alpha, type, output) } else { ans = .parchm1Copula(u, v, alpha, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ .parchm1Copula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Compute Maximum Extreme Value Copulae # Arguments: # see function: parchmCopula # Example: # Diagonal Value: .parchm1Copula((0:10)/10) # persp(.parchm1Copula(u = grid2d(), output = "list")) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[,1] u = u[,2] } # Consider Special Copulae: if (alpha == 0 & Type == 1) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 3) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 1 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 9) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 10) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 11) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 13) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 19) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 20) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 21) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 0 & Type == 22) { C.uv = pfrechetCopula(u, v, type = "pi") } else { C.uv = .invPhi(.Phi(u, alpha, type) + .Phi(v, alpha, type), alpha, type) } # Require special attention for No. 20: if (type == "20") { C.uv = C.uv + (1-sign(C.uv)) * pfrechetCopula(u, v, type = "m") } # Simulate max function: C.uv = (C.uv + abs(C.uv))/2 # Correct C(u,v) on Boundary of Unit Square: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(C.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } # ------------------------------------------------------------------------------ .parchm2Copula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list") ) { # A function implemented by Diethelm Wuertz # Description: # Arguments: # see function: parchmCopula # Example: # Diagonal Value: .parchm2Copula((0:10)/10) # persp(.parchm2Copula(u = grid2d(), output = "list")) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Consider Special Copulae: if (alpha == 0 & Type == 1) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 3) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "w") } else if (alpha == 1 & Type == 7) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 9) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 10) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 11) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 1 & Type == 13) { C.uv = pfrechetCopula(u, v, type = "pi") } else if (alpha == 0 & Type == 19) { C.uv = pfrechetCopula(u, v, type = "psp") } else if (alpha == 0 & Type == 20) { C.uv = pfrechetCopula(u, v, type = "pi") } else { if (Type == 1) {# Clayton Copula C.uv = (u^(-alpha)+v^(-alpha)-1)^(-1/alpha) } if (Type == 2) { X = 1-((1-u)^alpha+(1-v)^alpha)^(1/alpha) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 3) { C.uv = u*v/(1-alpha*(1-u)*(1-v)) } if (Type == 4) { # Gumbel Copula C.uv = exp( -((-log(u))^(alpha)+(-log(v))^(alpha))^(1/alpha)) } if (Type == 5) { # Frank Copula C.uv = -1/alpha*log(1+(exp(-alpha*u)-1)* (exp(-alpha*v)-1)/(exp(-alpha)-1)) } if (Type == 6) { C.uv = 1-((1-u)^alpha+(1-v)^alpha-(1-u)^alpha* (1-v)^alpha)^(1/alpha) } if (Type == 7) { X = alpha*u*v+(1-alpha)*(u+v-1) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 8) { X = (alpha^2*u*v-(1-u)*(1-v))/(alpha^2-(alpha-1)^2*(1-u)*(1-v)) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 9) { C.uv = u*v*exp(-alpha*log(u)*log(v)) } if (Type == 10) { C.uv = u*v/(1+(1-u^alpha)*(1-v^alpha))^(1/alpha) } if (Type == 11) { X = (u^alpha*v^alpha-2*(1-u^alpha)*(1-v^alpha))^(1/alpha) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 12) { C.uv = (1+((u^(-1)-1)^alpha+(v^(-1)-1)^alpha)^(1/alpha))^(-1) } if (Type == 13) { C.uv = exp(1-((1-log(u))^alpha+(1-log(v))^alpha-1)^(1/alpha)) } if (Type == 14) { C.uv = (1+((u^(-1/alpha)-1)^alpha + (v^(-1/alpha)-1)^alpha)^(1/alpha))^(-alpha) } if (Type == 15) { X = (1-((1-u^(1/alpha))^alpha + (1-v^(1/alpha))^alpha )^(1/alpha) )^alpha Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 16) { C.uv = 1/2*((u+v-1-alpha*(1/u+1/v-1))+ sqrt((u+v-1-alpha*(1/u+1/v-1))^2+4*alpha)) } if (Type == 17) { C.uv = (1+((1+u)^(-alpha)-1)* ((1+v)^(-alpha)-1)/(2^(-alpha)-1))^(-1/alpha)-1 } if (Type == 18) { eps = 1/10^8 u = u - eps*(1-sign(1-u)) v = v - eps*(1-sign(1-v)) X = 1+alpha/log(exp(alpha/(u-1))+exp(alpha/(v-1))) Y = rep(0, times = length(X)) C.uv = apply(cbind(X, Y), 1, max) } if (Type == 19) { C.uv = alpha/log(exp(alpha/u)+exp(alpha/v)-exp(alpha)) } if (Type == 20) { a.range = "(0, Inf)" C.uv = (log(exp(1/u^alpha)+exp(1/v^alpha)-exp(1)))^(-1/alpha) C.uv = C.uv + (1-sign(C.uv)) * pfrechetCopula(u, v, type = "m") } if (Type == 21) { # NOT YET IMPLEMENTED warning("No. 21 alternative not active") C.uv = NA # USE: C.uv = .parchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output ) return(C.uv) } if (Type == 22) { # NOT YET IMPLEMENTED warning("No. 22 alternative not active") C.uv = NA # USE: C.uv = .parchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output ) return(C.uv) } } # Simulate max function: C.uv = (C.uv + abs(C.uv))/2 # Correct C(u,v) on Boundary of Unit Square: C.uv[is.na(C.uv)] = 0 C.uv[which(u == 0)] = 0 C.uv[which(u == 1)] = v[which(u == 1)] C.uv[which(v == 0)] = 0 C.uv[which(v == 1)] = u[which(v == 1)] C.uv[which(u*v == 1)] = 1 C.uv[which(u+v == 0)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(C.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] C.uv = list(x = x, y = y, z = matrix(C.uv, ncol = N)) } # Return Value: C.uv } ################################################################################ # FUNCTION: ARCHIMEDEAN COPULAE DENSITY: # darchmCopula Computes Archimedean copula density # .darchm1Copula Utility Function # .darchm2Copula Utility Function darchmCopula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list"), alternative = FALSE ) { # A function implemented by Diethelm Wuertz # Description: # Computes extreme value copula density # Arguments: # u, v - two numeric values or vectors of the same length at # which the copula will be computed. If 'u' is a list then the # the '$x' and '$y' elements will be used as 'u' and 'v'. # If 'u' is a two column matrix then the first column will # be used as 'u' and the the second as 'v'. # alpha - a numeric value or vector of named parameters as # required by the copula specified by the variable 'type'. # If set to NULL, then the parameters will be taken as # specified by the function 'archmParam'. # type - the type of the Archimedean copula. An integer or character # string selected from: "1", ..., "22". # output - a character string specifying how the output should # be formatted. By default a vector of the same length as # 'u' and 'v'. If specified as "list" then 'u' and 'v' are # expected to span a two-dimensional grid as outputted by the # function 'grid2d' and the function returns a list with # elements '$x', 'y', and 'z' which can be directly used # for example by 2D plotting functions. # alternative - Should the probability be computed alternatively # in a direct way from the probability formula or by default # via the dependency function? # Value: # returns a vector or list of probabilities depending on the # value of the "output" variable. # Example: # Diagonal Value: darchmCopula((0:10)/10) # persp(darchmCopula(u=grid2d(), output="list"), theta=-40, phi=30, xlab="x") # FUNCTION: # Copula: if (alternative) { ans = .darchm2Copula(u, v, alpha, type, output) } else { ans = .darchm1Copula(u, v, alpha, type, output) } # Return Value: ans } # ------------------------------------------------------------------------------ .darchm1Copula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes Density of Maximum Extreme Value Copulae # References: # Nelsen # Matteis, Diploma Thesis # Carmona, Evanesce # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Density: c.uv = .invPhiSecondDer( .Phi(u, alpha, type) + .Phi(v, alpha, type), alpha, type ) / ( .invPhiFirstDer(.Phi(u, alpha, type), alpha, type) * .invPhiFirstDer(.Phi(v, alpha, type), alpha, type) ) # c.uv[which(u*v == 0 | u*v == 1)] = 0 # Replace NAs: # c.uv[is.na(c.uv)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(c.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } # ------------------------------------------------------------------------------ .darchm2Copula = function(u = 0.5, v = u, alpha = NULL, type = archmList(), output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Extreme Value Copulae # References: # Carmona, Evanesce # Matteis, Diploma Thesis # Notes: # "4" Gumbel(alpha->1) -> m-Copula min(u,v) # Example: # persp(z = matrix(.darchm1Copula(.gridCoord()$x, .gridCoord()$y, 1.1, "4"), 101)) # FUNCTION: # Match Arguments: output = match.arg(output) # Type: type = match.arg(type) Type = as.integer(type) # Settings: if (is.null(alpha)) { alpha = archmParam(type)$param } a = alpha if (is.list(u)) { v = u[[2]] u = u[[1]] } if (is.matrix(u)) { v = u[, 1] u = u[, 2] } # Density: if (Type == 1) { c.uv = (1 + a)*u^(-1 - a)*v^(-1 - a) * (-1 + u^(-a) + v^(-a))^(-2 - a^(-1)) } if (Type == 2) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 2 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 3) { c.uv = (-1 + a^2*(-1 + u + v - u*v) - a*(-2 + u + v + u*v)) / (-1 + a*(-1 + u)*(-1 + v))^3 } if (Type == 4) { # Matteis yields wrong results! # c.uv = ((-log(u))^(-1 + a)*(-1 + a + ((-log(u))^a + # (-log(v))^a)^a^(-1))*((-log(u))^a + # (-log(v))^a)^(-2 + a^(-1))*(-log(v))^(-1 + a))/ # (exp((-log(u))^a + (-log(v))^a)^a^(-1)*u*v) # Use instead: c.uv = exp(-((-log(u))^alpha+(-log(v))^alpha)^(1/alpha)) * (- (-log(u))^alpha*(-log(v))^alpha*((-log(u))^alpha + (-log(v))^alpha)^(1/alpha)+(-log(u))^alpha*(-log(v))^alpha * ( (-log(u))^alpha+(-log(v))^alpha)^(1/alpha)*alpha + (-log(u))^(3*alpha)*(-log(v))^alpha*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha)+2*(-log(u))^(2*alpha) * (-log(v))^(2*alpha)*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha)+(-log(u))^alpha * (-log(v))^(3*alpha)*((-log(u))^alpha + (-log(v))^alpha)^(-2*(alpha-1)/alpha))/log(v)/log(u)/v/u / ( (-log(u))^(2*alpha)+2*(-log(u))^alpha*(-log(v))^alpha + (-log(v))^(2*alpha)) } if (Type == 5) { c.uv = (a*exp(a*(1 + u + v))*(-1 + exp(a)))/(exp(a) - exp(a + a*u) + exp(a*(u + v)) - exp(a + a*v))^2 } if (Type == 6) { c.uv = (1 - u)^(-1 + a)*(a - (-1 + (1 - u)^a)*(-1 + (1 - v)^a)) * ((1 - u)^a + (1 - v)^a - (1 - u)^a * (1 - v)^a)^(-2 + a^(-1)) * (1 - v)^(-1 + a) } if (Type == 7) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 7 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 8) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 8 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 9) { c.uv = (1 - a - a*log(v) + a*log(u)*(-1 + a*log(v))) / exp(a*log(u)*log(v)) } if (Type == 10) { c.uv = (2 - v^a + u^a*(-1 + v^a))^(-2 - a^(-1)) * (4 - 2*v^a + u^a*(-2 - (-1 + a)*v^a)) } if (Type == 11) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 11 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 12) { c.uv = ((-1+u^(-1))^a*(-1+a+((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1)+a*((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1))*((-1+u^(-1))^a + (-1+v^(-1))^a)^(-2+a^(-1))*(-1+v^(-1))^a)/ ((-1+u)*u*(1+((-1+u^(-1))^a + (-1+v^(-1))^a)^a^(-1))^3*(-1+v)*v) } if (Type == 13) { c.uv = (exp(1 - (-1 + (1 - log(u))^a + (1 - log(v))^a)^a^(-1)) * (1 - log(u))^(-1 + a)*(-1 + a + (-1 + (1 - log(u))^a + (1 - log(v))^a)^a^(-1))*(-1 + (1 - log(u))^a + (1 - log(v))^a)^(-2 + a^(-1)) * (1 - log(v))^(-1 + a))/(u*v) } if (Type == 14) { c.uv = ((-1+u^(-a^(-1)))^a*(-1+v^(-a^(-1)))^a * ((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^(-2+a^(-1)) * (1+((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^a^(-1))^(-2-a) * (-1+a+2*a*((-1+u^(-a^(-1)))^a + (-1+v^(-a^(-1)))^a)^a^(-1))) / (a*u*(-1+u^a^(-1))*v*(-1+v^a^(-1))) } if (Type == 15) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 15 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 16) { c.uv = (2*a*(a^2 + u^2*v^2 + a*(u^2 + v^2))) / (sqrt(4*a + (-1 + u - a*(-1 + u^(-1) + v^(-1)) + v)^2) * (u^2*v^2*(-1 + u + v)^2 + a^2*(u + v - u*v)^2 + 2*a*u*v*(u^2*(-1 + v) - (-1 + v)*v + u*(1 - v + v^2)))) } if (Type == 17) { c.uv = (2^a*((-1 + 2^a)*a*(1 + u)^a*(1 + v)^a + 2^a*(-1 + (1 + u)^a) * (-1 + (1 + v)^a)))/((1 + u)*(1 + v)*(2^a - 2^a*(1 + u)^a - 2^a*(1 + v)^a + (1 + u)^a*(1 + v)^a)^2 * (1 + ((-1 + (1 + u)^(-a)) * (-1 + (1 + v)^(-a))) / (-1 + 2^(-a)))^a^(-1)) } if (Type == 18) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 18 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 19) { c.uv = (a^3*exp(a*(u^(-1) + v^(-1)))*(2 + log(-exp(a) + exp(a/u) + exp(a/v))))/((-exp(a) + exp(a/u) + exp(a/v))^2*u^2*v^2*log(-exp(a) + exp(a/u) + exp(a/v))^3) } if (Type == 20) { c.uv = (exp(u^(-a) + v^(-a))*u^(-1 - a)*v^(-1 - a) * log(-exp(1) + exp(u^(-a)) + exp(v^(-a)))^(-2 - a^(-1)) * (1 + a + a*log(-exp(1) + exp(u^(-a)) + exp(v^(-a))))) / (-exp(1) + exp(u^(-a)) + exp(v^(-a)))^2 } if (Type == 21) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 21 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } if (Type == 22) { # NOT YET IMPLEMENTED! c.uv = NA # USE: warning("No 22 alternative not available") c.uv = .darchm1Copula(u = u, v = v, alpha = alpha, type = type, output = output) return(c.uv) } # Replace NAs: # c.uv[is.na(c.uv)] = 0 # Add Control Attribute: control = list(alpha = alpha[[1]], copula = "archm", type = type) attr(c.uv, "control")<-unlist(control) # As List ? if (output == "list") { N = sqrt(length(u)) x = u[1:N] y = matrix(v, ncol = N)[1, ] c.uv = list(x = x, y = y, z = matrix(c.uv, ncol = N)) } # Return Value: c.uv } ################################################################################ rgumbelCopula = function(n = 100, alpha = 2) { # A function implemented by Diethelm Wuertz # Description: # Generates fast gumbel random variates # FUNCTION: # Stable RVs: dim = 2 theta <- runif(n, 0, pi) w <- rexp(n) b = 1/alpha a <- sin((1-b)*theta)*(sin(b*theta))^(b/(1-b)) / (sin(theta))^(1/(1-b)) fr = (a/w)^((1-b)/b) fr <- matrix(fr, nrow = n, ncol = dim) val <- matrix(runif(dim * n), nrow = n) s = -log(val)/fr # Bivariate Gumbel RVs: ans = exp(-s^(1/alpha) ) # Return Value: ans } # ------------------------------------------------------------------------------ pgumbelCopula = function(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes bivariate Gumbel copula probability # FUNCTION: # Bivariate Gumbel Probability: ans = parchmCopula (u, v, alpha, type = "4", output = output, alternative = FALSE) # Return Value: ans } # ------------------------------------------------------------------------------ dgumbelCopula = function(u = 0.5, v = u, alpha = 2, output = c("vector", "list")) { # A function implemented by Diethelm Wuertz # Description: # Computes bivariate Gumbel copula density # FUNCTION: # Bivariate Gumbel Density: ans = darchmCopula (u, v, alpha, type = "4", output = output, alternative = FALSE) # Return Value: ans } ################################################################################ fCopulae/NAMESPACE0000644000176000001440000001056611462277116013276 0ustar ripleyusers ################################################ ## import name space ################################################ import("sn") import("methods") import("timeDate") import("timeSeries") ################################################ ## useDynLib ################################################ useDynLib("fCopulae") ################################################ ## S4 classes ################################################ exportClasses("fCOPULA", "fMV" ) exportMethods("show" ) ################################################ ## S3 classes ################################################ S3method("plot", "fMV") S3method("plot", "hexBinning") S3method("plot", "squareBinning") S3method("summary", "fMV") ################################################ ## functions ################################################ export( ".AfuncFirstDer", ".AfuncSecondDer", ".Debye", ".Debye1", ".Kfunc", ".Phi", ".Phi0", ".PhiFirstDer", ".PhiSecondDer", ".TInt", ".TOwen", ".archm2Tau", ".archmRho", ".archmTau", ".archmTauRange", ".copulaRho", ".darchm1Copula", ".darchm2Copula", ".darchmContourSlider", ".darchmPerspSlider", ".dcauchyCopula", ".delliptical", ".delliptical2dSlider", ".dellipticalContourSlider", ".dellipticalCopulaGrid", ".dellipticalPerspSlider", ".dev1Copula", ".dev2Copula", ".devContourSlider", ".devPerspSlider", ".dmoCopula", ".dnorm2d", ".dnormCopula", ".dtCopula", ".ellipticalRho", ".ev1Rho", ".ev1Tau", ".ev2Rho", ".ev2Tau", ".getfCopulaeEnv", ".gfunc2d", ".invK", ".invK2", ".invPhi", ".invPhiFirstDer", ".invPhiSecondDer", ".makeConcordanceTable", ".mvsnorm.plot.1", ".mvsnorm.plot.1A", ".mvsnorm.plot.1B", ".mvsnorm.plot.2", ".mvsnorm.plot.3", ".mvsnorm.plot.4", ".mvsnorm.plot.5", ".mvsnormFit", ".mvsnormPlot", ".mvst.plot.1", ".mvst.plot.1A", ".mvst.plot.1B", ".mvst.plot.2", ".mvst.plot.3", ".mvst.plot.4", ".mvst.plot.5", ".mvstFit", ".mvstPlot", ".parchm1Copula", ".parchm2Copula", ".parchmContourSlider", ".parchmPerspSlider", ".pcauchyCopula", ".pelliptical", ".pellipticalContourSlider", ".pellipticalCopulaDiag", ".pellipticalCopulaGrid", ".pellipticalPerspSlider", ".pev1Copula", ".pev2Copula", ".pevContourSlider", ".pevPerspSlider", ".pmoCopula", ".pnorm2d", ".pnormCopula", ".ptCopula", ".qelliptical", ".qlogistic", ".qlogisticData", ".rNo1Copula", ".rNo2Copula", ".rcauchyCopula", ".rnorm2d", ".rnormCopula", ".rtCopula", ".setfCopulaeEnv", "Afunc", "AfuncSlider", "Kfunc", "KfuncSlider", "Phi", "PhiSlider", "adapt", "archmCheck", "archmCopulaFit", "archmCopulaSim", "archmList", "archmParam", "archmRange", "archmRho", "archmTailCoeff", "archmTailPlot", "archmTau", "contour.gridData", "darchmCopula", "darchmSlider", "dcauchy2d", "delliptical2d", "dellipticalCopula", "dellipticalSlider", "dempiricalCopula", "density2d", "devCopula", "devSlider", "dgumbelCopula", "dmvsnorm", "dmvst", "dnorm2d", "dt2d", "ellipticalCheck", "ellipticalCopulaFit", "ellipticalCopulaSim", "ellipticalList", "ellipticalParam", "ellipticalRange", "ellipticalRho", "ellipticalTailCoeff", "ellipticalTailPlot", "ellipticalTau", "evCheck", "evCopulaFit", "evCopulaSim", "evList", "evParam", "evRange", "evRho", "evTailCoeff", "evTailCoeffSlider", "evTau", "gfunc", "gfuncSlider", "grid2d", "gridData", "hexBinning", "hist2d", "integrate2d", "mvFit", "parchmCopula", "parchmSlider", "pcauchy2d", "pellipticalCopula", "pellipticalSlider", "pempiricalCopula", "persp.gridData", "pevCopula", "pevSlider", "pfrechetCopula", "pgumbelCopula", "pmvsnorm", "pmvst", "pnorm2d", "print.integration", "pt2d", "rarchmCopula", "rarchmSlider", "rcauchy2d", "rellipticalCopula", "rellipticalSlider", "revCopula", "revSlider", "rgumbelCopula", "rmvsnorm", "rmvst", "rnorm2d", "rt2d", "squareBinning" ) fCopulae/DESCRIPTION0000644000176000001440000000146612121533602013550 0ustar ripleyusersPackage: fCopulae Version: 3000.79 Revision: 5463 Date: 2013-03-18 Title: Rmetrics - Dependence Structures with Copulas Author: Diethelm Wuertz and many others, see the SOURCE file Depends: R (>= 2.4.0), sn, methods, timeDate, timeSeries, fBasics (>= 2100.78) Suggests: RUnit, tcltk Maintainer: Yohan Chalabi Description: Environment for teaching "Financial Engineering and Computational Finance" Note: Several parts are still preliminary and may be changed in the future. this typically includes function and argument names, as well as defaults for arguments and return values. LazyData: yes License: GPL (>= 2) URL: http://www.rmetrics.org Packaged: 2013-03-18 05:17:49 UTC; yankee NeedsCompilation: yes Repository: CRAN Date/Publication: 2013-03-18 07:43:14 fCopulae/ChangeLog0000644000176000001440000000327112121521575013616 0ustar ripleyusers2013-03-15 chalabi * DESCRIPTION: Updated maintainer field and version number * R/zzz.R: Removed depcrecated .First.lib() * R/bv-dnorm.R: Removed trailing whitespaces 2011-09-23 mmaechler * DESCRIPTION: remove deprecated "LazyLoad" entry 2010-10-26 chalabi * NAMESPACE: updated NAMESPACE 2010-07-23 chalabi * inst/DocCopying.pdf: removed DocCopying.pdf license is already specified in DESCRIPTION file 2009-10-27 chalabi * ChangeLog, DESCRIPTION: updated Changelog and DESCRIPTION file * DESCRIPTION, src/adapt_callback.c: added declaration of FORTRAN routine in C before use 2009-10-16 chalabi * NAMESPACE: updated NAMESPACE 2009-10-16 wuertz * DESCRIPTION, R/builtin-adapt.R, man/builtin-adapt.Rd, src, src/adapt2.f, src/adapt_callback.c: adapt added 2009-09-28 chalabi * DESCRIPTION: updated version number * ChangeLog, DESCRIPTION: updated DESCR and ChangeLog * NAMESPACE: new NAMESPACE structure which should ease maintenance of packages. 2009-06-25 chalabi * DESCRIPTION: Merge branch 'devel-timeSeries' Conflicts: pkg/timeSeries/R/base-Extract.R pkg/timeSeries/R/timeSeries.R 2009-04-19 chalabi * DESCRIPTION: added explicit version number in Depends field for key packages 2009-04-02 chalabi * DESCRIPTION: more explicit depends and suggests field in DESC file. * NAMESPACE: updated NAMESPACE * DESCRIPTION: updated DESC file 2009-01-28 chalabi * man/ArchimedeanCopulae.Rd, man/ArchimedeanDependency.Rd, man/ArchimedeanModelling.Rd, man/EmpiricalCopulae.Rd, man/ExtremeValueCopulae.Rd, man/ExtremeValueDependency.Rd, man/ExtremeValueGenerator.Rd, man/ExtremeValueModelling.Rd: updated manual pages to new Rd parser