fMultivar/0000755000176000001440000000000012402627212012251 5ustar ripleyusersfMultivar/inst/0000755000176000001440000000000012402605560013230 5ustar ripleyusersfMultivar/inst/unitTests/0000755000176000001440000000000012402605560015232 5ustar ripleyusersfMultivar/inst/unitTests/runit.BivariateBinning.R0000644000176000001440000000464712402605560021743 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 ################################################################################ # 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() } ################################################################################ fMultivar/inst/unitTests/Makefile0000644000176000001440000000042112402605560016667 0ustar ripleyusersPKG=fMultivar 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}fMultivar/inst/unitTests/runTests.R0000644000176000001440000000453112402605560017207 0ustar ripleyuserspkg <- "fMultivar" 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") } ################################################################################ fMultivar/inst/unitTests/runit.BivariateDistributions.R0000644000176000001440000001350512402605560023212 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 ################################################################################ # FUNCTION: DESCRIPTION: # grid2d Returns from two vectors x-y grid coordinates # density2d Returns 2D Kernel Density Estimates # hist2d Returns 2D Histogram Counts # 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 # REQUIREMENTS: # fBasics::.perspPlot # fBasics::.contourPlot ################################################################################ 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.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(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() } ################################################################################ fMultivar/inst/unitTests/runit.BivariateGridding.R0000644000176000001440000000555012402605560022100 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 ################################################################################ # FUNCTION: DESCRIPTION: # 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 # REQUIREMENT: DESCRIPTION: # akima Package # spatial Package ################################################################################ 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() { # 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: require(akima) 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() } ################################################################################ fMultivar/inst/obsolete/0000755000176000001440000000000012402605560015044 5ustar ripleyusersfMultivar/inst/obsolete/src/0000755000176000001440000000000012402605560015633 5ustar ripleyusersfMultivar/inst/obsolete/src/adapt_callback.c0000644000176000001440000000303312402605560020703 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); } fMultivar/inst/obsolete/src/adapt2.f0000644000176000001440000005111712402605560017162 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 fMultivar/inst/obsolete/R/0000755000176000001440000000000012402605560015245 5ustar ripleyusersfMultivar/inst/obsolete/R/utils-adapt.R0000644000176000001440000001534412402605560017626 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 ################################################################################ # FUNCTION: DESCRIPTION: # adapt Integrates over a two dimensional unit square ################################################################################ # 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 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 = "fMultivar")[ 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" # Return Value: x } # ------------------------------------------------------------------------------ # print.integration <- function(x, ...) { # print(noquote(sapply(x, format, ...)),...) # invisible(x) #} ################################################################################ fMultivar/inst/obsolete/man/0000755000176000001440000000000012402605560015617 5ustar ripleyusersfMultivar/inst/obsolete/man/utils-adapt.Rd0000644000176000001440000001011112402605560020327 0ustar ripleyusers\name{utils-adapt} \alias{adapt} \title{Integrator for multivariate distributions} \description{ The function is for adaptive quadrature. The underlyling fortran code is purported to work in from 2 to 20 dimensions. } \usage{ adapt(ndim, lower, upper, minpts = 100, maxpts = NULL, functn, eps = 0.01, \dots) } \details{ The function computes computes an n-dimensional integral between lower and upper bounds. Infinite rectangles are not allowed, and the number of dimensionas must be between 2 and 20. The function is modified from Mike Meyer's S code. The functions just calls 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{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 \code{r(d) = 2^d + 2 d(d + 3) + 1}. } \arguments{ \item{ndim}{ the dimension of the integral. } \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 NULL per default, see 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{class} \code{"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. } } %\references{} %\author{} \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} fMultivar/tests/0000755000176000001440000000000012402605560013415 5ustar ripleyusersfMultivar/tests/doRUnit.R0000644000176000001440000000151612402605560015127 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) } fMultivar/NAMESPACE0000644000176000001440000000065612402605560013501 0ustar ripleyusers################################################################################ ## Exports ################################################################################ exportPattern("^[^\\.]") ################################################################################ ## Imports ################################################################################ import("timeDate") import("timeSeries") import("fBasics") fMultivar/NEWS0000644000176000001440000000224212402605560012752 0ustar ripleyusers NEWS Package fMultivar provides functions which might be useful for the analysis and modeling of bivariate and multivariae financial return distributions. 2014 The contributed Package "SN" has essently improved over the years. Therefore we have removed the "SN" builtin functions for the density, probability, and random number generators. We recommend to call the functions directly from "SN". Thus also the functions from *mvnorm, *mvt, and *mvstnorm are obsolete, they will no longer be supported. Conveniance wrappers for "SN" parameter estimation have been added. 2013 Contributed Package "cubature" offers an adaptive integration function. We recommend to use this, the former builtin function "adapt"" has become a wrapper for "cubature::adaptIntegrate. The compiled FORTRAN code provided in directory "src" is no longer required. 2012 We have added a NAMESPACE. 2007 The adapt Package has been removed from CRAN. A builtin function with licensed FORTRAN Code fom Professor Genz has been implemented to fill this gap. 2005 The fMultivar was uploaded to CRAN. fMultivar/R/0000755000176000001440000000000012402605560012454 5ustar ripleyusersfMultivar/R/bvdist-norm2d.R0000644000176000001440000002121212402605560015267 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 ################################################################################ # FUNCTION: BIVARIATE NORMAL DISTRIBUTION: # dnorm2d Computes bivariate Normal density function # pnorm2d Computes bivariate Normal probability 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 } ############################################################################### fMultivar/R/zzz-mvstnorm.R0000644000176000001440000000616312402605560015325 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 ################################################################################ # FUNCTION: DESCRIPTION: # dmvsnorm # pmvsnorm # rmvsnorm # FUNCTION: DESCRIPTION: # dmvst # pmvst # rmvst ################################################################################ ################################################################################ # Obsolete Functions: # # 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) # ----------------------------------------------------------------------------- dmvsnorm <- function(x, dim=2, mu=rep(0, dim), Omega=diag(dim), alpha=rep(0, dim)) sn::dmsn(x=x, xi=mu, Omega=Omega, alpha=alpha) pmvsnorm <- function(q, dim=2, mu=rep(0, dim), Omega=diag(dim), alpha=rep(0, dim)) sn::pmsn(x=q, xi=mu, Omega=Omega, alpha=alpha) rmvsnorm <- function(n, dim=2, mu=rep(0, dim), Omega=diag(dim), alpha=rep(0, dim)) sn::rmsn(n=n, xi=mu, Omega=Omega, alpha=alpha) # ----------------------------------------------------------------------------- dmvst <- function(x, dim=2, mu=rep(0, dim), Omega=diag(dim), alpha=rep(0, dim), df=4) sn::dmst(x=x, xi=mu, Omega=Omega, alpha=alpha, nu=df) pmvst <- function(q, dim=2, mu=rep(0, dim), Omega=diag(dim), alpha=rep(0, dim), df=4) sn::pmst(x=q, xi=mu, Omega=Omega, alpha=alpha, nu=df) rmvst <- function(n, dim=2, mu=rep(0, dim), Omega=diag(dim), alpha=rep(0, dim), df=4) sn::rmst(n=n, xi=mu, Omega=Omega, alpha=alpha, nu=df) ############################################################################### mvFit <- function(x, method = c("snorm", "st"), fixed.df = NA, title = NULL, description = NULL, trace = FALSE) { method <- match.arg(method) if (method == "snorm") { ans <- msnFit(x, trace=trace) } if (method == "st") { if (is.na(fixed.df)) fixed.nu <- NULL else fixed.nu <- fixed.df ans <- mstFit(x, fixed.nu=fixed.nu, trace=trace) } # Return Value: ans } ############################################################################### fMultivar/R/bvdist-t2d.R0000644000176000001440000001002312402605560014555 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 ################################################################################ # 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 # REQUIRES: # mvtnorm ################################################################################ pt2d <- function(x, y = x, rho = 0, nu = 4) { # pt2d: Uses pmvt 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 <- pmvt(X, dim = 2, mu = c(0, 0), Omega = sigma, # alpha = c(0, 0), df = nu) .pmvt <- function(x, delta, sigma, df) mvtnorm::pmvt( lower = -Inf, upper = x, delta = delta, sigma = sigma, df = df) ans <- apply(X, 1, ".pmvt", delta = c(0,0), sigma = sigma, 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 } ############################################################################### fMultivar/R/zzz-mvnorm.R0000644000176000001440000000236112402605560014752 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 ############################################################################### # FUNCTION: DESCRIPTION: # dmvnorm Multivariate Normal Density function # pmvnorm Multivariate Normal Probability function # qmvnorm Multivariate Equicoordinate Normal Quantile function # rmvnorm Multivariate Normal Random Number generator # REQUIRES: DESCRIPTION: # mvtnorm Contributed R-Package ################################################################################ fMultivar/R/mvdist-mstFit.R0000644000176000001440000000500512402605560015351 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 ################################################################################ # FUNCTION: DESCRIPTION: # dmst Multivariate Skew Student-t Density function # pmst Multivariate Skew Student-t Probability function # rmst Multivariate Skew Student-t Random Number generator # REQUIRES: DESCRIPTION: # sn Contributed R-Package # fDISTSFIT fBasics Package ################################################################################ # NOTE: # The former multivariate skew Student-t distribution functions have # been deprecated. Use instead the functions directly from contributed # Package "sn". # NOTE: # The former multivariate "mvFit" parameter estimation functions have # been deprecated. New easy to use fitting functions have been adde: # ms[cdt]Fit have been added. mstFit <- function(x, fixed.nu=NULL, trace=FALSE, title=NULL, description=NULL) { # Fit distributional Parameters: if (is.null(fixed.nu)) { fit <- sn::mst.mple( x = rep(1, nrow(x)), y = x, start=NULL, fixed.nu=NULL, trace=trace, penalty=NULL) fit$estimated <- fit$dp } else { fit <- sn::mst.mple( x = rep(1, nrow(x)), y = x, start=NULL, fixed.nu=fixed.nu, trace=trace, penalty=NULL) fit$estimated <- list(fit$dp, nu=fixed.nu) } # Add Title and Description: if (is.null(title)) title <- "Student-t Parameter Estimation" if (is.null(description)) description <- description() # Return Value: new("fDISTFIT", call = match.call(), model = "Skew Student-t Distribution", data = as.data.frame(x), fit = fit, title = title, description = description) } ############################################################################### fMultivar/R/utils-gridding2d.R0000644000176000001440000000650012402605560015753 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 ################################################################################ # 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 # REQUIREMENTS: # akima # spatial ################################################################################ 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) } ################################################################################ fMultivar/R/bvdist-cauchy2d.R0000644000176000001440000000620712402605560015577 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 ################################################################################ # 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, nu = 1) attr(ans, "control") <- c(rho = rho) # Return Value: ans } ################################################################################ fMultivar/R/mvdist-msnFit.R0000644000176000001440000000560112402605560015345 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 ################################################################################ # FUNCTION: DESCRIPTION: # dmsn Multivariate Skew Normal Density function # pmsn Multivariate Skew Normal Probability function # rmsn Multivariate Skew Normal Random Number generator # REQUIRES: DESCRIPTION: # sn Contributed R-Package # fDISTSFIT fBasics Package ############################################################################### # NOTE: # The former multivariate skew Normal distribution functions have # been deprecated. Use instead the functions directly from contributed # Package "sn". # NOTE: # The former multivariate "mvFit" parameter estimation functions have # been deprecated. New easy to use fitting functions have been adde: # ms[cdt]Fit have been added. msnFit <- function(x, trace=FALSE, title=NULL, description=NULL) { fit <- sn::msn.mle(x = rep(1, nrow(x)), y = x, start=NULL, trace=trace) fit$estimated <- fit$dp if (is.null(title)) title <- "Skew Normal Parameter Estimation" if (is.null(description)) description <- description() new("fDISTFIT", call = match.call(), model = "Skew Normal Distribution", data = as.data.frame(x), fit = fit, title = title, description = description) } ############################################################################### .mnFit <- function(x, trace = FALSE, title = NULL, description = NULL) { fit <- list() fit$dp <- NA fit$logL <- NA fit$aux <- NA fit$opt.method <- NA fit$estimated <- list( beta = colMeans(x), Omega = cov(x), alpha = rep(0, times = ncol(x)), nu = Inf) if (is.null(title)) title <- "Normal Parameter Estimation" if (is.null(description)) description <- description() new("fDISTFIT", call = match.call(), model = "Skew Normal Distribution", data = as.data.frame(x), fit = fit, title = title, description = description) } ############################################################################### fMultivar/R/utils-density2d.R0000644000176000001440000001173412402605560015650 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 ################################################################################ # FUNCTION: DESCRIPTION: # density2d Returns 2D Kernel Density Estimates # hist2d Returns 2D Histogram Counts ################################################################################ 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) } ################################################################################ fMultivar/R/utils-integrate2d.R0000644000176000001440000000475212402605560016155 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 ################################################################################ # FUNCTION: DESCRIPTION: # integrate2d Integrates over a two dimensional unit square ################################################################################ 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) } ################################################################################ fMultivar/R/utils-adapt.R0000644000176000001440000001005712402605560015031 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 ################################################################################ # FUNCTION: DESCRIPTION: # adapt Integrates over a two dimensional unit square ################################################################################ adapt <- function(ndim=NULL, lower, upper, functn, ...) { ans <- cubature::adaptIntegrate( f=functn, lowerLimit=lower, upperLimit=upper, ...) # Return Value ans } # ----------------------------------------------------------------------------- # replaced by the cubature adaptIntegrate package # you will find the code in the deprecated folder # adapt <- function (ndim, lower, upper, minpts = 100, maxpts = NULL, # functn, eps = 0.01, ...) # 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 package under the Gnu GPL2 license. You have my permission to # do this. # Sincerely, # Alan Genz ################################################################################ fMultivar/R/utils-grid2d.R0000644000176000001440000000353212402605560015113 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 ################################################################################ # FUNCTION: DESCRIPTION: # grid2d Returns from two vectors x-y grid coordinates ################################################################################ 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]) } ################################################################################ fMultivar/R/mvdist-mscFit.R0000644000176000001440000000426412402605560015336 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 ################################################################################ # FUNCTION: DESCRIPTION: # dmsc Multivariate Skew Cauchy Density function # pmsc Multivariate Skew Cauchy Probability function # rmsc Multivariate Skew Cauchy Random Number generator # REQUIRES: DESCRIPTION: # sn Contributed R-Package # fDISTSFIT fBasics Package ############################################################################### # NOTE: # The former multivariate skew Cauchy distribution functions have # been deprecated. Use instead the functions directly from contributed # Package "sn". # NOTE: # The former multivariate "mvFit" parameter estimation functions have # been deprecated. New easy to use fitting functions have been adde: # ms[cdt]Fit have been added. mscFit <- function(x, trace=FALSE, title=NULL, description=NULL) { fit <- sn::mst.mple( x = rep(1, nrow(x)), y = x, start=NULL, fixed.nu=1, trace=trace, penalty=NULL) fit$estimated <- fit$dp if (is.null(title)) title <- "Skew Cauchy Parameter Estimation" if (is.null(description)) description <- description() new("fDISTFIT", call = match.call(), model = "Skew Cauchy Distribution", data = as.data.frame(x), fit = fit, title = title, description = description) } ############################################################################### fMultivar/R/bvdist-elliptical2d.R0000644000176000001440000002255412402605560016450 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 ################################################################################ # FUNCTION: DESCRIPTION: # delliptical2d Computes density for elliptical distributions # FUNCTION: DESCRIPTION: # .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 <- match.arg(type) # 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)) } ################################################################################ fMultivar/R/utils-binning2d.R0000644000176000001440000002367112402605560015620 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 ################################################################################ # 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) } ################################################################################ fMultivar/R/zzz-mvt.R0000644000176000001440000000237512402605560014247 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 ############################################################################### # FUNCTION: DESCRIPTION: # dmvt Multivariate Student-t Density function # pmvt Multivariate Student-t Probability function # qmvt Multivariate Equicoordinate Student-t Quantile function # rmvt Multivariate Student-t Random Nuber Generator # REQUIREMENTS: DESCRIPTION: # mvtnorm Contributed R - Package ############################################################################### fMultivar/R/zzz.R0000644000176000001440000000311512402605560013434 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 ################################################################################ .onAttach <- function(libname, pkgname) { # do whatever needs to be done when the package is loaded # some people use it to bombard users with # messages using packageStartupMessage( "\n" ) packageStartupMessage( "Rmetrics Package fMultivar" ) packageStartupMessage( "Analysing and Modeling Multivariate Financial Return Distributions" ) packageStartupMessage( "Copyright (C) 2005-2014 Rmetrics Association Zurich" ) packageStartupMessage( "Educational Software for Financial Engineering and Computational Science" ) packageStartupMessage( "Rmetrics is free software and comes with ABSOLUTELY NO WARRANTY." ) packageStartupMessage( "https://www.rmetrics.org --- Mail to: info@rmetrics.org" ) } ################################################################################ fMultivar/MD50000644000176000001440000000537012402627212012566 0ustar ripleyusers2e2af13877d8495397932126ba9cde53 *ChangeLog 501f46aa9f49f43dcd0cfa6a67bec066 *DESCRIPTION 53fc749bd94a37337fb14f448f81273b *NAMESPACE 79a41558ecfadc748f2770f80ddebc45 *NEWS 839c901173563748d1ad30034a160276 *R/bvdist-cauchy2d.R 1e3e9f50b692bead0ca965ef347d471b *R/bvdist-elliptical2d.R 058acc08dddc2266c6f525dea1e05bf7 *R/bvdist-norm2d.R 37f677693b68fe23843c4e5ded24d73e *R/bvdist-t2d.R ae78cd6c4e22b0041c2cd32e019af62d *R/mvdist-mscFit.R ede029f644fe5a7d0980f44cc97fc81d *R/mvdist-msnFit.R 16b23fd73728b673775995b65bfdfa70 *R/mvdist-mstFit.R a1b5fa45a4a537cc1310ec469be62b8a *R/utils-adapt.R b136fa46d098c6e4d3f0c6c8e3e7881e *R/utils-binning2d.R 16db3053ab78c9308decfd0f4160d18f *R/utils-density2d.R 5ddddd16b3f118db35d2b1f00fb01294 *R/utils-grid2d.R d2d383f081fb37580da44085c68e1f74 *R/utils-gridding2d.R 88a467e45dfe2ef037ba709489233fef *R/utils-integrate2d.R a8707cd3827c279cbb41aae069521288 *R/zzz-mvnorm.R 1221a0abd185276767709ab39d6485f7 *R/zzz-mvstnorm.R 44e172f024b9e66b815701ad107d876f *R/zzz-mvt.R a49504ac40b5d9524ca0b541e6fe7e80 *R/zzz.R a08b37c03bd1b1ffd908af41916b914f *inst/obsolete/R/utils-adapt.R b2b09e1232abe8c632cee4da6ff0e07f *inst/obsolete/man/utils-adapt.Rd 0ae32d48faf982f676ee2721b1ea4e02 *inst/obsolete/src/adapt2.f bf0cc4d5a94a7545fdb9d6dcd73306af *inst/obsolete/src/adapt_callback.c c21a9d4df2f42ea6b9cff25c61ccbf24 *inst/unitTests/Makefile 077d37383e501be8365cc12a07aad772 *inst/unitTests/runTests.R d2bfd8970137a530ed5050b79cc0ee84 *inst/unitTests/runit.BivariateBinning.R a721cf260d3a507233745cd10024cee7 *inst/unitTests/runit.BivariateDistributions.R 0f14f5966cbd8c04c9caad7ac1e5139b *inst/unitTests/runit.BivariateGridding.R 5415d25f40c583866e97c4c4e0808456 *man/00fMultivar-package.Rd 2f116e94b60b83144c9ad07ce6bfd36a *man/bvdist-cauchy2d.Rd e9766a0cea95724986b8733c6a24cfe9 *man/bvdist-elliptical2d.Rd 4efa8cea208944b2f96974b9ce67039b *man/bvdist-norm2d.Rd b76d0cb2c66b4c3f3bac07161b0878eb *man/bvdist-t2d.Rd 262e01ec1cd79ce4227ed4a772dec5dd *man/mvdist-msc.Rd 901d0d6368be039af23e31f704e3eb17 *man/mvdist-mscFit.Rd 21b5ea20c5c235b98711cf0ab01b88cf *man/mvdist-msn.Rd c67930e35c4b842228849bdf3e9ed1a0 *man/mvdist-msnFit.Rd a6bcd92904e7fb072807d184e17a0208 *man/mvdist-mst.Rd 746a769f13e024ea838abe61c19b9636 *man/mvdist-mstFit.Rd 3c78b8b6102c6a21bc48037c57cf1ffe *man/utils-adapt.Rd a52d0b06eaead7108bd494df0d3c8128 *man/utils-binning2d.Rd a25003cf49b2ea2eb2283a2dad5e76aa *man/utils-density2d.Rd b765604102cb2b486d4904d7c8fafb48 *man/utils-grid2d.Rd 360c5436059fb80058d43f3f88e0af69 *man/utils-gridding2d.Rd ebca25b9dd2e071f3a4ad08bdb550972 *man/utils-integrate2d.Rd b0e7d4db3a9e7a5cd890483e220bee41 *man/zzz-mvnorm.Rd fc532733f8d87a3ccf2f5366400d2d20 *man/zzz-mvstnorm.Rd 6db02de0245a6f7d7a70ba2d72e9f4b4 *man/zzz-mvt.Rd ca566e590ec30abd0718c5375e1a446f *tests/doRUnit.R fMultivar/DESCRIPTION0000644000176000001440000000174612402627212013767 0ustar ripleyusersPackage: fMultivar Title: Rmetrics - Analysing and Modeling Multivariate Financial Return Distributions Date: 2014-09-04 Version: 3011.78 Author: Rmetrics Core Team, Diethelm Wuertz [aut], Tobias Setz [cre] Yohan Chalabi [ctb] Maintainer: Tobias Setz Description: Environment for teaching "Financial Engineering and Computational Finance" Depends: R (>= 2.15.1), timeDate, timeSeries, fBasics Imports: cubature, mvtnorm, sn Suggests: methods, spatial, RUnit, tcltk, akima 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: https://www.rmetrics.org Packaged: 2014-09-06 13:26:08 UTC; Tobi NeedsCompilation: no X-CRAN-Comment: Archived on 2014-08-07 as check ERRORs were not fixed even after several reminders. Repository: CRAN Date/Publication: 2014-09-06 17:55:54 fMultivar/ChangeLog0000644000176000001440000000210112402605560014017 0ustar ripleyusers ChangeLog Package fMultivar 2014-02-03 wuertz * builtin functions from mvtnorm and sn are removed * these packages are now used as Depends in DESCRIPTION file 2014-02-02 wuertz * src: adapt moved from fCopulae (fCopulae loads fMultivar) * scripts renamed in: bvdist-, mvdist-, and utils 2012-11-07 chalabi * DESCRIPTION: Updated maintainer field to comply new CRAN policy * NAMESPACE: Added NAMESPACE * R/norm2d.R: Fixed partial argument match * R/zzz.R: Removed .First.lib call 2012-01-14 mmaechler * R/cauchy2d.R: use nu=1 ! -- thanks to Rolf Turner 2011-09-23 mmaechler * DESCRIPTION: remove deprecated "LazyLoad" entry 2010-07-23 chalabi * inst/DocCopying.pdf: removed DocCopying.pdf license is already specified in DESCRIPTION file 2009-09-30 chalabi * DESCRIPTION: updated version number 2009-09-29 chalabi * ChangeLog, DESCRIPTION: updated DESC and ChangeLog 2009-04-02 chalabi * DESCRIPTION: more explicit depends and suggests field in DESC file. 2009-04-01 chalabi * DESCRIPTION: updated DESC file fMultivar/man/0000755000176000001440000000000012402605560013026 5ustar ripleyusersfMultivar/man/zzz-mvt.Rd0000644000176000001440000000466712402605560014773 0ustar ripleyusers\name{zzz-mvt} \title{Multivariate Student-t Distribution} \description{ Alternative density, distribution function, and random generation for the multivariate Student-t distribution. } \details{ The functions to compute densities \code{dmvt}, probabilities \code{pmvt}, and to generate random numbers \code{rmvt} are available from the contributed R package \code{mvtnorm}. The function \code{qmvt} computes the equicoordinate quantile function of the multivariate normal distribution for arbitrary correlation matrices based on inversion of \code{pmvt}. \code{dmvt(x, delta, sigma, df, <<...>>)}\cr \code{pmvt(<<...>>) }\cr \code{rmvt(n, sigma, df, delta, <<...>>}\cr NOTE: The function are not builtin in the package \code{fMultivar}. Fur details we refer to the help page of \code{mvnorm}. } \references{ McNeil, A. J., Frey, R., and Embrechts, P. (2005), \emph{Quantitative Risk Management: Concepts, Techniques, Tools}, Princeton University Press. } \author{ Alan Genz, Frank Bretz, Tetsuhisa Miwa, Xuefei Mi, Friedrich Leisch, Fabian Scheipl, Bjoern Bornkamp, Torsten Hothorn. } \examples{ \dontrun{ ## Load Libray: require(mvtnorm) ## dmvt - # basic evaluation dmvt(x = c(0,0), sigma = diag(2)) ## dmvt | dmvnorm - # check behavior for df=0 and df=Inf x <- c(1.23, 4.56) mu <- 1:2 Sigma <- diag(2) x0 <- dmvt(x, delta = mu, sigma = Sigma, df = 0) # default log = TRUE! x8 <- dmvt(x, delta = mu, sigma = Sigma, df = Inf) # default log = TRUE! xn <- dmvnorm(x, mean = mu, sigma = Sigma, log = TRUE) stopifnot(identical(x0, x8), identical(x0, xn)) ## rmvt - # X ~ t_3(0, diag(2)) x <- rmvt(100, sigma = diag(2), df = 3) # t_3(0, diag(2)) sample plot(x) ## rmvt - # X ~ t_3(mu, Sigma) n <- 1000 mu <- 1:2 Sigma <- matrix(c(4, 2, 2, 3), ncol=2) set.seed(271) x <- rep(mu, each=n) + rmvt(n, sigma=Sigma, df=3) plot(x) ## rmvt - # Note that the call rmvt(n, mean=mu, sigma=Sigma, df=3) does *not* # give a valid sample from t_3(mu, Sigma)! [and thus throws an error] try(rmvt(n, mean=mu, sigma=Sigma, df=3)) ## rmvnorm - # df=Inf correctly samples from a multivariate normal distribution set.seed(271) x <- rep(mu, each=n) + rmvt(n, sigma=Sigma, df=Inf) set.seed(271) x. <- rmvnorm(n, mean=mu, sigma=Sigma) stopifnot(identical(x, x.)) } } \keyword{math} fMultivar/man/bvdist-t2d.Rd0000644000176000001440000000431212402605560015277 0ustar ripleyusers\name{bvdist-t2d} \alias{t2d} \alias{dt2d} \alias{pt2d} \alias{rt2d} \title{Bivariate Student-t Distribution} \description{ Density, distribution function, and random generation for the bivariate Student-t distribution. } \usage{ dt2d(x, y, rho = 0, nu = 4) pt2d(x, y, 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 \code{pnorm2d} function, \cr Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## dt2d - # 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))) # Perspective Plot: persp(Z, theta = -40, phi = 30, col = "steelblue") # Contour Plot: contour(Z) ## pt2d - # Bivariate Student-t Probability: x <- (-40:40)/10 X <- grid2d(x) z <- pt2d(X$x, X$y, rho = 0.5, nu = 6) Z <- list(x = x, y = x, z = matrix(z, ncol = length(x))) # Image Plot with Contours: image(Z) contour(Z, add=TRUE) } \keyword{math} fMultivar/man/zzz-mvnorm.Rd0000644000176000001440000000376212402605560015476 0ustar ripleyusers\name{zzz-mvnorm} \title{Multivariate Normal Distribution} \description{ Alternative density, distribution function, and random generation for the multivariate Normal distribution. } \details{ The multivariate distribution functions to compute densities \code{dmvnorm}, probabilities \code{pmvnorm}, and to generate random numbers \code{rmvnorm} are available from the contributed R package \code{mvtnorm}. The function \code{qmvnorm} computes the equicoordinate quantile function of the multivariate normal distribution for arbitrary correlation matrices based on inversion of \code{pmvnorm}. \code{dmvnorm(x, mean, sigma, <<...>>}\cr \code{pmvnorm(<<...>>)}\cr \code{qmvnorm(p, <<...>>)}\cr \code{rmvnorm(n, mean, sigma, <<...>>} NOTE: The function are not builtin in the package \code{fMultivar}. Fur details we refer to the help page of \code{mvnorm}. } \author{ Friedrich Leisch and Fabian Scheipl. } \examples{ \dontrun{ ## Load Libray: require(mvtnorm) ## dmvnorm - # Multivariate Normal Density Function: mean <- c(1, 1) sigma <- matrix(c(1, 0.5, 0.5, 1), ncol=2) dmvnorm(x = c(0, 0),mean, sigma) ## dmvnorm - # Across a Grid: x <- seq(-4, 4, length=90) X <- grid2d(x) X <- cbind(X$x, X$y) # Write Density Function: dmvnorm. <- function(X, mean, sigma) matrix(apply(X, 1, dmvnorm, mean=mean, sigma=sigma), ncol=sqrt(dim(X)[1])) z <- dmvnorm.(X, mean, sigma) contour(list(x = x, y = x, z = z)) ## qmvnorm - # Equicoordinate Quantile Function: qmvnorm(p = 0.95, sigma = diag(2), tail = "both") ## rmvnorm - # Random Numbers: sigma <- matrix(c(4, 2, 2, 3), ncol=2) x <- rmvnorm(n = 500, mean = c(1, 2), sigma = sigma) colMeans(x) var(x) # Next Generation: x <- rmvnorm(n = 500, mean = c(1, 2), sigma = sigma, method = "chol") colMeans(x) var(x) plot(x, cex=0.5, pch=19, col="steelblue") } } \keyword{math} fMultivar/man/mvdist-msnFit.Rd0000644000176000001440000000340712402605560016065 0ustar ripleyusers\name{mvdist-msnFit} \alias{msnFit} \title{Multivariate Skew Normal Parameter Estimation} \description{ Fitting the parameters for the multivariate skew Normal distribution. } \usage{ msnFit(x, trace = FALSE, title = NULL, description = NULL) } \arguments{ \item{x}{ a matrix with "d" columns, giving the coordinates of the point(s) where the density must be evaluated. } \item{trace}{ a logical value, should the estimation be traced? By default FALSE. } \item{title}{ an optional project title. } \item{description}{ an option project desctiption. } } \details{ This is an easy to use wrapper function using default function settings for fitting the distributional parameters in the framework of the contributed package \code{"sn"} written by Adelchi Azzalini. Starting values for the estimation have not to be provided, they are automatically created. } \examples{ \dontrun{ ## Load Library: require(sn) ## msnFit - # Fit Example: N <- 1000 xi <- c(0, 0) Omega <- diag(2); Omega[2,1] <- Omega[1,2] <- 0.5 alpha <- c(2, -6) set.seed(4711) X <- rmsn(n=N, xi, Omega, alpha) ans <- msnFit(X) print(ans) # 2-D Density Plot: plot(hexBinning(X[,1], X[, 2], bins = 30), main="Skew Normal") # Add Contours: N <- 101 x <- seq(min(X[, 1]), max(X[, 1]), l=N) y <- seq(min(X[, 2]), max(X[, 2]), l=N) u <- grid2d(x, y)$x v <- grid2d(x, y)$y XY <- cbind(u, v) param <- ans@fit$estimate Z <- matrix(dmsn(XY, param[[1]][1,], param[[2]], param[[3]]), ncol=N) contour(x, y, Z, add=TRUE, col="green", lwd=2) grid(col="brown", lty=3) } } \keyword{math} fMultivar/man/mvdist-msc.Rd0000644000176000001440000000574112402605560015412 0ustar ripleyusers\name{mvdist-msc} \title{Multivariate Skew Cauchy Distribution} \description{ Density, distribution function, and random number generation for the multivariate Cauchy distribution. } \details{ The functions to compute densities \code{dmsc}, probabilities \code{pmsc}, and to generate random numbers \code{rmsc} for the multivariate skew Cauchy distribution are available in the contributed R package \code{sn} (note, they are no longer builtin in fMultivar). The reason is that the performance for these functions in package \code{sn} has superseeded those used before in the package fMultivar. The usage of the \code{sn} functions is: \code{dmsc(x, xi, Omega, alpha, dp = NULL, log = FALSE)}\cr \code{pmsc(x, xi, Omega, alpha, dp = NULL, ...) }\cr \code{rmsc(n, xi, Omega, alpha, dp = NULL)} NOTE: The multivariate skew-normal distribution is discussed by Azzalini and Dalla Valle (1996). The \code{(Omega,alpha)} parametrization adopted here is the one of Azzalini and Capitanio (1999). Chapter 5 of Azzalini and Capitanio (2014) provides an extensive account, including subsequent developments. Be aware that the location vector \code{xi} does not represent the mean vector of the distribution. Similarly,\code{Omega} is not the covariance matrix of the distribution, although it is a covariance matrix. For further details we refer to the help page in the package \code{sn}. } \references{ Azzalini, A. and Dalla Valle, A. (1996), The multivariate skew-normal distribution, Biometrika 83, 715-726. Azzalini, A. and Capitanio, A. (1999), Statistical applications of the multivariate skew normal distribution, Journal Roy.Statist.Soc. B 61, 579-602, Full-length version available at http://arXiv.org/abs/0911.2093 Azzalini, A. with the collaboration of Capitanio, A. (2014), The Skew-Normal and Related Families, Cambridge University Press, IMS Monographs Series. } \examples{ \dontrun{ ## grid2d - # Make 2-D Grid Coordinates: N <- 101 x <- y <- seq(-3, 3, l=N) X <- cbind(u=grid2d(x)$x, v=grid2d(x)$y) ## Set Parameters: xi <- c(0, 0) Omega <- diag(2); Omega[2,1] <- Omega[1,2] <- 0.5 alpha <- c(2, -6) ## dmsc - # Compute skew Cauchy Density: z <- sn::dmsc(X, xi, Omega, alpha) Z <- list(x=x, y=x, z=matrix(z, ncol = length(x))) # Plot: image(Z, main ="Skew Cauchy Density") contour(Z, add=TRUE) grid(col="red") ## pmsc - # Compute skew Cauchy Probability: z <- NULL for (i in 1:nrow(X)) z <- c(z, sn::pmsc(X[i, ], xi, Omega, alpha)[[1]]) Z <- list(x=x, y=x, z=matrix(z, ncol = length(x))) # Plot: image(Z, main ="Skew Cauchy Probability") contour(Z, add=TRUE) grid(col="red") ## rmsc - # Skew Cauchy Random Deviates: set.seed(4711) r <- sn::rmsc(10000, xi, Omega, alpha) plot(hexBinning(r[, 1], r[, 2])) # Note, we have fat tails ... } } \keyword{math} fMultivar/man/mvdist-mstFit.Rd0000644000176000001440000000474312402605560016077 0ustar ripleyusers\name{mvdist-mstFit} \alias{mstFit} \title{Multivariate Skew Student-t Parameter Estimation} \description{ Fitting the parameters for the Multivariate Skew Student-t Distribution } \usage{ mstFit(x, fixed.nu=NULL, trace=FALSE, title=NULL, description=NULL) } \arguments{ \item{x}{ a matrix with "d" columns, giving the coordinates of the point(s) where the density must be evaluated. } \item{fixed.nu}{ a positive value to keep fixed the parameter nu of the Student-t distribution in the optimization process; with default value NULL, nu is estimated like the other parameters. } \item{trace}{ a logical value, should the estimation be traced? By default FALSE. } \item{title}{ an optional project title. } \item{description}{ an option project desctiption. } } \details{ This is an easy to use wrapper function using default function settings for fitting the distributional parameters in the framework of the contributed package \code{"sn"} written by Adelchi Azzalini. Starting values for the estimation have not to be provided, they are automatically created. } \examples{ \dontrun{ ## Load Library: require(sn) ## mstFit - # Fit Example: N <- 1000 xi <- c(0, 0) Omega <- diag(2); Omega[2,1] <- Omega[1,2] <- 0.5 alpha <- c(2, -2) nu <- 4 set.seed(4711) X <- rmst(n=N, xi, Omega, alpha, nu=4) ans <- mstFit(X) # Show fitted Parameters: print(ans) # 2-D Density Plot: plot(hexBinning(X[,1], X[, 2], bins = 30), main="Skew Student-t") # Add Contours: N <- 101 x <- seq(min(X[, 1]), max(X[, 1]), l=N) y <- seq(min(X[, 2]), max(X[, 2]), l=N) u <- grid2d(x, y)$x v <- grid2d(x, y)$y XY <- cbind(u, v) param <- ans@fit$dp Z <- matrix(dmst( XY, param[[1]][1,], param[[2]], param[[3]], param[[4]]), ncol=N) contour(x, y, Z, add=TRUE, col="green", lwd=2) grid(col="brown", lty=3) ## mstFit - # Fit Example with fixed nu=4: ans <- mstFit(X, fixed.nu=4) # Show fitted Parameters: print(ans) # 2-D Density Plot: plot(hexBinning(X[,1], X[, 2], bins = 30), main="Student-t | fixed nu") # Add Contours: param <- ans@fit$dp Z <- matrix(dmst( XY, param[[1]][1,], param[[2]], param[[3]], nu=4), ncol=N) contour(x, y, Z, add=TRUE, col="green", lwd=2) grid(col="brown", lty=3) } } \keyword{math} fMultivar/man/mvdist-mscFit.Rd0000644000176000001440000000435612402605560016056 0ustar ripleyusers\name{mvdist-mscFit} \alias{mscFit} \title{Multivariate Skew Cauchy Parameter Estimation} \description{ Fitting the parameters for the Multivariate Skew Cauchy Distribution. } \usage{ mscFit(x, trace=FALSE, title = NULL, description = NULL) } \arguments{ \item{x}{ a matrix with "d" columns, giving the coordinates of the point(s) where the density must be evaluated. } \item{trace}{ a logical value, should the estimation be traced? By default FALSE. } \item{title}{ an optional project title. } \item{description}{ an option project desctiption. } } \details{ This is an easy to use wrapper function using default function settings for fitting the distributional parameters in the framework of the contributed package \code{"sn"} written by Adelchi Azzalini. Starting values for the estimation have not to be provided, they are automatically created. } \examples{ \dontrun{ ## Load Library: require(sn) ## mscFit - # Fit Example: N <- 1000 xi <- c(0, 0) Omega <- diag(2); Omega[2,1] <- Omega[1,2] <- 0.5 alpha <- c(2, -6) set.seed(4711) X <- rmsc(n=N, xi, Omega, alpha) ans <- mscFit(X) # Show fitted Parameters: print(ans) # 2-D Density Plot: plot(hexBinning(X[,1], X[, 2], bins = 30), main="Skew Cauchy") # Add Contours: N <- 101 x <- seq(min(X[, 1]), max(X[, 1]), l=N) y <- seq(min(X[, 2]), max(X[, 2]), l=N) u <- grid2d(x, y)$x v <- grid2d(x, y)$y XY <- cbind(u, v) param <- ans@fit$dp Z <- matrix(dmsc(XY, param[[1]][1,], param[[2]], param[[3]]), ncol=N) contour(x, y, Z, add=TRUE, col="green", lwd=2) grid(col="brown", lty=3) ## Cut the Tails: CUT <- 25 X <- X[abs(X[, 1]) <= CUT, ] X <- X[abs(X[, 2]) <= CUT, ] plot(hexBinning(X[,1], X[, 2], bins = 30), main="Skew Cauchy") x <- y <- seq(-CUT, CUT, l=N) u <- grid2d(x, y)$x v <- grid2d(x, y)$y XY <- cbind(u, v) param <- ans@fit$dp Z <- matrix(dmsc(XY, param[[1]][1,], param[[2]], param[[3]]), ncol=N) contour(x, y, Z, add=TRUE, col="green", lwd=2) grid(col="brown", lty=3) # Try larger cuts ... } } \keyword{math} fMultivar/man/bvdist-cauchy2d.Rd0000644000176000001440000000357712402605560016324 0ustar ripleyusers\name{bvdist-cauchy2d} \alias{cauchy2d} \alias{dcauchy2d} \alias{pcauchy2d} \alias{rcauchy2d} \title{Bivariate Cauchy Distribution} \description{ Density, distribution function, and random generation for the bivariate Cauchy distribution. } \usage{ dcauchy2d(x, y, rho = 0) pcauchy2d(x, y, rho = 0) rcauchy2d(n, rho = 0) } \arguments{ \item{x, y}{ two numeric vectors defining the x and y coordinates. } \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. } } \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 \code{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))) ## Perspective Density Plot: persp(Z, theta = -40, phi = 30, col = "steelblue") ## Image Density Plot with Contours: image(Z, main="Bivariate Cauchy") contour(Z, add=TRUE) } \keyword{math} fMultivar/man/utils-density2d.Rd0000644000176000001440000000430012402605560016355 0ustar ripleyusers\name{utils-density2d} \alias{density2d} \alias{hist2d} \title{Bivariate Density Tools} \description{ Kernel density estimator and histogram counter for bivariate distributions } \usage{ density2d(x, y = NULL, n = 20, h = NULL, limits = c(range(x), range(y))) hist2d(x, y = NULL, n = c(20, 20)) } \arguments{ \item{x, y}{ 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{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. } \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. } } \value{ \code{density2d} and \code{hist2d} return 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}. } \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. } \examples{ ## hist2d - # Normal Random Numbers: set.seed(4711) X <- rnorm2d(40000) # 2D Histogram Plot: Z <- hist2d(X) image(Z) contour(Z, add=TRUE) } \keyword{math} fMultivar/man/utils-adapt.Rd0000644000176000001440000000634212402605560015551 0ustar ripleyusers\name{utils-adapt} \alias{adapt} \title{Integrator for multivariate distributions} \description{ The function is for adaptive quadrature. } \usage{ adapt(ndim, lower, upper, functn, \dots) } \note{ In 2007 the package \code{adapt} was removed from the CRAN repository, due to unclear license conditions. Nevertheless, formerly available versions can still be obtained from the CRAN \href{http://cran.r-project.org/src/contrib/Archive/adapt/}{archive}. Package \code{adapt} used FORTRAN code from Professor Genz. From 2007 until 2013 the package \code{fMultivar} used an builtin licensed by Professor Genz to Rmetrics. This version is still available in the current package, have a look into the folder \code{deprecated}. 2013 the contributed package \code{cubature} was added to the CRAN repository. This provides an alternative n-dimensional integration routine. We recommend to use the function \code{adaptIntegrate} directly from the package \code{cubature} which allows adaptive multivariate integration over hypercubes. It is a wrapper around the pure C, GPLed implementation by Steven G. Johnson. Since 2014 \code{fMultivar} uses also the C Version based implementation of Johnson. The former function \code{adapt} has been replaced by a wrapper function calling \code{adaptIntegrate}. The arguments \code{ndim}, \code{lower}, \code{upper}, and \code{functn} have been remeined the same, control parameters have been adapted to the function \code{cubature::adaptIntegrate}. } \arguments{ \item{ndim}{ the dimension of the integral. By default NUll, no longer used. } \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{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{\dots}{ other parameters to be passed to the underlying function. } } \value{ The returned value is a list of three items: \item{integral}{ the value of the integral. } \item{error}{ the estimated relative error. } \item{functionEvaluations}{ the number of times the function was evaluated. } \item{returnCode}{ the actual integer return code of the C routine. } } \references{ See: http://ab-initio.mit.edu/wiki/index.php/Cubature. } \author{ Balasubramanian Narasimhan } \examples{ ## Check that dnorm2d is normalized: # Normal Density: density <- function(x) dnorm2d(x=x[1], y = x[2]) # Calling Cubature: BIG <- c(99, 99) cubature::adaptIntegrate(f=density, lowerLimit=-BIG, upperLimit=BIG) cubature::adaptIntegrate(f=density, low=-BIG, upp=BIG, tol=1e-7) # Using the Wrapper: adapt(lower=-BIG, upper=BIG, functn=density) adapt(lower=-BIG, upper=BIG, functn=density, tol=1e-7)$integral } \keyword{math} fMultivar/man/zzz-mvstnorm.Rd0000644000176000001440000000573412402605560016046 0ustar ripleyusers\name{zzz-mvstnorm} \alias{mvstnorm} \alias{dmvsnorm} \alias{pmvsnorm} \alias{rmvsnorm} \alias{dmvst} \alias{pmvst} \alias{rmvst} \alias{mvFit} \title{Obsolete Functions} \description{ Obsolete Functions: Alternative multivariate distribution and parameter estimation functions for the skew normal and skew Student-t distribution functions. } \details{ The former implementations have been replaced by wrpper functions calling functions from the package \code{"sn"}. } \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) } \arguments{ \item{x, q}{ the vector of quantiles, a matrix with "dim" columns. } \item{n}{ the number of desired observations. } \item{dim}{ the dimension, by default the bivariate case is considered where \code{dim=2} } \item{mu, Omega, alpha, df}{ \code{mu} is a numeric vector of length "dim" representing the location parameter of the distribution, \code{Omega} is a symmetric positive-definite matrix of dimension "d" timesd "d", \code{alpha} is a numeric vector which regulates the the slant of the density, \code{df} a positive value representing the degrees of freedom. } \item{method}{ selects the type of distribution function, either \code{"snorm"} which is the default, or \code{"st"}. } \item{fixed.df}{ set to a positive value to keep fixed the parameter \code{nu} of the skew student-t distribution in the optimization process; with default value NULL, i.e. \code{nu} is estimated like the other parameters. } \item{title}{ an optional project title. } \item{description}{ an option project desctiption. } \item{trace}{ a logical, should the estimation be traced? } \item{...}{ arguments passed to the underlying "sn" density functions. } } \value{ \code{dm*} gives the density, \code{pm*} gives the distribution function, and \code{rm*} generates \code{n} random deviates of dimension \code{dim} \code{mvFit} returns an object of class \code{fDISTFEED}, see package \code{fBasics}. } %\references{} %\author{} \examples{ \dontrun{ ## Load Libray: require(mvtnorm) ## [dr]mvsnorm - dmvsnorm(rnorm2d(100)) rmvsnorm(100) ## [dr]mvst - dmvst(rt2d(100)) rmvst(100) } } \keyword{math} fMultivar/man/mvdist-msn.Rd0000644000176000001440000000522412402605560015421 0ustar ripleyusers\name{mvdist-msn} \title{Multivariate Skew-Normal Distribution} \description{ Density, distribution function, and random number generation for the multivariate Skew-Normal distribution. } \details{ The functions to compute densities \code{dmsc}, probabilities \code{pmsc}, and to generate random numbers \code{rmsc} for the multivariate skew Normal distribution are available in the contributed R package \code{sn} (note, they are no longer builtin in fMultivar). The reason is that the performance for these functions in package \code{sn} has superseeded those used before in the package fMultivar. The usage of the \code{sn} functions is: \code{dmsn(x, xi, Omega, alpha, tau = 0, dp = NULL, log = FALSE)}\cr \code{pmsn(x, xi, Omega, alpha, tau = 0, dp = NULL, ...)}\cr \code{rmsn(n, xi, Omega, alpha, tau = 0, dp = NULL)} NOTE: The multivariate skew-normal distribution is discussed by Azzalini and Dalla Valle (1996). The \code{(Omega,alpha)} parametrization adopted here is the one of Azzalini and Capitanio (1999). Chapter 5 of Azzalini and Capitanio (2014) provides an extensive account, including subsequent developments. Be aware that the location vector \code{xi} does not represent the mean vector of the distribution. Similarly,\code{Omega} is not the covariance matrix of the distribution, although it is a covariance matrix. For further details we refer to the help page in the package \code{sn}. } \references{ Azzalini, A. and Dalla Valle, A. (1996), The multivariate skew-normal distribution, Biometrika 83, 715-726. Azzalini, A. and Capitanio, A. (1999), Statistical applications of the multivariate skew normal distribution, Journal Roy.Statist.Soc. B 61, 579-602, Full-length version available at http://arXiv.org/abs/0911.2093 Azzalini, A. with the collaboration of Capitanio, A. (2014), The Skew-Normal and Related Families, Cambridge University Press, IMS Monographs Series. } \examples{ \dontrun{ ## Make 2-D Grid Coordinates: N <- 101 x <- y <- seq(-3, 3, l=N) X <- cbind(u=grid2d(x)$x, v=grid2d(x)$y) ## dmsn # Set Parameters: xi <- c(0, 0) Omega <- diag(2); Omega[2,1] <- Omega[1,2] <- 0.5 alpha <- c(2, -6) # Compute skew Normal Density: z <- sn::dmsn(X, xi, Omega, alpha) Z <- list(x=x, y=x, z=matrix(z, ncol = length(x))) # Plot: image(Z) contour(Z) grid(col="red") ## rmsn - set.seed(4711) r <- sn::rmsn(n=5000, xi, Omega, alpha) plot(hexBinning(r)) contour(Z, add=TRUE, col="darkblue", lwd=2) grid(col="red") } } \keyword{math} fMultivar/man/utils-grid2d.Rd0000644000176000001440000000130312402605560015623 0ustar ripleyusers\name{utils-grid2d} \alias{grid2d} \title{Bivariate Density Tools} \description{ Grid generator for bivariate distributions. } \usage{ grid2d(x = (0:10)/10, y = x) } \arguments{ \item{x, y}{ two numeric vectors defining the \code{x} and \code{y} coordinates. } } \value{ \code{grid2d} 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}. } %\references{} \author{ Diethelm Wuertz. } \examples{ ## grid2d - # Create a square grid: x <- seq(0, 10, length = 6) X <- grid2d(x = x, y = x) cbind(X$x, X$y) } \keyword{math} fMultivar/man/bvdist-elliptical2d.Rd0000644000176000001440000000531312402605560017160 0ustar ripleyusers\name{bvdist-elliptical2d} \alias{elliptical2d} \alias{delliptical2d} \title{Bivariate Elliptical Densities} \description{ Density function for bivariate elliptical distributions. } \usage{ delliptical2d(x, y, rho = 0, param = NULL, type = c("norm", "cauchy", "t", "logistic", "laplace", "kotz", "epower"), output = c("vector", "list")) } \arguments{ \item{x, y}{ two numeric vectors defining the x and y coordinates. \cr } \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"}. } } \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{ ## delliptical2d - # 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))) ## Perspective Plot: persp(Z, theta = -40, phi = 30, col = "steelblue") ## Image Plot with Contours: image(Z, main = "Bivariate Kotz") contour(Z, add=TRUE) ## Internal Density Slider: \dontrun{ .delliptical2dSlider() } } \keyword{math} fMultivar/man/bvdist-norm2d.Rd0000644000176000001440000000460712402605560016016 0ustar ripleyusers\name{bvdist-norm2d} \alias{norm2d} \alias{dnorm2d} \alias{pnorm2d} \alias{rnorm2d} \title{Bivariate Normal Distribution} \description{ Density, distribution function, and random generation for the bivariate normal distribution. } \usage{ dnorm2d(x, y, rho = 0) pnorm2d(x, y, rho = 0) rnorm2d(n, rho = 0) } \arguments{ \item{x, y}{ two numeric vectors defining the x and y coordinates. } \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. } } \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 \code{pnorm2d} function, \cr Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## dnorm2d - # Bivariate Normal Density: x <- (-40:40)/10 X <- grid2d(x) z <- dnorm2d(X$x, X$y, rho = 0.5) ZD <- list(x = x, y = x, z = matrix(z, ncol = length(x))) # Perspective Density Plot: persp(ZD, theta = -40, phi = 30, col = "steelblue") # Contour Density Plot: contour(ZD, main="Bivariate Normal Density") ## pnorm2d - # Bivariate Normal Probability: z <- pnorm2d(X$x, X$y, rho = 0.5) ZP <- list(x = x, y = x, z = matrix(z, ncol = length(x))) # Perspective Plot: persp(ZP, theta = -40, phi = 30, col = "steelblue") # Contour Plot: contour(ZP) ## rnorm2d - # Bivariate Normal Random Deviates r <- rnorm2d(5000, rho=0.5) # Scatter Plot: plot(r, col="steelblue", pch=19, cex=0.5) contour(ZD, add=TRUE, lwd=2, col="red") # Hexagonal Binning: plot(hexBinning(r)) contour(ZD, add=TRUE, lwd=2, col="black") } \keyword{math} fMultivar/man/utils-gridding2d.Rd0000644000176000001440000000406512402605560016475 0ustar ripleyusers\name{utils-gridding2d} \alias{utils-gridding2} \alias{gridData} \alias{persp.gridData} \alias{contour.gridData} \title{Bivariate Gridded Data Sets} \description{ 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} fMultivar/man/utils-integrate2d.Rd0000644000176000001440000000276412402605560016674 0ustar ripleyusers\name{utils-integrate2d} \alias{integrate2d} \title{Bivariate Integration Tools} \description{ Integrates over the unit square. } \usage{ integrate2d(fun, error = 1.0e-5, \dots) } \arguments{ \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{error}{ the error bound to be achieved by the integration formula. A numeric value. } \item{\dots}{ parameters passed to the function to be integrated. } } \value{ \code{integrate2d} 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} fMultivar/man/mvdist-mst.Rd0000644000176000001440000000526412402605560015433 0ustar ripleyusers\name{mvdist-mst} \title{Multivariate Skew Student-t Distribution} \description{ Density, distribution function, and random number generation for the multivariate Skew-Student-t distribution. } \details{ The functions to compute densities \code{dmsc}, probabilities \code{pmsc}, and to generate random numbers \code{rmsc} for the multivariate skew Student-t distribution are available in the contributed R package \code{sn} (note, they are no longer builtin in fMultivar). The reason is that the performance for these functions in package \code{sn} has superseeded those used before in the package fMultivar. The usage of the \code{sn} functions is: \code{dmst(x, xi, Omega, alpha, nu = Inf, dp = NULL, log = FALSE)}\cr \code{pmst(x, xi, Omega, alpha, nu = Inf, dp = NULL, ...)}\cr \code{rmst(n, xi, Omega, alpha, nu = Inf, dp = NULL)}\cr NOTE: The multivariate skew-normal distribution is discussed by Azzalini and Dalla Valle (1996). The \code{(Omega,alpha)} parametrization adopted here is the one of Azzalini and Capitanio (1999). Chapter 5 of Azzalini and Capitanio (2014) provides an extensive account, including subsequent developments. Be aware that the location vector \code{xi} does not represent the mean vector of the distribution. Similarly,\code{Omega} is not the covariance matrix of the distribution, although it is a covariance matrix. For further details we refer to the help page in the package \code{sn}. } \references{ Azzalini, A. and Dalla Valle, A. (1996), The multivariate skew-normal distribution, Biometrika 83, 715-726. Azzalini, A. and Capitanio, A. (1999), Statistical applications of the multivariate skew normal distribution, Journal Roy.Statist.Soc. B 61, 579-602, Full-length version available at http://arXiv.org/abs/0911.2093 Azzalini, A. with the collaboration of Capitanio, A. (2014), The Skew-Normal and Related Families, Cambridge University Press, IMS Monographs Series. } \examples{ \dontrun{ ## Make 2-D Grid Coordinates: N <- 101 x <- y <- seq(-3, 3, l=N) X <- cbind(u=grid2d(x)$x, v=grid2d(x)$y) ## dmst - # Set Parameters: xi <- c(0, 0) Omega <- diag(2); Omega[2,1] <- Omega[1,2] <- 0.5 alpha <- c(2, -6) nu <- 4 # Compute skew Student-t Density: z <- dmst(X, xi, Omega, alpha, nu) Z <- list(x=x, y=x, z=matrix(z, ncol = length(x))) # Plot: image(Z) contour(Z) grid(col="red") ## rmst - set.seed(4711) r <- rmst(n=5000, xi, Omega, alpha, nu) plot(hexBinning(r)) contour(Z, add=TRUE, col="darkblue", lwd=2) grid(col="red") } } \keyword{math} fMultivar/man/00fMultivar-package.Rd0000644000176000001440000001503412402605560017022 0ustar ripleyusers\name{fMultivar-package} \alias{fMultivar-package} \alias{fMultivar} \docType{package} \title{Modelling Multivariate Return Distributions} \description{ The Rmetrics "fMultivar"" package is a collection of functions to manage, to investigate and to analyze bivariate and multivariate data sets of financial returns. } \details{ \tabular{ll}{ Package: \tab fMultivar\cr Type: \tab Package\cr Version: \tab R 3.0.1\cr Date: \tab 2014\cr License: \tab GPL Version 2 or later\cr Copyright: \tab (c) 1999-2014 Rmetrics Assiciation\cr URL: \tab \url{https://www.rmetrics.org} } } \section{1 Introduction}{ The package \code{fMultivar} was written to explore and investigate bivariate and multivariate financial return series. The bivariate modeling allows us the comparison of financial returns from two investments or from one investment and its benchmark. When it comes to the investigation of multiple investment returns from funds or portfolios we are concerned with the multivariate case. In the case of bivariate distribution functions we provide functions for the 2-dimensional Cauchy, Normal, and Student-t distributions. A generalisation (for the density only) is made for the family of 2-dimensional elliptical distributions. In this case we provide density functions for the Normal, Cauchy, Student-t, Logistic, Laplace, Kotz, e-Power distributions. In the case of multivariate distribution functions from the skew-normal (SN) family and some related ones we recommend to use the density funtions, probability functions and random number generators provided by Azzalini's contributed package \code{sn}. The family of his SN-distributions cover the skew Cauchy, the skew Normal, and the skew Student-t distributions. For parameter fitting we have added three simple wrapper functions for an easy to use approach to estimate the distributional parameters for financial return series. In the case of multivariate distribution functions from the generalized hyperbolic (GHYP) family and some related ones we recommend to use the density funtions, probability functions and random number generators provided by David Luethi and Wolfgang Breymann's contributed package \code{ghyp}. The family of their GHYP-distributions cover beside the General Hyperbolic distribution (GHYP) also the special cases for the Hyperbolic distribution (HYP), for the Normal Inverse Gaussian distribution (NIG), for the Variance Gamma distribution (VG), and for the skewed Student-t distribution (GHST). } \section{2 Bivariate Distributions}{ This section contains functions to model bivariate density, probability, quantile functions, and to generate random numbers for three standard distributions. \preformatted{ [dpr]cauchy2d Bivariate Cauchy Distribution [dpr]norm2d Bivariate Normal Disribution [dpr]t2d Bivariate Student-t Disribution } The density function \preformatted{ delliptical2d Bivariate Elliptical Densities } computes for several bivariate elliptical distributions their densities. Included distributions are the following types: \code{"norm"}, \code{"cauchy"}, \code{"t"}, \code{"logistic"}, \code{"laplace"}, \code{"kotz"}, and \code{"epower"}. } \section{3 Multivariate Symmetric Distributions}{ \preformatted{ [dpr] Multivariate Cauchy Distribution [dpr] Multivariate Normal Distribution [dpr] Multivariate Student-t Distribution [dpr] Multivariate Truncated Normal Distribution } } \section{3 Multivariate Skew Distributions}{ We use the functions from the contributed package \code{"sn"} package to model multivariate density and probability functions, and to generate random numbers for the skew Cauchy, Normal and Student-t distributions. Note the symmetric case is also included in these functions. The functions are: \preformatted{ [dpr]msc Multivariate Skew Cauchy Distribution [dpr]msn Multivariate Skew Normal Distribution [dpr]mst Multivariate Skew Student-t Distribution } Note the functions are not part of the \code{fMultivar} package they depend on the \code{"sn"} package and are loaded when \code{fMultivar} is loaded. NOTE: In the new version of the \code{fMultivar} package the following two distribution functions \code{*mvsnorm} (multivariate Normal distribution) and \code{*mvst} (multivariate Student-t Distribution) will become obsolete together with the \code{mvFit} parameter estimation function. The functionality is fully covered by the \code{"sn"} package. (They will be most likely deprecated in the future.) For parameter estimation please use the simple wrapper functions: \preformatted{ mscFit Multivariate Skew Cauchy Fit msnFit Multivariate Skew Normal Fit mstFit Multivariate Skew Student-t Fit } Thes parameter estimation functions will be in the same style as all the other fitting functions in other Rmetrics packages. } \section{4 Multivariate GHYP Distributions}{ We refer to the package \code{"ghyp"} authored by David Luethi and Wolfgang Breymann, } \section{5 Utility Functions}{ We have also added some very useful utility functions for the bivariate case, these include 2-D grid generation, squared and hexagonal binned histograms, 2-D kernel density estimates, bivariate histogram plots: \preformatted{ grid2d Bivariate Square Grid of Coordinates binning2d Bivariate Square/Hexagonal Binning Plot density2d Bivariate Kernel Density Plot hist2d Bivariate Histogram Plot gridData Bivariate gridded data set } For integration we have added two quadratur routines a simple one for the bivariate case and an adaptive one for the multivariate case: \preformatted{ integrate2d Bivariate Integration adapt Multivariate adaptive Quadratur } The function \code{adapt} is a wrapper to the function \code{adaptIntegrate} from the new contributed package \code{cubature} authored by Stephan G. Johnson. } \section{About Rmetrics:}{ The \code{fMultivar} Rmetrics package is written for educational support in teaching "Computational Finance and Financial Engineering" and licensed under the GPL. } \keyword{package} fMultivar/man/utils-binning2d.Rd0000644000176000001440000000433312402605560016330 0ustar ripleyusers\name{utils-binning2} \alias{utils-binning2} \alias{squareBinning} \alias{hexBinning} \alias{plot.squareBinning} \alias{plot.hexBinning} \title{Square and Hexagonal Data Binning} \description{ Two functions which allow to create histograms due to sqaure and hexagonal binning. } \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. } \details{ \code{squareBinning} does a square binning of data points, and \code{hexBinning} does a hexagonal binning of data points. } \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}