mnormt/0000755000176200001440000000000014314275176011600 5ustar liggesusersmnormt/NAMESPACE0000644000176200001440000000026114245630274013013 0ustar liggesusersimportFrom("stats", "dnorm", "pnorm", "qnorm", "rnorm", "dt", "pt", "pchisq", "rchisq", "runif", "complete.cases", "var", "cov2cor") exportPattern(".") mnormt/ChangeLog0000644000176200001440000000255712354254143013354 0ustar liggesusersR package 'mnormt' history file ------------------------------- 2005-nov. : built private version 2006-01-23: 1.0-0 first version uploaded on CRAN 2006-04-26: 1.0-1 fixed a bug of non-compliance to R programming standards 2006-10-09: 1.1-0 adopt amedend Fortran code of Alan Genz (subtroutine TRESTR) 2006-10-26: 1.2-0 fixed a bug in function rmt 2007-03-16: 1.2-1 some amendments in documentation 2008-06-12: 1.3-0 added Fortran code for the bivariate case; improved R coding 2009-01-26: 1.3-2 minor modification to F77 code to avoid GOTO outside IF block 2009-03-21: 1.3-3 romoved check on the R version, at request of the R Core team 2009-11-25: 1.3-4 fixed a bug affecting the case d>2 & df=Inf 2011-01-16: 1.4-0 pd.solve() introduced; argument 'mean' can now be a matrix 2011-04-06: 1.4-1 fixed documentation, coding of dmnorm & dmt is straightened, log.det in pd.solve() provided only on request 2011-04-28: 1.4-2 fixed bug of biv.not.prob if some (lower=-Inf & upper=Inf) 2011-05-03: 1.4-3 fixed bug as above for sadmvn and sadmvt 2012-01-06: 1.4-5 NAMESPACE introduced on request from R Core Team 2013-12-04: 1.4-7 .First.lib() removed on request from CRAN, other minor fixes 2014-06-25: 1.5-0 improved coding of dmnorm and dmt functions, allow calling pmnorm and pmt with a matrix argument 2014-06-30: 1.5-1 fixes a minor bug of version 1.5-0 mnormt/man/0000755000176200001440000000000014314263017012342 5ustar liggesusersmnormt/man/plot_fxy.Rd0000644000176200001440000001201014247454755014507 0ustar liggesusers\name{plot_fxy} \alias{plot_fxy} \title{Plotting a function of two variables} \description{ Plot a real-valued function \code{f} evaluated on a grid of points of the Cartesian plane, possibly with parameters specified by \code{...}. The type of graphical display can be regulated by selecting the plotting function among a set of available options. } \usage{ plot_fxy(f, xlim, ylim, ..., npt=51, grf, grpar) } \arguments{ \item{f}{either a function or a character string with the name of a real-valued function whose first argument represents the coordinates of points where \code{f} is evaluated; see \sQuote{Details} for additional information.} \item{xlim}{either a vector of abscissae where the \code{f} must be evaluated, or a length-two vector with the endpoints of such an interval, in which case \code{npt[1]} equally spaced points will be considered. } \item{ylim}{either a vector of ordinates where the \code{f} must be evaluated, or a length-two vector with the endpoints of such an interval, in which case \code{npt[2]} equally spaced points will be considered. } \item{...}{additional parameters to be supplied to \code{f}; these must be named as expected by the specification of \code{f}.} \item{npt}{either an integer value or a two-element integer vector with the number of equally-spaced points, within the endpoints of \code{xlim} and \code{ylim}, used to set up the grid of points where \code{f} is evaluated; default value: \code{51}. When a single value is supplied, this is expanded into a length-2 vector. If \code{length(xlim)>2} and \code{length(ylim)>2}, \code{npt} is ignored. } \item{grf}{an optional character string with the name of the function which produces the graphical display, selectable among \code{"contour", "filled.contour", "persp", "image" } of package \code{graphics}; if \code{grf} is unset, \code{"contour"} is used.} \item{grpar}{an optional character string with arguments supplied to the selected \code{grf} function, with items separated by \code{,} as in a regular call.} } \details{ Function \code{f} will be called with the first argument represented by a two-column matrix, where each row represents a point of the grid on the Cartesian plane identified by \code{xlim} and \code{ylim}; this set of coordinates is stored in matrix \code{pts} of the returned list. If present, arguments supplied as \code{...} are also passed to \code{f}. It is assumed that \code{f} accepts this type of call. The original motivation of \code{plot_fxy} was to plot instances of bivariate probability density functions specified by package \code{mnormt}, but it can be used for plotting any function fulfilling the above requirements, as illustrated by some of the examples below. } \value{ an invisible list with the following components: \tabular{ll}{ \code{x}\tab a vector of coordinates on the \eqn{x} axis\cr \code{y}\tab a vector of coordinates on the \eqn{y} axis\cr \code{pts}\tab a matrix of dimension \code{(npt[1]*npt[2],2)} with the coordinates of the evaluation points \eqn{(x,y)} \cr \code{f.values} \tab the vector of \code{f} values at the \code{pts} points. } } \seealso{ \code{\link[graphics]{contour}}, \code{\link[graphics]{filled.contour}}, \code{\link[graphics]{persp}}, \code{\link[graphics]{image}} } \examples{ Sigma <- matrix(c(1,1,1,2), 2, 2) mean <- c(0, -1) xlim <- c(-3, 5) ylim <- c(-5, 3) # # multivariate normal density, contour-level plot gp <- 'col="blue", nlevels=6, main="bivariate normal density"' u <- plot_fxy(dmnorm, xlim, ylim, mean=mean, varcov=Sigma, grpar=gp) cat(str(u)) #--- # multivariate normal density, filled-contour plot plot_fxy(dmnorm, xlim, ylim, mean=mean, varcov=Sigma,grf="filled.contour") #--- # multivariate normal density, perspective plot gp <- "theta = 10, phi = 25, r = 2.5" plot_fxy(dmnorm, xlim, ylim, mean=mean, varcov=Sigma, grf="persp", grpar=gp) #--- # multivariate Student's "t" density; # the xlim argument passed to function 'grf' overrides the earlier xlim; # xlim and ylim can be placed after the arguments of 'f', if one prefers so grp <- 'xlim=c(-1, 3)' plot_fxy(dmt, mean=mean, S=Sigma, df=8, xlim, ylim, npt=101, grf="filled.contour", grpar=grp) #--- # multivariate truncated normal density, 'image' plot low <- c(-3, -5) hi <- c(1, 0) plot_fxy(dmtruncnorm, mean=mean, varcov=Sigma, lower=low, upper=hi, xlim, ylim, npt=81, grf="image") #--- # multivariate truncated normal distribution function, 'image' plot; # hence not a density function low <- c(-3, -5) hi <- c(1, 0) v <- plot_fxy(pmtruncnorm, mean=mean, varcov=Sigma, lower=low, upper=hi, xlim, ylim, npt=c(61, 81), grf="image") #--- # a different sort of 'f' function (lbeta), not a component of this package funct <- function(z) lbeta(a=z[,1], b=z[,2]) plot_fxy(funct, xlim=c(0.1, 2), ylim=c(0.1, 2), npt=41, grpar='main="function log-beta(a,b)", xlab="a", ylab="b"') } \keyword{multivariate} \keyword{hplot} mnormt/man/recintab.Rd0000644000176200001440000001240014313352666014425 0ustar liggesusers\name{recintab} \alias{recintab} \title{ Moments of arbitrary order of a (possibly) truncated multivariate normal variable } \description{ Produces an array with the moments up to specified orders of a (possibly) truncated multivariate normal distribution. Each component variable can be truncated on one side (to the left or to the right) or on two sides or not truncated. } \usage{ recintab(kappa, a, b, mu, S, ...) } \arguments{ \item{kappa}{a vector of non-negative integer values representing the required order of moments for each component variable.} \item{a}{a vector representing the lower truncation values of the component variables; \code{-Inf} values are allowed.} \item{b}{a vector representing the upper truncation values of the component variables; \code{Inf} values are allowed.} \item{mu}{a vector representing the mean value of the pre-truncation normal random variable.} \item{S}{a symmetric positive-definite matrix representing the variance matrix of the pre-truncation normal random variable.} \item{\dots}{parameters passed to \code{sadmvn}; see the \sQuote{Details}. } } \details{ The maximal dimension of the multivariate normal variable is 20. If this threshold is exceeded \code{NA}s are returned. This function is the \R translation of the Matlab function with the same name belonging to the package \code{ftnorm}, which is associated to the paper of Kan and Robotti (2017). The Matlab package \code{ftnorm} has been downloaded from \url{http://www-2.rotman.utoronto.ca/~kan/research.htm}, on 2020-04-23. The function returns an array, \code{M} say, whose entries represent integrals of type \eqn{\int_a^b x^\kappa f(x) dx}, where \eqn{f(x)} denotes the \eqn{d}-dimensional normal density function. Typically, interest is in the scaled array \code{M/M[1]} whose entries represent the moments of the truncated distribution. The algorithm is based on a recursion starting from the integral of the normal distribution over the specified hyper-rectangle. This integral is evaluated by \code{sadmvn}, whose tuning parameters \code{maxpts, abseps, releps} can be regulated via the \code{...} argument. } \value{ In the multivariate case, for an input vector \code{kappa=c(k1,\dots, kd)}, the functions returns an array of dimension \code{c((k1+1),...,(kd+1))} whose entries represent integrals described in section \sQuote{Details}. In other words, the array element \code{M[i+1, j+1, k+1,...]} contains the \emph{unnormalized} cross moment of order \code{(i, j, k,...)}; this must be divided by \code{M[1]} to obtain the regular cross moment. In the univariate case, a vector is returned with similar meaning. } \section{Warning}{ Although the underlying algorithm is exact in principle, the actual computation hinges crucially on the initial integration of the multivariate normal density over the truncation hyper-cube. This integration may result in numerical inaccuracies, whose amount depends on the supplied arguments. Moreover, the recursion employed by the algorithm propagates the initial error to other terms. When problematic cases have been processed by the original Matlab function, the same issues have occurred, up to minor variations. Instances of such errors may be detected when the array \code{M/M[1]} is passed to \code{\link{mom2cum}}, but there is no guarantee that all such problems are detected. } \references{ Kan, Raymond and Robotti, Cesare (2017). On moments of folded and truncated multivariate normal distributions. \emph{Journal of Computational and Graphical Statistics}, 26, 930-934, DOI: 10.1080/10618600.2017.1322092 Leppard, P. and Tallis, G. M. (1989). Algorithm AS249: Evaluation of the mean and covariance of the truncated multinormal distribution \emph{Applied Statistics} 38, 543-553) } \author{ Original Matlab code by Raymond Kan and Cesare Robotti, porting to R by Adelchi Azzalini. } \note{This function is not intended for direct call by a user, at least in commonly encountered situations. Function \code{\link{mom.mtruncnorm}} represents a more user-friendly tool.} \seealso{\code{\link{mom.mtruncnorm}} for a more user-friendly function, \code{\link{mom2cum}} for transformation to cumulants, \code{\link{sadmvn}} for regulating accuracy if \code{d>2}} \examples{ mu <- c(1, -0.5, 0) Sigma <- toeplitz(1/(1:3)) low <- c(-Inf, -3, -4) hi <- c(1.5, Inf, 2) M <- recintab(c(2,3,1), low, hi, mu, Sigma) M/M[1] # cross-moments up to order 2 for X1, up to the 3 for X2, up to 1 for X3, # if the components of the trivariate variable are denoted (X1,X2,X3) #-- # Example 2 of Leppard & Tallis (1989, Appl.Stat. vol.38, p.547) truncp <- c(0, 1, 2) U <- c(0, 0, 0) V <- 0.5*(diag(3) + matrix(1, 3, 3)) M <- recintab(c(2,2,2), truncp, rep(Inf,3), U, V) mom <- M/M[1] EX <- c(mom[2,1,1], mom[1,2,1], mom[1,1,2]) print(EX, digits=9) EX2 <- matrix(c( mom[3,1,1], mom[2,2,1], mom[2,1,2], mom[2,2,1], mom[1,3,1], mom[1,2,2], mom[2,1,2], mom[1,2,2], mom[1,1,3]), 3, 3, byrow=TRUE) varX <- EX2 - outer(EX ,EX) print(varX, digits=9) } % Add one or more standard keywords, see file 'KEYWORDS' in the \keyword{distribution} \keyword{multivariate} \concept{moments} \concept{truncated multivariate normal distribution} mnormt/man/mt.Rd0000644000176200001440000001655214313353467013272 0ustar liggesusers\name{mt} \alias{dmt} \alias{pmt} \alias{rmt} \alias{sadmvt} \alias{biv.nt.prob} \alias{ptriv.nt} \title{The multivariate Student's \emph{t} distribution} \description{ The probability density function, the distribution function and random number generation for a \code{d}-dimensional Student's \emph{t} random variable. } \usage{ dmt(x, mean = rep(0, d), S, df=Inf, log = FALSE) pmt(x, mean = rep(0, d), S, df=Inf, ...) rmt(n = 1, mean = rep(0, d), S, df=Inf, sqrt=NULL) sadmvt(df, lower, upper, mean, S, maxpts = 2000*d, abseps = 1e-06, releps = 0) biv.nt.prob(df, lower, upper, mean, S) ptriv.nt(df, x, mean, S) } \arguments{ \item{x}{ either a vector of length \code{d} or (for \code{dmt} and \code{pmt}) a matrix with \code{d} columns representing the coordinates of the point(s) where the density must be evaluated; see also \sQuote{Details}.} \item{mean}{either a vector of length \code{d}, representing the location parameter (equal to the mean vector when \code{df>1}), or (for \code{dmt} and \code{pmt}) a matrix whose rows represent different mean vectors; in the matrix case, its dimensions must match those of \code{x}.} \item{S}{a symmetric positive definite matrix with dimensions \code{(d,d)} representing the scale matrix of the distribution, such that \code{S*df/(df-2)} is the variance-covariance matrix when \code{df>2}; a vector of length \code{1} is also allowed (in this case, \code{d=1} is set).} \item{df}{the degrees of freedom. For \code{rmt}, it must be a positive real value or \code{Inf}. For all other functions, it must be a positive integer or \code{Inf}. A value \code{df=Inf} is translated to a call to a suitable function for the the multivariate normal distribution. See \sQuote{Details} for its effect for the evaluation of distribution functions and other probabilities.} \item{log}{a logical value(default value is \code{FALSE}); if \code{TRUE}, the logarithm of the density is computed.} \item{sqrt}{if not \code{NULL} (default value is \code{NULL}), a square root of the intended scale matrix \code{S}; see \sQuote{Details} for a full description.} \item{...}{arguments passed to \code{sadmvt}, among \code{maxpts}, \code{absrel}, \code{releps}.} \item{n}{the number of random vectors to be generated} \item{lower}{a numeric vector of lower integration limits of the density function; must be of maximal length \code{20}; \code{+Inf} and \code{-Inf} entries are allowed.} \item{upper}{ a numeric vector of upper integration limits of the density function; must be of maximal length \code{20}; \code{+Inf} and \code{-Inf} entries are allowed } \item{maxpts}{the maximum number of function evaluations (default value: \code{2000*d})} \item{abseps}{absolute error tolerance (default value: \code{1e-6}).} \item{releps}{relative error tolerance (default value: \code{0}).} } \details{ The dimension \code{d} cannot exceed \code{20} for \code{pmt} and \code{sadmvt}. If this threshold is exceeded, \code{NA} is returned. The functions \code{sadmvt}, \code{ptriv.mt} and \code{biv.nt.prob} are interfaces to Fortran 77 routines by Alan Genz, available from his web page; they makes use of some auxiliary functions whose authors are indicated in the Fortran code itself. The routine \code{sadmvt} uses an adaptive integration method. If \code{df=3}, a call to \code{pmt} activates a call to \code{ptriv.nt} which is specific for the trivariate case, and uses Genz's Fortran code \code{tvpack.f}; see Genz (2004) for the background methodology. A similar fact takes place when \code{df=2} with function \code{biv.nt.prob}; note however that the underlying Fortran code is taken from \code{mvtdstpack.f}, not from \code{tvpack.f}. If \code{pmt} is called with \code{d>3}, this is converted into a suitable call to \code{sadmvt}. If \code{sqrt=NULL} (default value), the working of \code{rmt} involves computation of a square root of \code{S} via the Cholesky decomposition. If a non-\code{NULL} value of \code{sqrt} is supplied, it is assumed that it represents a square root of the scale matrix, otherwise represented by \code{S}, whose value is ignored in this case. This mechanism is intended primarily for use in a sequence of calls to \code{rmt}, all sampling from a distribution with fixed scale matrix; a suitable matrix \code{sqrt} can then be computed only once beforehand, avoiding that the same operation is repeated multiple times along the sequence of calls. For examples of use of this argument, see those in the documentation of \code{\link{rmnorm}}. Another use of \code{sqrt} is to supply a different form of square root of the scale matrix, in place of the Cholesky factor. For efficiency reasons, \code{rmt} does not perform checks on the supplied arguments. } \value{ \code{dmt} returns a vector of density values (possibly log-transformed); \code{pmt} and \code{sadmvt} return a single probability with attributes giving details on the achieved accuracy, provided \code{x} of \code{pmnorm} is a vector; \code{rmt} returns a matrix of \code{n} rows of random vectors, or a vector in case \code{n=1} or \code{d=1}. } \references{ Genz, A.: Fortran 77 code in files \code{mvt.f}, \code{mvtdstpack.f} and code{tvpack}, downloaded in 2005 and again in 2007 from his webpage, whose URL as of 2020-06-01 is \url{https://www.math.wsu.edu/faculty/genz/software/software.html} Genz, A. (2004). Numerical computation of rectangular bivariate and trivariate normal and \emph{t} probabilities. \emph{Statistics and Computing} 14, 251-260. Dunnett, C.W. and Sobel, M. (1954). A bivariate generalization of Student's \emph{t}-distribution with tables for certain special cases. \emph{Biometrika} 41, 153--169. } \author{ \acronym{FORTRAN 77} code of \code{SADMVT}, \code{MVTDSTPACK}, \code{TVPACK} and many auxiliary functions by Alan Genz; some additional auxiliary functions by people referred to within his programs; interface to \R and additional \R code (for \code{dmt}, \code{rmt} etc.) by Adelchi Azzalini.} \note{ The attributes \code{error} and \code{status} of the probability returned by \code{sadmvt} and by \code{pmt} (the latter only if \code{x} is a vector and \code{d>2}) indicate whether the function had a normal termination, achieving the required accuracy. If this is not the case, re-run the function with a higher value of \code{maxpts}. } \seealso{\code{\link[stats:TDist]{dt}}, \code{\link{rmnorm}} for use of argument \code{sqrt}, \code{\link{plot_fxy}} for plotting examples} \examples{ x <- seq(-2,4,length=21) y <- 2*x+10 z <- x+cos(y) mu <- c(1,12,2) Sigma <- matrix(c(1,2,0,2,5,0.5,0,0.5,3), 3, 3) df <- 4 f <- dmt(cbind(x,y,z), mu, Sigma,df) p1 <- pmt(c(2,11,3), mu, Sigma, df) p2 <- pmt(c(2,11,3), mu, Sigma, df, maxpts=10000, abseps=1e-8) x <- rmt(10, mu, Sigma, df) p <- sadmvt(df, lower=c(2,11,3), upper=rep(Inf,3), mu, Sigma) # upper tail # p0 <- pmt(c(2,11), mu[1:2], Sigma[1:2,1:2], df=5) p1 <- biv.nt.prob(5, lower=rep(-Inf,2), upper=c(2, 11), mu[1:2], Sigma[1:2,1:2]) p2 <- sadmvt(5, lower=rep(-Inf,2), upper=c(2, 11), mu[1:2], Sigma[1:2,1:2]) c(p0, p1, p2, p0-p1, p0-p2) } \keyword{distribution} \keyword{multivariate} \concept{multivariate t distribution} mnormt/man/mnormt-package.Rd0000644000176200001440000000417114247462037015551 0ustar liggesusers\name{mnormt-package} \alias{mnormt-package} \docType{package} \title{The 'mnormt' package: summary information} \description{ Functions are provided for computing the density and the distribution function of d-dimensional normal and \emph{t} random variables, possibly truncated (on one side or two sides, with componentwise choice), and for generating random vectors sampled from these distributions, except sampling from the truncated \emph{t}. Moments of arbitrary order of a truncated normal are computed, and converted to cumulants up to order 4. } \details{ Probabilities are computed via non-Monte Carlo methods; different routines are used in the case \code{d=1, d=2, d=3, d>2}, if \code{d} denotes the dimensionality. } \section{Licence}{ This package and its documentation are usable under the terms of the \dQuote{GNU General Public License} version 3 or version 2, as you prefer; a copy of them is available from \url{https://www.R-project.org/Licenses/}.} \author{ Adelchi Azzalini (R code and package creation) and Alan Genz (Fortran code, see the references below; this code incorporates routines of other authors). % Function \code{recintab} is the \R porting by Adelchi Azzalini of the % Matlab function with the same name by Kan and Robotti. } \references{ Genz, A. (1992). Numerical Computation of Multivariate Normal Probabilities. \emph{J. Computational and Graphical Statist.} \bold{1}, 141-149. Genz, A. (1993). Comparison of methods for the computation of multivariate normal probabilities. \emph{Computing Science and Statistics}, \bold{25}, 400-405. Genz, A.: Fortran code downloaded in 2006 from the author web page, located at \url{https://www.math.wsu.edu/faculty/genz/software/software.html}, as of 2020-06-01. } \keyword{package} \keyword{distribution} \keyword{multivariate} \concept{multivariate normal distribution} \concept{multivariate truncated normal distribution} \concept{multivariate t distribution} \concept{multivariate truncated t distribution} \concept{moments} \concept{cumulants} mnormt/man/mtruncnorm.Rd0000644000176200001440000001304214313353654015043 0ustar liggesusers\name{mtruncnorm} \alias{dmtruncnorm} \alias{pmtruncnorm} \alias{rmtruncnorm} \title{The multivariate truncated normal distribution} \description{ The probability density function, the distribution function and random number generation for the \code{d}-dimensional truncated normal (Gaussian) random variable. } \usage{ dmtruncnorm(x, mean, varcov, lower, upper, log = FALSE, ...) pmtruncnorm(x, mean, varcov, lower, upper, ...) rmtruncnorm(n, mean, varcov, lower, upper, start, burnin=5, thinning=1) } \arguments{ \item{x}{either a vector of length \code{d} or a matrix with \code{d} columns,representing the coordinates of the point(s) where the density must be evaluated. Here we denote \code{d=ncol(varcov)}; see \sQuote{Details} for restrictions.} \item{mean}{a \code{d}-vector representing the mean value of the pre-truncation normal distribution.} \item{varcov}{a symmetric positive definite matrix with dimensions \code{(d,d)} representing the variance matrix of the pre-truncation normal distribution.} \item{lower}{a \code{d}-vector representing the lower truncation values of the component variables; \code{-Inf} values are allowed. If missing, it is set equal to \code{rep(-Inf, d)}.} \item{upper}{a \code{d}-vector representing the upper truncation values of the component variables; \code{Inf} values are allowed. If missing, it is set equal to \code{rep(Inf, d)}.} \item{log}{a logical value (default value is \code{FALSE}); if \code{TRUE}, the logarithm of the density is computed.} \item{\dots}{arguments passed to \code{sadmvn}, among \code{maxpts}, \code{abseps}, \code{releps}.} \item{n}{the number of (pseudo) random vectors to be generated.} \item{start}{an optional vector of initial values; see \sQuote{Details}.} \item{burnin}{the number of burnin iterations of the Gibbs sampler (default: \code{5}); see \sQuote{Details}.} \item{thinning}{a positive integer representing the thinning factor of the internally generated Gibbs sequence (default: \code{1}); see \sQuote{Details}.} } \details{For \code{dmtruncnorm} and \code{pmtruncnorm}, the dimension \code{d} cannot exceed \code{20}. If this threshold is exceeded, \code{NA}s are returned. The constraint originates from the underlying function \code{\link{sadmvn}}. If \code{d>1}, \code{rmtruncnorm} uses a Gibbs sampling scheme as described by Breslaw (1994) and by Kotecha & Djurić (1999), Detailed algebraic expressions are provided by Wilhelm (2022). After some initial settings in \R, the core iteration is performed by a compiled \acronym{FORTRAN 77} subroutine, for numerical efficiency. If the \code{start} vector is not supplied, the mean value of the truncated distribution is used. This choice should provide a good starting point for the Gibbs iteration, which explains why the default value for the \code{burnin} stage is so small. Since successive random vectors generated by a Gibbs sampler are not independent, which can be a problem in certain applications. This dependence is typically ameliorated by generating a larger-than-required number of random vectors, followed by a \sQuote{thinning} stage; this can be obtained by setting the \code{thinning} argument larger that \code{1}. The overall number of generated points is \code{burnin+n*thinning}, and the returned object is formed by those with index in \code{burnin+(1:n)*thinning}. If \code{d=1}, the values are sampled using a non-iterative procedure, essentially as in equation (4) of Breslaw (1994), except that in this case the mean and the variance do not refer to a conditional distribution, but are the arguments supplied in the calling statement. } \value{ \code{dmtruncnorm} and \code{pmtruncnorm} return a numeric vector; \code{rmtruncnorm} returns a matrix, unless either \code{n=1} or \code{d=1}, in which case it returns a vector. } \author{Adelchi Azzalini} \seealso{\code{\link{plot_fxy}} for additional plotting examples, \code{\link{sadmvn}} for regulating accuracy via \code{...}} \examples{ # example with d=2 m2 <- c(0.5, -1) V2 <- matrix(c(3, 3, 3, 6), 2, 2) low <- c(-1, -2.8) up <- c(1.5, 1.5) # plotting truncated normal density using 'dmtruncnorm' and 'contour' functions plot_fxy(dmtruncnorm, xlim=c(-2, 2), ylim=c(-3, 2), mean=m2, varcov=V2, lower=low, upper=up, npt=101) set.seed(1) x <- rmtruncnorm(n=500, mean=m2, varcov=V2, lower=low, upper=up) points(x, cex=0.2, col="red") #------ # example with d=1 set.seed(1) low <- -4 hi <- 3 x <- rmtruncnorm(1e5, mean=2, varcov=5, lower=low, upper=hi) hist(x, prob=TRUE, xlim=c(-8, 12), main="Truncated univariate N(2, sqrt(5))") rug(c(low, hi), col=2) x0 <- seq(-8, 12, length=251) pdf <- dnorm(x0, 2, sqrt(5)) p <- pnorm(c(low, hi), 2, sqrt(5)) lines(x0, pdf/diff(p), col=4, lty=2) lines(x0, dmtruncnorm(x0, 2, 5, low, hi), col=2, lwd=2) } \references{ Breslaw, J.A. (1994) Random sampling from a truncated multivariate normal distribution. \emph{Appl. Math. Lett.} vol.7, pp.1-6. Kotecha, J.H. and Djurić, P.M. (1999). Gibbs sampling approach for generation of truncated multivariate Gaussian random variables. In \emph{ICASSP'99: Proceedings of IEEE International Conference on Acoustics, Speech, and Signal Processing}, vol.3, pp.1757-1760. \doi{10.1109/ICASSP.1999.756335}. Wilhelm, S. (2022). Gibbs sampler for the truncated multivariate normal distribution. Vignette of R package \url{https://cran.r-project.org/package=tmvtnorm}, version 1.5. } %--- \keyword{distribution} \keyword{multivariate} \concept{multivariate truncated normal distribution} mnormt/man/mom2cum.Rd0000644000176200001440000001355413674625655014242 0ustar liggesusers\name{mom2cum} \alias{mom2cum} \title{ Conversion of an array of moments to cumulants } \description{ Given an array of moments of a multivariate distribution, the corresponding cumulants up to the 4th order and other connected quantities are computed, notably the Mardia's measures of multivariate skewness and kurtosis } \usage{mom2cum(mom)} \arguments{ \item{mom}{an array whose entries are assumed to represent moments of a multivariate distribution; see \sQuote{Details} for an extended description.} } \details{The structure of the input array \code{mom} is of type \code{M/M[1]} where \code{M} represents the output from function \code{\link{recintab}}. For a \code{d}-dimensional random variable, \code{mom} is a \code{k}-fold \code{d}-dimensional array, where \code{k} is the highest order of moments being considered; see the documentation of \code{recintab} for a more detailed description. However, it is not necessary that \code{mom} originates from \code{recintab}; the moments can refer to any distribution, as long as \code{mom} has the appropriate structure and content. Also, it is not necessary that all entries of \code{mom} are there; values not required for the processing can be left as \code{NA}. For computing cumulants of order \code{k}, say, we only need cross moments whose exponents add up to \code{k} or less. Conversion from moments to cumulants is performed by using formulae (2.7) of McCullagh (1987). See also \eqn{\rho_{23}^2} in his (2.15) and \eqn{\rho_4} in (2.16) for computing the Mardia's (1970, 1974) measures of multivariate skewness and kurtosis. In some cases, the function may report inconsistencies detected in the argument \code{mom}. A typical origin of this situation is in numerical inaccuracies of the returned value of \code{\link{recintab}}, as explained in more detail in its documentation. When detected, cases of these sort are flagged in the returned \code{$message} string, and a warning message is issued. The absence of such string does not represent a guarantee of perfect input. } \value{ In the multivariate case, a list with the following elements, provided moments of the required order are available, up to the maximal order 4. \item{cum1}{the \code{d}-vector of first-order cumulants, \acronym{AKA} the expected value or the mean value; this will be there if \code{mom} contains all moments of order 1.} \item{order2}{a list with the following components: \code{m2}, the \code{(d,d)} matrix of second order moments; \code{cum2}, the \code{(d,d)} matrix of second order cumulants, \acronym{AKA} the variance-covariance matrix, the variance matrix, the covariance matrix, the dispersion matrix; \code{conc.matrix}, the concentration matrix, that is, the inverse of \code{cum2}; \code{log.det.cum2}, the logarithm of the determinant of \code{cum2}. } % end order2 \item{order3}{a list with the following components: \code{m3}, array of third order moments, having dimension \code{(d,d,d)}; \code{cum3}, array of third order cumulants, having dimension \code{(d,d,d)}; \code{m3.marginal}, vector of third order marginal moments; \code{centr.mom3.marginal}, vector of third order marginal central moments; \code{gamma1.marginal}, vector of third order marginal standardized cumulants; \code{gamma1.Mardia}, the Mardia measure of multivariate skewness; \code{beta1.Mardia}, the Mardia measure of multivariate skewness, again. } % end order3 \item{order4}{a list with the following components: \code{m4}, array of fourth order moments, with dimension \code{(d,d,d,d)}; \code{cum4}, array of fourth order cumulants, with dimension \code{(d,d,d,d)}; \code{m4.marginal}, vector of fourth order marginal moments; \code{centr.mom4.marginal}, vector of fourth order marginal central moments; \code{gamma2.marginal}, vector of fourth order marginal standardized cumulants; \code{gamma2.Mardia}, the Mardia measure of multivariate kurtosis, \eqn{\gamma_{2,d}}; \code{beta2.Mardia}, the Mardia measure of multivariate kurtosis, \eqn{\beta_{2,d}}. }% end order4 \item{message}{possibly, a character string indicating that some inconsistency has been detected in the argument \code{mom}; see \sQuote{Details}.} In the univariate case a list with elements: \item{cum}{a vector of cumulants,} \item{centr.mom}{a vector of central moments,} \item{std.cum}{a vector with the third and the fourth standardized cumulants (when enough moments are available), representing common measures of skewness and kurtosis.} \item{message}{possibly, a character string indicating that some inconsistency has been detected in the argument \code{mom}; see \sQuote{Details}.} } \references{ Mardia, K. V. (1970). Measures of multivariate skewness and kurtosis with applications \emph{Biometrika}, 57, 519-530. Mardia, K. V. (1974). Applications of some measures of multivariate skewness and kurtosis in testing normality and robustness studies. \emph{Sankhya ser.B}, 36, 115-128. McCullagh, Peter (1987). \emph{Tensor Methods in Statistics}. Chapman & Hall, London. } \author{Adelchi Azzalini} \note{In the case of a multivariate truncated normal distribution, a user does not need to call this function; \code{\link{mom.mtruncnorm}} provides a more convenient interface for the same computations. The present function needs to be called only if the array \code{mom} represents the moments of some other distribution.} \seealso{\code{\link{recintab}} } \examples{ mu <- c(1, -0.5) Sigma <- toeplitz(1/(1:2)) low <- c(-Inf, -3) hi <- c(1.5, Inf) mom <- recintab(c(3,3), low, hi, mu, Sigma) cum <- mom2cum(mom) print(cum$order3$gamma1.marginal) print(cum$order3$gamma1.Mardia) } %---- \keyword{distribution} \keyword{multivariate} \concept{moments} \concept{cumulants} \concept{Mardia's measures of multivariate skewness and kurtosis} \concept{multivariate truncated normal distribution} mnormt/man/sample_Mardia_measures.Rd0000644000176200001440000000525114246163417017305 0ustar liggesusers\name{sample_Mardia_measures} \alias{sample_Mardia_measures} \concept{Mardia measures of multivariate skewness and kurtosis} \title{ The Mardia measures of multivariate skewness and kurtosis for a given sample } \description{ Given a multivariate sample, the Mardia measures of skewness and kurtosis are computed, along with their \emph{p}-values for testing normality } \usage{ sample_Mardia_measures(data, correct = FALSE) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{data}{a data matrix} \item{correct}{(logical) if \code{correct=TRUE}, the \sQuote{corrected} sample variance matrix is used, otherwise the \sQuote{uncorrected} version is used (default)} } \details{ For a given a data matrix, the multivariate measures of skewness and kurtosis introduced by Mardia (1970, 1974) are computed, along with some associated quantities. We follow the notation of the 1974 paper. If \code{n} denotes the number of complete cases, the condition \code{n>3} is required for numerical computation. Clearly, a much larger \code{n} is required for meaningful statistical work. The sample variance matrix \eqn{S} appearing in (2.2) and (2.4) is computed here (in the dafault setting) with the \eqn{n} denominator, at variance from the commonly employed \code{n-1} denominator. With this definition of \eqn{S}, one obtains the same numerical outcome of the example on p.127 of Mardia (1974). The approximate observed significance levels for testing normality, \code{p.b1} and \code{p.b2}, are computed using expressions (5.5) and (5.6) in Section 5 of Mardia (1974). For \code{p.b2}, the condition \code{(n-d-1)>0} is required, where \code{d} denotes the number of variables. } \value{ A named vector with the following components: \item{b1}{the measure of asymmetry as given in (2.2)} \item{b2}{the measure of kurtosis as given in (2.4)} \item{g1}{the measure of asymmetry as given in (2.10)} \item{g2}{the measure of kurtosis as given in (2.11)} \item{p.b1}{observed significance level of \code{b1}} \item{p.b2}{observed significance level of \code{b2}} \item{n}{The number of complete cases in the input data matrix} where the quoted formulae are those of Mardia (1974). } \references{ Mardia, K. V. (1970). Measures of multivariate skewness and kurtosis with applications \emph{Biometrika}, 57, 519-530. Mardia, K. V. (1974). Applications of some measures of multivariate skewness and kurtosis in testing normality and robustness studies. \emph{Sankhya ser.B}, 36, 115-128. } \author{ Adelchi Azzalini } \examples{ set.seed(1) x <- rmnorm(100, mean=1:3, varcov=toeplitz(1/(1:3))) sample_Mardia_measures(x) } \keyword{distribution} \keyword{multivariate} mnormt/man/mom.mtruncnorm.Rd0000644000176200001440000001066614313350722015634 0ustar liggesusers\name{mom.mtruncnorm} \alias{mom.mtruncnorm} \title{Moments and other quantities of a (possibly) truncated multivariate normal distribution } \description{ Moments up to the specified orders of a possibly truncated \code{d}-dimensional normal distribution; the distribution must be non-degenerate. Each component variable can be truncated on one side (to the left or to the right) or on two sides or not truncated. After the initial stage, cumulants up to the fourth order and other quantities are computed, provided all moments of the required order had been computed in the first stage. } \usage{ mom.mtruncnorm(powers=4, mean, varcov, lower, upper, cum = TRUE, ...) } \arguments{ \item{powers}{a vector of non-negative integer values representing the required order of moments for each component variable, or a single such value, in which case this value is repeated for all component variables.} \item{mean}{a \code{d}-length vector representing the mean value of the pre-truncation normal random variable. If \code{d=length(mean)}, see \sQuote{Details} for restrictions on \code{d}.} \item{varcov}{a symmetric positive definite matrix with dimensions \code{(d,d)} representing the variance matrix of the pre-truncation normal random variable.} \item{lower}{a \code{d}-vector representing the lower truncation values of the component variables; \code{-Inf} values are allowed. If missing, it is set equal to \code{rep(-Inf, d)}.} \item{upper}{a \code{d}-vector representing the upper truncation values of the component variables; \code{Inf} values are allowed. If missing, it is set equal to \code{rep(Inf, d)}.} \item{cum}{a logical value; if code{TRUE} (default value), cumulants are other quantities are computed up to the minimum between the fourth order and the maximum possible order, given the available moments.} \item{\dots}{additional arguments passed to \code{sadmvn}; see \sQuote{Details} for a description.} } \details{ The maximal value of {d} is \code{20}. If this threshold is exceeded, \code{NA}s are returned. The constraint originates from the underlying function \code{\link{sadmvn}}. This function makes use of two workhorses, \code{recintab} and \code{mom2cum}, providing a user-friendly interface to these more basic tools. The first function computes an array of raw moments of the truncated normal; the second function translates them into cumulants and other quantities such as the Mardia's measures of skewness and kurtosis, unless \code{cum=FALSE}. See the documentation of these two underlying functions for additional information about the arguments and the returned quantities. The argument \code{...} is passed, via \code{recintab}, to \code{sadmvn} for regulation of its working. Not all \code{d} component variables need to be truncated. In fact, the function works also with no truncated components (just omit \code{lower} and \code{upper}), although for this case there exist known formulae to do the job. } \value{A list with the following components: \item{mom}{an array with raw moments as produced by \code{recintab}, followed by normalization; see its documentation for a description.} \item{cum1}{the vector of first-order cumulants, \acronym{AKA} the expected value or the mean value, which will be there provided \code{cum=TRUE} and all elements of \code{powers} are not less than 1.} \item{order2, ...}{additional lists with higher order terms up to order 4; these lists only exist when the available moments are of sufficiently high order. See \code{\link{mom2cum}} for a more detailed description.} } \author{Adelchi Azzalini} % \note{%% ~~further notes~~} \seealso{ \code{\link{recintab}}, \code{\link{mom2cum}}, \code{\link{sadmvn}} } \examples{ mu <- c(1, -0.5, 0) Sigma <- toeplitz(1/(1:3)) lower <- c(-Inf, -3, -4) upper <- c(1.5, Inf, 2) m <- mom.mtruncnorm(1, mu, Sigma, lower, upper) print(m$cum1) # m <- mom.mtruncnorm(3, mu, Sigma, lower, upper) print(m$order3$gamma1.marginal) print(m$order3$gamma1.Mardia) # #-- # Example 2 of Leppard & Tallis (1989, Appl.Stat. vol.38, p.547) truncp <- c(0, 1, 2) U <- c(0, 0, 0) V <- 0.5*(diag(3) + matrix(1, 3, 3)) m <- mom.mtruncnorm(2, U, V, truncp) print(m$cum1, digits=9) print(m$order2$cum2, digits=9) } %---- \keyword{distribution} \keyword{multivariate} \concept{moments} \concept{multivariate truncated normal distribution} mnormt/man/mtrunct.Rd0000644000176200001440000000473413670466646014356 0ustar liggesusers\name{mtrunct} \alias{dmtrunct} \alias{pmtrunct} \title{The multivariate truncated Student's \emph{t} distribution} \description{ The probability density function and the distribution function of the multivariate truncated Student's \emph{t} distribution } \usage{ dmtrunct(x, mean, S, df, lower, upper, log = FALSE, ...) pmtrunct(x, mean, S, df, lower, upper, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ either a vector of length \code{d} or a matrix with \code{d} columns, where \code{d=ncol(S)}, giving the coordinates of the point(s) where the density must be evaluated. } \item{mean}{either a vector of length \code{d}, representing the location parameter (equal to the mean vector when \code{df>1}) of the pre-truncation distribution or a matrix whose rows represent different mean vectors; in the matrix case, its dimensions must match those of \code{x}.} \item{S}{a symmetric positive-definite matrix representing the scale matrix, such that \code{S*df/(df-2)} is the variance-covariance matrix of the pre-truncation distribution when \code{df>2}.} \item{df}{degrees of freedom; it must be a positive integer} \item{lower}{a vector representing the lower truncation values of the component variables; \code{-Inf} values are allowed. If missing, it is set equal to \code{rep(-Inf, d)}.} \item{upper}{a vector representing the upper truncation values of the component variables; \code{Inf} values are allowed. If missing, it is set equal to \code{rep(Inf, d)}.} \item{log}{a logical value (default value is \code{FALSE}); if \code{TRUE}, the logarithm of the density is computed.} \item{\dots}{arguments passed to \code{sadmvt}, among \code{maxpts}, \code{absrel}, \code{releps}.} } \details{The dimension \code{d} cannot exceed \code{20}.} \value{a numeric vector} % \references{%% ~put references to the literature/web site here ~} \author{Adelchi Azzalini} % \note{%% ~~further notes~~} \seealso{ \code{\link{sadmvt}} for regulating accuracy} \examples{ m2 <- c(0.5, -1) V2 <- matrix(c(1.5, -1.75, -1.75, 3), 2, 2) lower <- a <- c(-1, -2.5) upper <- b <- c(2, 1) set.seed(1) points <- matrix(runif(10, -3, 3), nrow=5, ncol=2) pdf <- dmtrunct(points, mean=m2, S=V2, df=4, lower, upper) cdf <- pmtrunct(points, mean=m2, S=V2, df=4, lower, upper) } %---- \keyword{distribution} \keyword{multivariate} \concept{multivariate truncated t distribution} mnormt/man/pd.solve.Rd0000644000176200001440000000253312666762020014374 0ustar liggesusers\name{pd.solve} \alias{pd.solve} \title{Inverse of a symmetric positive-definite matrix} \description{ The inverse of a symmetric positive-definite matrix and its log-determinant } \usage{ pd.solve(x, silent = FALSE, log.det=FALSE) } \arguments{ \item{x}{a symmetric positive-definite matrix.} \item{silent}{a logical value which indicates the action to take in case of an error. If \code{silent==TRUE} and an error occurs, the function silently returns a \code{NULL} value; if \code{silent==FALSE} (default), an error generates a \code{stop} with an error message.} \item{log.det}{ a logical value to indicate whether the log-determinant of \code{x} is required (default is \code{FALSE}).} } \value{ the inverse matrix of \code{x}; if \code{log.det=TRUE}, this inverse has an attribute which contains the logarithm of the determinant of \code{x}. } \details{The function checks that \code{x} is a symmetric positive-definite matrix. If an error is detected, an action is taken which depends on the value of the argument \code{silent}. } \author{Adelchi Azzalini} \examples{ x <- toeplitz(rev(1:4)) x.inv <- pd.solve(x) print(x.inv \%*\% x) x.inv <- pd.solve(x, log.det=TRUE) logDet <- attr(x.inv, "log.det") print(abs(logDet - determinant(x, logarithm=TRUE)$modulus)) } \keyword{algebra} \keyword{array} mnormt/man/mnorm.Rd0000644000176200001440000001610314313360722013762 0ustar liggesusers\name{mnorm} \alias{dmnorm} \alias{pmnorm} \alias{rmnorm} \alias{sadmvn} \title{The multivariate normal distribution} \description{ The probability density function, the distribution function and random number generation for a \code{d}-dimensional multivariate normal (Gaussian) random variable. } \usage{ dmnorm(x, mean = rep(0, d), varcov, log = FALSE) pmnorm(x, mean = rep(0, d), varcov, ...) rmnorm(n = 1, mean = rep(0, d), varcov, sqrt=NULL) sadmvn(lower, upper, mean, varcov, maxpts = 2000*d, abseps = 1e-06, releps = 0) } \arguments{ \item{x}{either a vector of length \code{d} or a matrix with \code{d} columns representing the coordinates of the point(s) where the density must be evaluated; see also \sQuote{Details} for restrictions on \code{d}.} \item{mean}{either a vector of length \code{d}, representing the mean value, or (except for \code{rmnorm}) a matrix whose rows represent different mean vectors; in the matrix case, only allowed for \code{dmnorm} and \code{pmnorm}, its dimensions must match those of \code{x}.} \item{varcov}{a symmetric positive-definite matrix representing the variance-covariance matrix of the distribution; a vector of length 1 is also allowed (in this case, \code{d=1} is set).} \item{sqrt}{if not \code{NULL} (default value is \code{NULL}), a square root of the intended \code{varcov} matrix; see \sQuote{Details} for a full description.} \item{log}{a logical value (default value is \code{FALSE}); if \code{TRUE}, the logarithm of the density is computed.} \item{...}{arguments passed to \code{sadmvn}, among \code{maxpts}, \code{abseps}, \code{releps}.} \item{n}{the number of (pseudo) random vectors to be generated.} \item{lower}{a numeric vector of lower integration limits of the density function; must be of maximal length \code{20}; \code{+Inf} and \code{-Inf} entries are allowed.} \item{upper}{ a numeric vector of upper integration limits of the density function; must be of maximal length \code{20}; \code{+Inf} and \code{-Inf} entries are allowed.} \item{maxpts}{the maximum number of function evaluations (default value: \code{2000*d}).} \item{abseps}{absolute error tolerance (default value: \code{1e-6}).} \item{releps}{relative error tolerance (default value: \code{0}).} } \details{ The dimension \code{d} cannot exceed \code{20} for \code{pmnorm} and \code{sadmvn}. If this threshold is exceeded, \code{NA} is returned. The function \code{pmnorm} works by making a suitable call to \code{sadmvn} if \code{d>3}, or to \code{ptriv.nt} if \code{d=3}, or to \code{biv.nt.prob} if \code{d=2}, or to \code{pnorm} if \code{d=1}. The \R functions \code{sadmvn}, \code{ptriv.nt} and \code{biv.nt.prob} are, in essence, interfaces to underlying \acronym{Fortran 77} routines by Alan Genz; see the references below. These routines use adaptive numerical quadrature and other non-random type techniques. If \code{sqrt=NULL} (default value), the working of \code{rmnorm} involves computation of a square root of \code{varcov} via the Cholesky decomposition. If a non-\code{NULL} value of \code{sqrt} is supplied, it is assumed that it represents a matrix, \eqn{R} say, such that \eqn{R' R} represents the required variance-covariance matrix of the distribution; in this case, the argument \code{varcov} is ignored. This mechanism is intended primarily for use in a sequence of calls to \code{rmnorm}, all sampling from a distribution with fixed variance matrix; a suitable matrix \code{sqrt} can then be computed only once beforehand, avoiding that the same operation is repeated multiple times along the sequence of calls; see the examples below. Another use of \code{sqrt} is to supply a different form of square root of the variance-covariance matrix, in place of the Cholesky factor. For efficiency reasons, \code{rmnorm} does not perform checks on the supplied arguments. If, after setting the same seed value to \code{\link[base:Random]{set.seed}}, two calls to \code{rmnorm} are made with the same arguments except that one generates \code{n1} vectors and the other \code{n2} vectors, with \code{n1 Depends: R (>= 2.2.0) Description: Functions are provided for computing the density and the distribution function of d-dimensional normal and "t" random variables, possibly truncated (on one side or two sides), and for generating random vectors sampled from these distributions, except sampling from the truncated "t". Moments of arbitrary order of a multivariate truncated normal are computed, and converted to cumulants up to order 4. Probabilities are computed via non-Monte Carlo methods; different routines are used in the case d=1, d=2, d=3, d>3, if d denotes the dimensionality. License: GPL-2 | GPL-3 URL: http://azzalini.stat.unipd.it/SW/Pkg-mnormt/ NeedsCompilation: yes Encoding: UTF-8 Packaged: 2022-09-26 08:42:55 UTC; aa Repository: CRAN Date/Publication: 2022-09-26 10:10:06 UTC mnormt/build/0000755000176200001440000000000014314263017012666 5ustar liggesusersmnormt/build/partial.rdb0000644000176200001440000000007514314263017015015 0ustar liggesusers‹‹àb```b`abd`b1…À€… H02°0piÖ¼ÄÜÔb C"Éðw‚a7mnormt/src/0000755000176200001440000000000014314263017012356 5ustar liggesusersmnormt/src/biv-nt.f0000644000176200001440000004365213652027125013740 0ustar liggesusers* Selected portion of code downloaded from: * http://www.math.wsu.edu/faculty/genz/software/mvtdstpack.f * to compute bivariate normal and Student's t distribution functions. * * Author: * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * * except for some auxiliary functions whose authors are indicated * in the respective code below. * * In addition, the dummy subroutine below has been added, needed to interface * R and Fortran. Adelchi Azzalini, 2008-12-06 SUBROUTINE SMVBVT(PROB, NU, LOWER, UPPER, INFIN, CORREL) DOUBLE PRECISION PROB, LOWER(*), UPPER(*), CORREL, MVBVT INTEGER NU, INFIN(*) PROB = MVBVT(NU, LOWER, UPPER, INFIN, CORREL) RETURN END ************************************************************************ * DOUBLE PRECISION FUNCTION MVBVN( LOWER, UPPER, INFIN, CORREL ) * * A function for computing bivariate normal probabilities. * * Parameters * * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, correlation coefficient. * DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, MVBVU INTEGER INFIN(*) IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) + - MVBVU ( UPPER(1), LOWER(2), CORREL ) + - MVBVU ( LOWER(1), UPPER(2), CORREL ) + + MVBVU ( UPPER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 1 ) THEN MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) + - MVBVU ( UPPER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 2 ) THEN MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) + - MVBVU ( LOWER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 0 ) THEN MVBVN = MVBVU ( -UPPER(1), -UPPER(2), CORREL ) + - MVBVU ( -LOWER(1), -UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 2 ) THEN MVBVN = MVBVU ( -UPPER(1), -UPPER(2), CORREL ) + - MVBVU ( -UPPER(1), -LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 0 ) THEN MVBVN = MVBVU ( LOWER(1), -UPPER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 1 ) THEN MVBVN = MVBVU ( -UPPER(1), LOWER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 1 ) THEN MVBVN = MVBVU ( LOWER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 0 ) THEN MVBVN = MVBVU ( -UPPER(1), -UPPER(2), CORREL ) ELSE MVBVN = 1 END IF END DOUBLE PRECISION FUNCTION MVBVU( SH, SK, R ) * * A function for computing bivariate normal probabilities; * developed using * Drezner, Z. and Wesolowsky, G. O. (1989), * On the Computation of the Bivariate Normal Integral, * J. Stat. Comput. Simul.. 35 pp. 101-107. * with extensive modications for double precisions by * Alan Genz and Yihong Ge * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * * BVN - calculate the probability that X is larger than SH and Y is * larger than SK. * * Parameters * * SH REAL, integration limit * SK REAL, integration limit * R REAL, correlation coefficient * LG INTEGER, number of Gauss Rule Points and Weights * DOUBLE PRECISION BVN, SH, SK, R, ZERO, TWOPI INTEGER I, LG, NG PARAMETER ( ZERO = 0, TWOPI = 6.283185307179586D0 ) DOUBLE PRECISION X(10,3), W(10,3), AS, A, B, C, D, RS, XS DOUBLE PRECISION MVPHI, SN, ASR, H, K, BS, HS, HK SAVE X, W * Gauss Legendre Points and Weights, N = 6 DATA ( W(I,1), X(I,1), I = 1, 3 ) / * 0.1713244923791705D+00,-0.9324695142031522D+00, * 0.3607615730481384D+00,-0.6612093864662647D+00, * 0.4679139345726904D+00,-0.2386191860831970D+00/ * Gauss Legendre Points and Weights, N = 12 DATA ( W(I,2), X(I,2), I = 1, 6 ) / * 0.4717533638651177D-01,-0.9815606342467191D+00, * 0.1069393259953183D+00,-0.9041172563704750D+00, * 0.1600783285433464D+00,-0.7699026741943050D+00, * 0.2031674267230659D+00,-0.5873179542866171D+00, * 0.2334925365383547D+00,-0.3678314989981802D+00, * 0.2491470458134029D+00,-0.1252334085114692D+00/ * Gauss Legendre Points and Weights, N = 20 DATA ( W(I,3), X(I,3), I = 1, 10 ) / * 0.1761400713915212D-01,-0.9931285991850949D+00, * 0.4060142980038694D-01,-0.9639719272779138D+00, * 0.6267204833410906D-01,-0.9122344282513259D+00, * 0.8327674157670475D-01,-0.8391169718222188D+00, * 0.1019301198172404D+00,-0.7463319064601508D+00, * 0.1181945319615184D+00,-0.6360536807265150D+00, * 0.1316886384491766D+00,-0.5108670019508271D+00, * 0.1420961093183821D+00,-0.3737060887154196D+00, * 0.1491729864726037D+00,-0.2277858511416451D+00, * 0.1527533871307259D+00,-0.7652652113349733D-01/ IF ( ABS(R) .LT. 0.3 ) THEN NG = 1 LG = 3 ELSE IF ( ABS(R) .LT. 0.75 ) THEN NG = 2 LG = 6 ELSE NG = 3 LG = 10 ENDIF H = SH K = SK HK = H*K BVN = 0 IF ( ABS(R) .LT. 0.925 ) THEN HS = ( H*H + K*K )/2 ASR = ASIN(R) DO I = 1, LG SN = SIN(ASR*( X(I,NG)+1 )/2) BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) ) SN = SIN(ASR*(-X(I,NG)+1 )/2) BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) ) END DO BVN = BVN*ASR/(2*TWOPI) + MVPHI(-H)*MVPHI(-K) ELSE IF ( R .LT. 0 ) THEN K = -K HK = -HK ENDIF IF ( ABS(R) .LT. 1 ) THEN AS = ( 1 - R )*( 1 + R ) A = SQRT(AS) BS = ( H - K )**2 C = ( 4 - HK )/8 D = ( 12 - HK )/16 BVN = A*EXP( -(BS/AS + HK)/2 ) + *( 1 - C*(BS - AS)*(1 - D*BS/5)/3 + C*D*AS*AS/5 ) IF ( HK .GT. -160 ) THEN B = SQRT(BS) BVN = BVN - EXP(-HK/2)*SQRT(TWOPI)*MVPHI(-B/A)*B + *( 1 - C*BS*( 1 - D*BS/5 )/3 ) ENDIF A = A/2 DO I = 1, LG XS = ( A*(X(I,NG)+1) )**2 RS = SQRT( 1 - XS ) BVN = BVN + A*W(I,NG)* + ( EXP( -BS/(2*XS) - HK/(1+RS) )/RS + - EXP( -(BS/XS+HK)/2 )*( 1 + C*XS*( 1 + D*XS ) ) ) XS = AS*(-X(I,NG)+1)**2/4 RS = SQRT( 1 - XS ) BVN = BVN + A*W(I,NG)*EXP( -(BS/XS + HK)/2 ) + *( EXP( -HK*(1-RS)/(2*(1+RS)) )/RS + - ( 1 + C*XS*( 1 + D*XS ) ) ) END DO BVN = -BVN/TWOPI ENDIF IF ( R .GT. 0 ) BVN = BVN + MVPHI( -MAX( H, K ) ) IF ( R .LT. 0 ) BVN = -BVN + MAX( ZERO, MVPHI(-H) - MVPHI(-K) ) ENDIF MVBVU = BVN END * DOUBLE PRECISION FUNCTION MVSTDT( NU, T ) * * Student t Distribution Function * * T * TSTDNT = C I ( 1 + y*y/NU )**( -(NU+1)/2 ) dy * NU -INF * INTEGER NU, J DOUBLE PRECISION MVPHI, T, CSTHE, SNTHE, POLYN, TT, TS, RN, PI PARAMETER ( PI = 3.141592653589793D0 ) IF ( NU .LT. 1 ) THEN MVSTDT = MVPHI( T ) ELSE IF ( NU .EQ. 1 ) THEN MVSTDT = ( 1 + 2*ATAN( T )/PI )/2 ELSE IF ( NU .EQ. 2) THEN MVSTDT = ( 1 + T/SQRT( 2 + T*T ))/2 ELSE TT = T*T CSTHE = NU/( NU + TT ) POLYN = 1 DO J = NU - 2, 2, -2 POLYN = 1 + ( J - 1 )*CSTHE*POLYN/J END DO IF ( MOD( NU, 2 ) .EQ. 1 ) THEN RN = NU TS = T/SQRT(RN) MVSTDT = ( 1 + 2*( ATAN( TS ) + TS*CSTHE*POLYN )/PI )/2 ELSE SNTHE = T/SQRT( NU + TT ) MVSTDT = ( 1 + SNTHE*POLYN )/2 END IF IF ( MVSTDT .LT. 0 ) MVSTDT = 0 ENDIF END * DOUBLE PRECISION FUNCTION MVBVT( NU, LOWER, UPPER, INFIN, CORREL ) * * A function for computing bivariate normal and t probabilities. * * Parameters * * NU INTEGER degrees of freedom parameter; NU < 1 gives normal case. * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, correlation coefficient. * DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, MVBVN, MVBVTL INTEGER NU, INFIN(*) IF ( NU .LT. 1 ) THEN MVBVT = MVBVN ( LOWER, UPPER, INFIN, CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) + - MVBVTL ( NU, UPPER(1), LOWER(2), CORREL ) + - MVBVTL ( NU, LOWER(1), UPPER(2), CORREL ) + + MVBVTL ( NU, LOWER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 1 ) THEN MVBVT = MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL ) + - MVBVTL ( NU, -UPPER(1), -LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 2 ) THEN MVBVT = MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL ) + - MVBVTL ( NU, -LOWER(1), -UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 0 ) THEN MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) + - MVBVTL ( NU, LOWER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 2 ) THEN MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) + - MVBVTL ( NU, UPPER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 0 ) THEN MVBVT = MVBVTL ( NU, -LOWER(1), UPPER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 1 ) THEN MVBVT = MVBVTL ( NU, UPPER(1), -LOWER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 1 ) THEN MVBVT = MVBVTL ( NU, -LOWER(1), -LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 0 ) THEN MVBVT = MVBVTL ( NU, UPPER(1), UPPER(2), CORREL ) ELSE MVBVT = 1 END IF END IF END * DOUBLE PRECISION FUNCTION MVBVTC( NU, L, U, INFIN, RHO ) * * A function for computing complementary bivariate normal and t * probabilities. * * Parameters * * NU INTEGER degrees of freedom parameter. * L REAL, array of lower integration limits. * U REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(1) INFIN(2), then MVBVTC computes * 0 0 P( X>U(1), Y>U(2) ) * 1 0 P( XU(2) ) * 0 1 P( X>U(1), YU(1), Y>U(2) ) + P( XU(2) ) * 2 1 P( X>U(1), YU(1), Y>U(2) ) + P( X>U(1), YU(2) ) + P( XU(1), YU(1), Y>U(2) ) + P( XU(2) ) * * RHO REAL, correlation coefficient. * DOUBLE PRECISION L(*), U(*), LW(2), UP(2), B, RHO, MVBVT INTEGER I, NU, INFIN(*), INF(2) * DO I = 1, 2 IF ( MOD( INFIN(I), 2 ) .EQ. 0 ) THEN INF(I) = 1 LW(I) = U(I) ELSE INF(I) = 0 UP(I) = L(I) END IF END DO B = MVBVT( NU, LW, UP, INF, RHO ) DO I = 1, 2 IF ( INFIN(I) .EQ. 2 ) THEN INF(I) = 0 UP(I) = L(I) B = B + MVBVT( NU, LW, UP, INF, RHO ) END IF END DO IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN INF(1) = 1 LW(1) = U(1) B = B + MVBVT( NU, LW, UP, INF, RHO ) END IF MVBVTC = B END * double precision function mvbvtl( nu, dh, dk, r ) * * a function for computing bivariate t probabilities. * * Alan Genz * Department of Mathematics * Washington State University * Pullman, Wa 99164-3113 * Email : alangenz@wsu.edu * * this function is based on the method described by * Dunnett, C.W. and M. Sobel, (1954), * A bivariate generalization of Student's t-distribution * with tables for certain special cases, * Biometrika 41, pp. 153-169. * * mvbvtl - calculate the probability that x < dh and y < dk. * * parameters * * nu number of degrees of freedom * dh 1st lower integration limit * dk 2nd lower integration limit * r correlation coefficient * integer nu, j, hs, ks double precision dh, dk, r double precision tpi, pi, ors, hrk, krh, bvt, snu double precision gmph, gmpk, xnkh, xnhk, qhrk, hkn, hpk, hkrn double precision btnckh, btnchk, btpdkh, btpdhk, one parameter ( pi = 3.14159265358979323844d0, tpi = 2*pi, one = 1 ) snu = sqrt( dble(nu) ) ors = 1 - r*r hrk = dh - r*dk krh = dk - r*dh if ( abs(hrk) + ors .gt. 0 ) then xnhk = hrk**2/( hrk**2 + ors*( nu + dk**2 ) ) xnkh = krh**2/( krh**2 + ors*( nu + dh**2 ) ) else xnhk = 0 xnkh = 0 end if hs = sign( one, dh - r*dk ) ks = sign( one, dk - r*dh ) if ( mod( nu, 2 ) .eq. 0 ) then bvt = atan2( sqrt(ors), -r )/tpi gmph = dh/sqrt( 16*( nu + dh**2 ) ) gmpk = dk/sqrt( 16*( nu + dk**2 ) ) btnckh = 2*atan2( sqrt( xnkh ), sqrt( 1 - xnkh ) )/pi btpdkh = 2*sqrt( xnkh*( 1 - xnkh ) )/pi btnchk = 2*atan2( sqrt( xnhk ), sqrt( 1 - xnhk ) )/pi btpdhk = 2*sqrt( xnhk*( 1 - xnhk ) )/pi do j = 1, nu/2 bvt = bvt + gmph*( 1 + ks*btnckh ) bvt = bvt + gmpk*( 1 + hs*btnchk ) btnckh = btnckh + btpdkh btpdkh = 2*j*btpdkh*( 1 - xnkh )/( 2*j + 1 ) btnchk = btnchk + btpdhk btpdhk = 2*j*btpdhk*( 1 - xnhk )/( 2*j + 1 ) gmph = gmph*( 2*j - 1 )/( 2*j*( 1 + dh**2/nu ) ) gmpk = gmpk*( 2*j - 1 )/( 2*j*( 1 + dk**2/nu ) ) end do else qhrk = sqrt( dh**2 + dk**2 - 2*r*dh*dk + nu*ors ) hkrn = dh*dk + r*nu hkn = dh*dk - nu hpk = dh + dk bvt = atan2(-snu*(hkn*qhrk+hpk*hkrn),hkn*hkrn-nu*hpk*qhrk)/tpi if ( bvt .lt. -1d-15 ) bvt = bvt + 1 gmph = dh/( tpi*snu*( 1 + dh**2/nu ) ) gmpk = dk/( tpi*snu*( 1 + dk**2/nu ) ) btnckh = sqrt( xnkh ) btpdkh = btnckh btnchk = sqrt( xnhk ) btpdhk = btnchk do j = 1, ( nu - 1 )/2 bvt = bvt + gmph*( 1 + ks*btnckh ) bvt = bvt + gmpk*( 1 + hs*btnchk ) btpdkh = ( 2*j - 1 )*btpdkh*( 1 - xnkh )/( 2*j ) btnckh = btnckh + btpdkh btpdhk = ( 2*j - 1 )*btpdhk*( 1 - xnhk )/( 2*j ) btnchk = btnchk + btpdhk gmph = 2*j*gmph/( ( 2*j + 1 )*( 1 + dh**2/nu ) ) gmpk = 2*j*gmpk/( ( 2*j + 1 )*( 1 + dk**2/nu ) ) end do end if mvbvtl = bvt * * end mvbvtl * end * * DOUBLE PRECISION FUNCTION MVPHI(Z) * * Normal distribution probabilities accurate to 1d-15. * Reference: J.L. Schonfelder, Math Comp 32(1978), pp 1232-1240. * INTEGER I, IM DOUBLE PRECISION A(0:43), BM, B, BP, P, RTWO, T, XA, Z PARAMETER( RTWO = 1.414213562373095048801688724209D0, IM = 24 ) SAVE A DATA ( A(I), I = 0, 43 )/ & 6.10143081923200417926465815756D-1, & -4.34841272712577471828182820888D-1, & 1.76351193643605501125840298123D-1, & -6.0710795609249414860051215825D-2, & 1.7712068995694114486147141191D-2, & -4.321119385567293818599864968D-3, & 8.54216676887098678819832055D-4, & -1.27155090609162742628893940D-4, & 1.1248167243671189468847072D-5, 3.13063885421820972630152D-7, & -2.70988068537762022009086D-7, 3.0737622701407688440959D-8, & 2.515620384817622937314D-9, -1.028929921320319127590D-9, & 2.9944052119949939363D-11, 2.6051789687266936290D-11, & -2.634839924171969386D-12, -6.43404509890636443D-13, & 1.12457401801663447D-13, 1.7281533389986098D-14, & -4.264101694942375D-15, -5.45371977880191D-16, & 1.58697607761671D-16, 2.0899837844334D-17, & -5.900526869409D-18, -9.41893387554D-19, 2.14977356470D-19, & 4.6660985008D-20, -7.243011862D-21, -2.387966824D-21, & 1.91177535D-22, 1.20482568D-22, -6.72377D-25, -5.747997D-24, & -4.28493D-25, 2.44856D-25, 4.3793D-26, -8.151D-27, -3.089D-27, & 9.3D-29, 1.74D-28, 1.6D-29, -8.0D-30, -2.0D-30 / * XA = ABS(Z)/RTWO IF ( XA .GT. 100 ) THEN P = 0 ELSE T = ( 8*XA - 30 ) / ( 4*XA + 15 ) BM = 0 B = 0 DO I = IM, 0, -1 BP = B B = BM BM = T*B - BP + A(I) END DO P = EXP( -XA*XA )*( BM - BP )/4 END IF IF ( Z .GT. 0 ) P = 1 - P MVPHI = P END * mnormt/src/tvpack.f0000644000176200001440000006113513664752535014042 0ustar liggesusers* source: http://www.sci.wsu.edu/math/faculty/genz/software/tvpack.f * Author: * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu C------- C A dummy subroutine has been added, required to interface R and Fortran. C This is listed just after the present passage. The lines of the driver C program TVTST have been commented out, and also those of function STUDNT C which already exists in file sadmvnt.f -- Adelchi Azzalini (2020-05-30) subroutine stvtl(prob, nu, h, r, epsi) integer nu double precision prob, h(3), r(3), epsi, tvtl prob = tvtl(nu, h, r, epsi) return end C------ * * This file contains a test program and functions TVTL (trivariate normal * and t), BVTL (bivariate t), BVND (bivariate normal), STUDNT (univariate * t), PHID (univariate normal), plus some support functions. * The file is self contained and should compile without errors on (77) * standard Fortran compilers. The test program demonstrates the use of * TVTL for computing trivariate distribution values 20 test problems * with NU = 0 (normal case), 3, 6, 9, and 12. * * The software is based on work described in the paper * "Numerical Computation of Rectangular Bivariate and Trivariate Normal * and t Probabilities", by * * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * C PROGRAM TVTST C INTEGER I, J, NU, NT C PARAMETER ( NT = 20 ) C DOUBLE PRECISION TVTL, LIMIT(3,NT), SIGMA(3,NT), EPS, V C DATA ( LIMIT(I,1), I = 1, 3 ), ( SIGMA(I,1), I = 1, 3 ) C & / .5D0, .5D0, .8D0, .1D0, .6D0, .8D0 / C DATA ( LIMIT(I,2), I = 1, 3 ), ( SIGMA(I,2), I = 1, 3 ) C & / -2.5D0, .5D0, .8D0, .1D0, -.6D0, -.8D0 / C DATA ( LIMIT(I,3), I = 1, 3 ), ( SIGMA(I,3), I = 1, 3 ) C & / 1.5D0, .5D0, .8D0, .1D0, .6D0, .8D0 / C DATA ( LIMIT(I,4), I = 1, 3 ), ( SIGMA(I,4), I = 1, 3 ) C & / .5D0, .5D0, .8D0, .1D0, -.6D0, -.8D0 / C DATA ( LIMIT(I,5), I = 1, 3 ), ( SIGMA(I,5), I = 1, 3 ) C & / .5D0, .5D0, .8D0, .1D0, -.5D0, .5D0 / C DATA ( LIMIT(I,6), I = 1, 3 ), ( SIGMA(I,6), I = 1, 3 ) C & / -1.5D0, .5D0, .8D0, .1D0, -.5D0, .5D0 / C DATA ( LIMIT(I,7), I = 1, 3 ), ( SIGMA(I,7), I = 1, 3 ) C & / 1.5D0, .5D0, .8D0, .1D0, .5D0, -.5D0 / C DATA ( LIMIT(I,8), I = 1, 3 ), ( SIGMA(I,8), I = 1, 3 ) C & / -.5D0, 1D0, 1.2D0, -.4D0, .2D0, .7D0 / C DATA ( LIMIT(I,9), I = 1, 3 ), ( SIGMA(I,9), I = 1, 3 ) C & / 1D0, 1D0, 2D0, .4D0, .8D0, .8D0 / C DATA ( LIMIT(I,10), I = 1, 3 ), ( SIGMA(I,10), I = 1, 3 ) C & / 1D0, 2D0, 1D0, .4D0, .8D0, .8D0 / C DATA ( LIMIT(I,11), I = 1, 3 ), ( SIGMA(I,11), I = 1, 3 ) C & / -2D0, -2D0, -2D0, .4D0, .8D0, .8D0 / C DATA ( LIMIT(I,12), I = 1, 3 ), ( SIGMA(I,12), I = 1, 3 ) C * / 1D0, 2D0, 3D0, -.998D0, -0.248D0, 0.248D0 / C DATA ( LIMIT(I,13), I = 1, 3 ), ( SIGMA(I,13), I = 1, 3 ) C * / -1D0, 2D0, 3D0, .25D0, 0.25D0, 0.25D0 / C DATA ( LIMIT(I,14), I = 1, 3 ), ( SIGMA(I,14), I = 1, 3 ) C * / 1D0, 1D0, 3D0, .998D0, 0.2482D0, 0.2487D0 / C DATA ( LIMIT(I,15), I = 1, 3 ), ( SIGMA(I,15), I = 1, 3 ) C * / 1D0, 1D0, 3D0, .998D0, 0.5D0, 0.5D0 / C DATA ( LIMIT(I,16), I = 1, 3 ), ( SIGMA(I,16), I = 1, 3 ) C * / 1D0, 1D0, 3D0, .99D0, 0.99D0, 0.99D0 / C DATA ( LIMIT(I,17), I = 1, 3 ), ( SIGMA(I,17), I = 1, 3 ) C * / 1D0, 2D0, 3D0, -1D0, -.99D0, .99D0 / C DATA ( LIMIT(I,18), I = 1, 3 ), ( SIGMA(I,18), I = 1, 3 ) C * / 1D0, 2D0, 3D0, 1D0, -.99D0, -.99D0 / C DATA ( LIMIT(I,19), I = 1, 3 ), ( SIGMA(I,19), I = 1, 3 ) C * / 1D0, -1D0, 1D0, .998D0, -0.2482D0, -0.2482D0 / C DATA ( LIMIT(I,NT), I = 1, 3 ), ( SIGMA(I,NT), I = 1, 3 ) C * / 1D0, -1D0, 2D0, .99992D0, 0.64627D0, 0.63975D0 / C EPS = 1D-6 C PRINT '('' Trivariate t Test with EPS ='', E10.1)', EPS C DO NU = 0, 12, 3 C PRINT '(''NU B1 B2 B3 R21 R31 R32 TVT'')' C DO J = 1, NT C V = TVTL( NU, LIMIT(1,J), SIGMA(1,J), EPS ) C PRINT '(I2,3F5.1,3F9.5,F13.10)', NU, C & ( LIMIT(I,J), I = 1, 3 ), ( SIGMA(I,J), I = 1, 3 ), V C END DO C END DO C END * DOUBLE PRECISION FUNCTION TVTL( NU, H, R, EPSI ) * * A function for computing trivariate normal and t-probabilities. * This function uses algorithms developed from the ideas * described in the papers: * R.L. Plackett, Biometrika 41(1954), pp. 351-360. * Z. Drezner, Math. Comp. 62(1994), pp. 289-294. * with adaptive integration from (0,0,1) to (0,0,r23) to R. * * Calculate the probability that X(I) < H(I), for I = 1,2,3 * NU INTEGER degrees of freedom; use NU = 0 for normal cases. * H REAL array of uppoer limits for probability distribution * R REAL array of three correlation coefficients, R should * contain the lower left portion of the correlation matrix r. * R should contains the values r21, r31, r23 in that order. * EPSI REAL required absolute accuracy; maximum accuracy for most * computations is approximately 1D-14 * * The software is based on work described in the paper * "Numerical Computation of Rectangular Bivariate and Trivariate * Normal and t Probabilities", by the code author: * * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * EXTERNAL TVTMFN INTEGER NU, NUC DOUBLE PRECISION H(3), H1, H2, H3, R(3), R12, R13, R23, EPSI DOUBLE PRECISION ONE, ZRO, EPS, ZROS(3), HS(3), TVT DOUBLE PRECISION RUA, RUB, AR, RUC, PT, BVTL, PHID, ADONET PARAMETER ( ZRO = 0, ONE = 1 ) COMMON /TVTMBK/ H1, H2, H3, R23, RUA, RUB, AR, RUC, NUC EPS = MAX( 1D-14, EPSI ) PT = ASIN(ONE) NUC = NU H1 = H(1) H2 = H(2) H3 = H(3) R12 = R(1) R13 = R(2) R23 = R(3) * * Sort R's and check for special cases * IF ( ABS(R12) .GT. ABS(R13) ) THEN H2 = H3 H3 = H(2) R12 = R13 R13 = R(1) END IF IF ( ABS(R13) .GT. ABS(R23) ) THEN H1 = H2 H2 = H(1) R23 = R13 R13 = R(3) END IF TVT = 0 IF ( ABS(H1) + ABS(H2) + ABS(H3) .LT. EPS ) THEN TVT = ( 1 + ( ASIN(R12) + ASIN(R13) + ASIN(R23) )/PT )/8 ELSE IF ( NU .LT. 1 .AND. ABS(R12) + ABS(R13) .LT. EPS ) THEN TVT = PHID(H1)*BVTL( NU, H2, H3, R23 ) ELSE IF ( NU .LT. 1 .AND. ABS(R13) + ABS(R23) .LT. EPS ) THEN TVT = PHID(H3)*BVTL( NU, H1, H2, R12 ) ELSE IF ( NU .LT. 1 .AND. ABS(R12) + ABS(R23) .LT. EPS ) THEN TVT = PHID(H2)*BVTL( NU, H1, H3, R13 ) ELSE IF ( 1 - R23 .LT. EPS ) THEN TVT = BVTL( NU, H1, MIN( H2, H3 ), R12 ) ELSE IF ( R23 + 1 .LT. EPS ) THEN IF ( H2 .GT. -H3 ) & TVT = BVTL( NU, H1, H2, R12 ) - BVTL( NU, H1, -H3, R12 ) ELSE * * Compute singular TVT value * IF ( NU .LT. 1 ) THEN TVT = BVTL( NU, H2, H3, R23 )*PHID(H1) ELSE IF ( R23 .GE. 0 ) THEN TVT = BVTL( NU, H1, MIN( H2, H3 ), ZRO ) ELSE IF ( H2 .GT. -H3 ) THEN TVT = BVTL( NU, H1, H2, ZRO ) - BVTL( NU, H1, -H3, ZRO ) END IF * * Use numerical integration to compute probability * * RUA = ASIN( R12 ) RUB = ASIN( R13 ) AR = ASIN( R23) RUC = SIGN( PT, AR ) - AR TVT = TVT + ADONET( TVTMFN, ZRO, ONE, EPS )/( 4*PT ) END IF TVTL = MAX( ZRO, MIN( TVT, ONE ) ) END * DOUBLE PRECISION FUNCTION TVTMFN( X ) * * Computes Plackett formula integrands * INTEGER NU DOUBLE PRECISION X, H1, H2, H3, R23, RUA, RUB, AR, RUC DOUBLE PRECISION R12, RR2, R13, RR3, R, RR, ZRO, PNTGND PARAMETER ( ZRO = 0 ) COMMON /TVTMBK/ H1, H2, H3, R23, RUA, RUB, AR, RUC, NU TVTMFN = 0 CALL SINCS( RUA*X, R12, RR2 ) CALL SINCS( RUB*X, R13, RR3 ) IF ( ABS(RUA) .GT. 0 ) & TVTMFN = TVTMFN + RUA*PNTGND( NU, H1,H2,H3, R13,R23,R12,RR2 ) IF ( ABS(RUB) .GT. 0 ) & TVTMFN = TVTMFN + RUB*PNTGND( NU, H1,H3,H2, R12,R23,R13,RR3 ) IF ( NU .GT. 0 ) THEN CALL SINCS( AR + RUC*X, R, RR ) TVTMFN = TVTMFN - RUC*PNTGND( NU, H2, H3, H1, ZRO, ZRO, R, RR ) END IF END * SUBROUTINE SINCS( X, SX, CS ) * * Computes SIN(X), COS(X)^2, with series approx. for |X| near PI/2 * DOUBLE PRECISION X, SX, CS, PT, EE PARAMETER ( PT = 1.57079632679489661923132169163975D0 ) EE = ( PT - ABS(X) )**2 IF ( EE .LT. 5D-5 ) THEN SX = SIGN( 1 - EE*( 1 - EE/12 )/2, X ) CS = EE*( 1 - EE*( 1 - 2*EE/15 )/3 ) ELSE SX = SIN(X) CS = 1 - SX*SX END IF END * DOUBLE PRECISION FUNCTION PNTGND( NU, BA, BB, BC, RA, RB, R, RR ) * * Computes Plackett formula integrand * INTEGER NU DOUBLE PRECISION BA, BB, BC, RA, RB, R, RR DOUBLE PRECISION DT, FT, BT, PHID, STUDNT PNTGND = 0 DT = RR*( RR - ( RA - RB )**2 - 2*RA*RB*( 1 - R ) ) IF ( DT .GT. 0 ) THEN BT = ( BC*RR + BA*( R*RB - RA ) + BB*( R*RA -RB ) )/SQRT(DT) FT = ( BA - R*BB )**2/RR + BB*BB IF ( NU .LT. 1 ) THEN IF ( BT .GT. -10 .AND. FT .LT. 100 ) THEN PNTGND = EXP( -FT/2 ) IF ( BT .LT. 10 ) PNTGND = PNTGND*PHID(BT) END IF ELSE FT = SQRT( 1 + FT/NU ) PNTGND = STUDNT( NU, BT/FT )/FT**NU END IF END IF END * DOUBLE PRECISION FUNCTION ADONET( F, A, B, TOL ) * * One Dimensional Globally Adaptive Integration Function * EXTERNAL F DOUBLE PRECISION F, A, B, TOL INTEGER NL, I, IM, IP PARAMETER ( NL = 100 ) DOUBLE PRECISION EI(NL), AI(NL), BI(NL), FI(NL), FIN, ERR, KRNRDT COMMON /ABLK/ ERR, IM AI(1) = A BI(1) = B ERR = 1 IP = 1 IM = 1 DO WHILE ( 4*ERR .GT. TOL .AND. IM .LT. NL ) IM = IM + 1 BI(IM) = BI(IP) AI(IM) = ( AI(IP) + BI(IP) )/2 BI(IP) = AI(IM) FI(IP) = KRNRDT( AI(IP), BI(IP), F, EI(IP) ) FI(IM) = KRNRDT( AI(IM), BI(IM), F, EI(IM) ) ERR = 0 FIN = 0 DO I = 1, IM IF ( EI(I) .GT. EI(IP) ) IP = I FIN = FIN + FI(I) ERR = ERR + EI(I)**2 END DO ERR = SQRT( ERR ) END DO ADONET = FIN END * DOUBLE PRECISION FUNCTION KRNRDT( A, B, F, ERR ) * * Kronrod Rule * DOUBLE PRECISION A, B, ERR, T, CEN, F, FC, WID, RESG, RESK * * The abscissae and weights are given for the interval (-1,1); * only positive abscissae and corresponding weights are given. * * XGK - abscissae of the 2N+1-point Kronrod rule: * XGK(2), XGK(4), ... N-point Gauss rule abscissae; * XGK(1), XGK(3), ... optimally added abscissae. * WGK - weights of the 2N+1-point Kronrod rule. * WG - weights of the N-point Gauss rule. * INTEGER J, N PARAMETER ( N = 11 ) DOUBLE PRECISION WG(0:(N+1)/2), WGK(0:N), XGK(0:N) SAVE WG, WGK, XGK DATA WG( 0)/ 0.2729250867779007D+00/ DATA WG( 1)/ 0.5566856711617449D-01/ DATA WG( 2)/ 0.1255803694649048D+00/ DATA WG( 3)/ 0.1862902109277352D+00/ DATA WG( 4)/ 0.2331937645919914D+00/ DATA WG( 5)/ 0.2628045445102478D+00/ * DATA XGK( 0)/ 0.0000000000000000D+00/ DATA XGK( 1)/ 0.9963696138895427D+00/ DATA XGK( 2)/ 0.9782286581460570D+00/ DATA XGK( 3)/ 0.9416771085780681D+00/ DATA XGK( 4)/ 0.8870625997680953D+00/ DATA XGK( 5)/ 0.8160574566562211D+00/ DATA XGK( 6)/ 0.7301520055740492D+00/ DATA XGK( 7)/ 0.6305995201619651D+00/ DATA XGK( 8)/ 0.5190961292068118D+00/ DATA XGK( 9)/ 0.3979441409523776D+00/ DATA XGK(10)/ 0.2695431559523450D+00/ DATA XGK(11)/ 0.1361130007993617D+00/ * DATA WGK( 0)/ 0.1365777947111183D+00/ DATA WGK( 1)/ 0.9765441045961290D-02/ DATA WGK( 2)/ 0.2715655468210443D-01/ DATA WGK( 3)/ 0.4582937856442671D-01/ DATA WGK( 4)/ 0.6309742475037484D-01/ DATA WGK( 5)/ 0.7866457193222764D-01/ DATA WGK( 6)/ 0.9295309859690074D-01/ DATA WGK( 7)/ 0.1058720744813894D+00/ DATA WGK( 8)/ 0.1167395024610472D+00/ DATA WGK( 9)/ 0.1251587991003195D+00/ DATA WGK(10)/ 0.1312806842298057D+00/ DATA WGK(11)/ 0.1351935727998845D+00/ * * Major variables * * CEN - mid point of the interval * WID - half-length of the interval * RESG - result of the N-point Gauss formula * RESK - result of the 2N+1-point Kronrod formula * * Compute the 2N+1-point Kronrod approximation to * the integral, and estimate the absolute error. * WID = ( B - A )/2 CEN = ( B + A )/2 FC = F(CEN) RESG = FC*WG(0) RESK = FC*WGK(0) DO J = 1, N T = WID*XGK(J) FC = F( CEN - T ) + F( CEN + T ) RESK = RESK + WGK(J)*FC IF( MOD( J, 2 ) .EQ. 0 ) RESG = RESG + WG(J/2)*FC END DO KRNRDT = WID*RESK ERR = ABS( WID*( RESK - RESG ) ) END * C DOUBLE PRECISION FUNCTION STUDNT( NU, T ) * * Student t Distribution Function * * T * STUDNT = C I ( 1 + y*y/NU )**( -(NU+1)/2 ) dy * NU -INF * C INTEGER NU, J C DOUBLE PRECISION T, ZRO, ONE, PI, PHID C DOUBLE PRECISION CSSTHE, SNTHE, POLYN, TT, TS, RN C PARAMETER ( ZRO = 0, ONE = 1 ) C PI = ACOS(-ONE) C IF ( NU .LT. 1 ) THEN C STUDNT = PHID( T ) C ELSE IF ( NU .EQ. 1 ) THEN C STUDNT = ( 1 + 2*ATAN(T)/PI )/2 C ELSE IF ( NU .EQ. 2 ) THEN C STUDNT = ( 1 + T/SQRT( 2 + T*T ))/2 C ELSE C TT = T*T C CSSTHE = 1/( 1 + TT/NU ) C POLYN = 1 C DO J = NU-2, 2, -2 C POLYN = 1 + ( J - 1 )*CSSTHE*POLYN/J C END DO C IF ( MOD( NU, 2 ) .EQ. 1 ) THEN C RN = NU C TS = T/SQRT(RN) C STUDNT = ( 1 + 2*( ATAN(TS) + TS*CSSTHE*POLYN )/PI )/2 C ELSE C SNTHE = T/SQRT( NU + TT ) C STUDNT = ( 1 + SNTHE*POLYN )/2 C END IF C STUDNT = MAX( ZRO, MIN( STUDNT, ONE ) ) C ENDIF C END * DOUBLE PRECISION FUNCTION BVTL( NU, DH, DK, R ) * * A function for computing bivariate t probabilities. * * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * * This function is based on the method described by * Dunnett, C.W. and M. Sobel, (1954), * A bivariate generalization of Student's t-distribution * with tables for certain special cases, * Biometrika 41, pp. 153-169. * * BVTL - calculate the probability that X < DH and Y < DK. * * parameters * * NU number of degrees of freedom * DH 1st lower integration limit * DK 2nd lower integration limit * R correlation coefficient * INTEGER NU, J, HS, KS DOUBLE PRECISION DH, DK, R DOUBLE PRECISION TPI, PI, ORS, HRK, KRH, BVT, SNU, BVND, STUDNT DOUBLE PRECISION GMPH, GMPK, XNKH, XNHK, QHRK, HKN, HPK, HKRN DOUBLE PRECISION BTNCKH, BTNCHK, BTPDKH, BTPDHK, ONE, EPS PARAMETER ( ONE = 1, EPS = 1D-15 ) IF ( NU .LT. 1 ) THEN BVTL = BVND( -DH, -DK, R ) ELSE IF ( 1 - R .LE. EPS ) THEN BVTL = STUDNT( NU, MIN( DH, DK ) ) ELSE IF ( R + 1 .LE. EPS ) THEN IF ( DH .GT. -DK ) THEN BVTL = STUDNT( NU, DH ) - STUDNT( NU, -DK ) ELSE BVTL = 0 END IF ELSE PI = ACOS(-ONE) TPI = 2*PI SNU = NU SNU = SQRT(SNU) ORS = 1 - R*R HRK = DH - R*DK KRH = DK - R*DH IF ( ABS(HRK) + ORS .GT. 0 ) THEN XNHK = HRK**2/( HRK**2 + ORS*( NU + DK**2 ) ) XNKH = KRH**2/( KRH**2 + ORS*( NU + DH**2 ) ) ELSE XNHK = 0 XNKH = 0 END IF HS = SIGN( ONE, DH - R*DK ) KS = SIGN( ONE, DK - R*DH ) IF ( MOD( NU, 2 ) .EQ. 0 ) THEN BVT = ATAN2( SQRT(ORS), -R )/TPI GMPH = DH/SQRT( 16*( NU + DH**2 ) ) GMPK = DK/SQRT( 16*( NU + DK**2 ) ) BTNCKH = 2*ATAN2( SQRT( XNKH ), SQRT( 1 - XNKH ) )/PI BTPDKH = 2*SQRT( XNKH*( 1 - XNKH ) )/PI BTNCHK = 2*ATAN2( SQRT( XNHK ), SQRT( 1 - XNHK ) )/PI BTPDHK = 2*SQRT( XNHK*( 1 - XNHK ) )/PI DO J = 1, NU/2 BVT = BVT + GMPH*( 1 + KS*BTNCKH ) BVT = BVT + GMPK*( 1 + HS*BTNCHK ) BTNCKH = BTNCKH + BTPDKH BTPDKH = 2*J*BTPDKH*( 1 - XNKH )/( 2*J + 1 ) BTNCHK = BTNCHK + BTPDHK BTPDHK = 2*J*BTPDHK*( 1 - XNHK )/( 2*J + 1 ) GMPH = GMPH*( 2*J - 1 )/( 2*J*( 1 + DH**2/NU ) ) GMPK = GMPK*( 2*J - 1 )/( 2*J*( 1 + DK**2/NU ) ) END DO ELSE QHRK = SQRT( DH**2 + DK**2 - 2*R*DH*DK + NU*ORS ) HKRN = DH*DK + R*NU HKN = DH*DK - NU HPK = DH + DK BVT = ATAN2( -SNU*( HKN*QHRK + HPK*HKRN ), & HKN*HKRN-NU*HPK*QHRK )/TPI IF ( BVT .LT. -EPS ) BVT = BVT + 1 GMPH = DH/( TPI*SNU*( 1 + DH**2/NU ) ) GMPK = DK/( TPI*SNU*( 1 + DK**2/NU ) ) BTNCKH = SQRT( XNKH ) BTPDKH = BTNCKH BTNCHK = SQRT( XNHK ) BTPDHK = BTNCHK DO J = 1, ( NU - 1 )/2 BVT = BVT + GMPH*( 1 + KS*BTNCKH ) BVT = BVT + GMPK*( 1 + HS*BTNCHK ) BTPDKH = ( 2*J - 1 )*BTPDKH*( 1 - XNKH )/( 2*J ) BTNCKH = BTNCKH + BTPDKH BTPDHK = ( 2*J - 1 )*BTPDHK*( 1 - XNHK )/( 2*J ) BTNCHK = BTNCHK + BTPDHK GMPH = 2*J*GMPH/( ( 2*J + 1 )*( 1 + DH**2/NU ) ) GMPK = 2*J*GMPK/( ( 2*J + 1 )*( 1 + DK**2/NU ) ) END DO END IF BVTL = BVT END IF * END BVTL END * DOUBLE PRECISION FUNCTION PHID(Z) * * Normal distribution probabilities accurate to 1d-15. * Reference: J.L. Schonfelder, Math Comp 32(1978), pp 1232-1240. * INTEGER I, IM DOUBLE PRECISION A(0:43), BM, B, BP, P, RTWO, T, XA, Z PARAMETER( RTWO = 1.414213562373095048801688724209D0, IM = 24 ) SAVE A DATA ( A(I), I = 0, 43 )/ & 6.10143081923200417926465815756D-1, & -4.34841272712577471828182820888D-1, & 1.76351193643605501125840298123D-1, & -6.0710795609249414860051215825D-2, & 1.7712068995694114486147141191D-2, & -4.321119385567293818599864968D-3, & 8.54216676887098678819832055D-4, & -1.27155090609162742628893940D-4, & 1.1248167243671189468847072D-5, 3.13063885421820972630152D-7, & -2.70988068537762022009086D-7, 3.0737622701407688440959D-8, & 2.515620384817622937314D-9, -1.028929921320319127590D-9, & 2.9944052119949939363D-11, 2.6051789687266936290D-11, & -2.634839924171969386D-12, -6.43404509890636443D-13, & 1.12457401801663447D-13, 1.7281533389986098D-14, & -4.264101694942375D-15, -5.45371977880191D-16, & 1.58697607761671D-16, 2.0899837844334D-17, & -5.900526869409D-18, -9.41893387554D-19, 2.14977356470D-19, & 4.6660985008D-20, -7.243011862D-21, -2.387966824D-21, & 1.91177535D-22, 1.20482568D-22, -6.72377D-25, -5.747997D-24, & -4.28493D-25, 2.44856D-25, 4.3793D-26, -8.151D-27, -3.089D-27, & 9.3D-29, 1.74D-28, 1.6D-29, -8.0D-30, -2.0D-30 / * XA = ABS(Z)/RTWO IF ( XA .GT. 100 ) THEN P = 0 ELSE T = ( 8*XA - 30 ) / ( 4*XA + 15 ) BM = 0 B = 0 DO I = IM, 0, -1 BP = B B = BM BM = T*B - BP + A(I) END DO P = EXP( -XA*XA )*( BM - BP )/4 END IF IF ( Z .GT. 0 ) P = 1 - P PHID = P END * DOUBLE PRECISION FUNCTION BVND( DH, DK, R ) * * A function for computing bivariate normal probabilities. * * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * * This function is based on the method described by * Drezner, Z and G.O. Wesolowsky, (1989), * On the computation of the bivariate normal integral, * Journal of Statist. Comput. Simul. 35, pp. 101-107, * with major modifications for double precision, and for |R| close to 1. * * BVND calculates the probability that X > DH and Y > DK. * Note: Prob( X < DH, Y < DK ) = BVND( -DH, -DK, R ). * * Parameters * * DH DOUBLE PRECISION, integration limit * DK DOUBLE PRECISION, integration limit * R DOUBLE PRECISION, correlation coefficient * DOUBLE PRECISION DH, DK, R, TWOPI INTEGER I, IS, LG, NG PARAMETER ( TWOPI = 6.283185307179586D0 ) DOUBLE PRECISION X(10,3), W(10,3), AS, A, B, C, D, RS, XS, BVN DOUBLE PRECISION PHID, SN, ASR, H, K, BS, HS, HK * Gauss Legendre Points and Weights, N = 6 DATA ( W(I,1), X(I,1), I = 1,3) / & 0.1713244923791705D+00,-0.9324695142031522D+00, & 0.3607615730481384D+00,-0.6612093864662647D+00, & 0.4679139345726904D+00,-0.2386191860831970D+00/ * Gauss Legendre Points and Weights, N = 12 DATA ( W(I,2), X(I,2), I = 1,6) / & 0.4717533638651177D-01,-0.9815606342467191D+00, & 0.1069393259953183D+00,-0.9041172563704750D+00, & 0.1600783285433464D+00,-0.7699026741943050D+00, & 0.2031674267230659D+00,-0.5873179542866171D+00, & 0.2334925365383547D+00,-0.3678314989981802D+00, & 0.2491470458134029D+00,-0.1252334085114692D+00/ * Gauss Legendre Points and Weights, N = 20 DATA ( W(I,3), X(I,3), I = 1, 10 ) / & 0.1761400713915212D-01,-0.9931285991850949D+00, & 0.4060142980038694D-01,-0.9639719272779138D+00, & 0.6267204833410906D-01,-0.9122344282513259D+00, & 0.8327674157670475D-01,-0.8391169718222188D+00, & 0.1019301198172404D+00,-0.7463319064601508D+00, & 0.1181945319615184D+00,-0.6360536807265150D+00, & 0.1316886384491766D+00,-0.5108670019508271D+00, & 0.1420961093183821D+00,-0.3737060887154196D+00, & 0.1491729864726037D+00,-0.2277858511416451D+00, & 0.1527533871307259D+00,-0.7652652113349733D-01/ SAVE X, W IF ( ABS(R) .LT. 0.3 ) THEN NG = 1 LG = 3 ELSE IF ( ABS(R) .LT. 0.75 ) THEN NG = 2 LG = 6 ELSE NG = 3 LG = 10 ENDIF H = DH K = DK HK = H*K BVN = 0 IF ( ABS(R) .LT. 0.925 ) THEN IF ( ABS(R) .GT. 0 ) THEN HS = ( H*H + K*K )/2 ASR = ASIN(R) DO I = 1, LG DO IS = -1, 1, 2 SN = SIN( ASR*( IS*X(I,NG) + 1 )/2 ) BVN = BVN + W(I,NG)*EXP( ( SN*HK-HS )/( 1-SN*SN ) ) END DO END DO BVN = BVN*ASR/( 2*TWOPI ) ENDIF BVN = BVN + PHID(-H)*PHID(-K) ELSE IF ( R .LT. 0 ) THEN K = -K HK = -HK ENDIF IF ( ABS(R) .LT. 1 ) THEN AS = ( 1 - R )*( 1 + R ) A = SQRT(AS) BS = ( H - K )**2 C = ( 4 - HK )/8 D = ( 12 - HK )/16 ASR = -( BS/AS + HK )/2 IF ( ASR .GT. -100 ) BVN = A*EXP(ASR) & *( 1 - C*( BS - AS )*( 1 - D*BS/5 )/3 + C*D*AS*AS/5 ) IF ( -HK .LT. 100 ) THEN B = SQRT(BS) BVN = BVN - EXP( -HK/2 )*SQRT(TWOPI)*PHID(-B/A)*B & *( 1 - C*BS*( 1 - D*BS/5 )/3 ) ENDIF A = A/2 DO I = 1, LG DO IS = -1, 1, 2 XS = ( A*( IS*X(I,NG) + 1 ) )**2 RS = SQRT( 1 - XS ) ASR = -( BS/XS + HK )/2 IF ( ASR .GT. -100 ) THEN BVN = BVN + A*W(I,NG)*EXP( ASR ) & *( EXP( -HK*( 1 - RS )/( 2*( 1 + RS ) ) )/RS & - ( 1 + C*XS*( 1 + D*XS ) ) ) END IF END DO END DO BVN = -BVN/TWOPI ENDIF IF ( R .GT. 0 ) THEN BVN = BVN + PHID( -MAX( H, K ) ) ELSE BVN = -BVN IF ( K .GT. H ) BVN = BVN + PHID(K) - PHID(H) ENDIF ENDIF BVND = BVN END mnormt/src/mnormt_init.c0000644000176200001440000000315414245154164015071 0ustar liggesusers#include #include #include #include // for NULL #include void F77_SUB(rndstart)(void) { GetRNGstate(); } void F77_SUB(rndend)(void) { PutRNGstate(); } double F77_SUB(unifrnd)(void) { return unif_rand(); } double F77_SUB(pnormr)(double *x, double *mu, double *sigma, int *lower_tail, int *log_p) { return pnorm(*x, *mu, *sigma, *lower_tail, *log_p); } double F77_SUB(qnormr)(double *p, double *mu, double *sigma, int *lower_tail, int *log_p) { return qnorm(*p, *mu, *sigma, *lower_tail, *log_p); } /* .Fortran calls */ extern void F77_NAME(sadmvn)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(sadmvt)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); extern void F77_NAME(smvbvt)(void *, void *, void *, void *, void *, void *); extern void F77_NAME(stvtl)(void *, void *, void *, void *, void *); extern void F77_NAME(rtmng)(void *, void *, void *, void *, void *, void *, void *, void *, void *); static const R_FortranMethodDef FortEntries[] = { {"sadmvn", (DL_FUNC) &F77_NAME(sadmvn), 11}, {"sadmvt", (DL_FUNC) &F77_NAME(sadmvt), 12}, {"smvbvt", (DL_FUNC) &F77_NAME(sadmvn), 6}, {"stvtl", (DL_FUNC) &F77_NAME(stvtl), 5}, {"rtmng", (DL_FUNC) &F77_NAME(rtmng), 9}, {NULL, NULL, 0} }; static const R_CMethodDef CEntries[] = { {NULL, NULL, 0} }; void R_init_heavy(DllInfo *dll) { R_registerRoutines(dll, CEntries, NULL, FortEntries, NULL); R_useDynamicSymbols(dll, FALSE); } mnormt/src/sadmvnt.f0000644000176200001440000017117713652027000014211 0ustar liggesusers* Selected portions of code dowloaded from: * http://www.math.wsu.edu/math/faculty/genz/software/mvn.f * http://www.math.wsu.edu/math/faculty/genz/software/mvt.f * with a few very minor modifications by Adelchi Azzalini (Univ. Padua, Italy) * required to match CRAN requirements (search for 'AA' to find them) * * Author: * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * except for some auxiliary functions whose authors are indicated * in the respective code below. *----------------------------------------------------------------------- SUBROUTINE SADMVN( N, LOWER, UPPER, INFIN, CORREL, MAXPTS, & ABSEPS, RELEPS, ERROR, VALUE, INFORM ) * * A subroutine for computing multivariate normal probabilities. * This subroutine uses an algorithm given in the paper * "Numerical Computation of Multivariate Normal Probabilities", in * J. of Computational and Graphical Stat., 1(1992), pp. 141-149, by * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * * Parameters * * N INTEGER, the number of variables. * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) < 0, Ith limits are (-infinity, infinity); * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, array of correlation coefficients; the correlation * coefficient in row I column J of the correlation matrix * should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I. * MAXPTS INTEGER, maximum number of function values allowed. This * parameter can be used to limit the time taken. A * sensible strategy is to start with MAXPTS = 1000*N, and then * increase MAXPTS if ERROR is too large. * ABSEPS REAL absolute error tolerance. * RELEPS REAL relative error tolerance. * ERROR REAL estimated absolute error, with 99% confidence level. * VALUE REAL estimated value for the integral * INFORM INTEGER, termination status parameter: * if INFORM = 0, normal completion with ERROR < EPS; * if INFORM = 1, completion with ERROR > EPS and MAXPTS * function vaules used; increase MAXPTS to * decrease ERROR; * if INFORM = 2, N > 20 or N < 1. * EXTERNAL MVNFNC INTEGER N, NL, M, INFIN(*), LENWRK, MAXPTS, INFORM, INFIS, & RULCLS, TOTCLS, NEWCLS, MAXCLS DOUBLE PRECISION & CORREL(*), LOWER(*), UPPER(*), ABSEPS, RELEPS, ERROR, VALUE, & OLDVAL, D, E, MVNNIT, MVNFNC PARAMETER ( NL = 20 ) PARAMETER ( LENWRK = 20*NL**2 ) DOUBLE PRECISION WORK(LENWRK) * * [AA (2014-06-25)] next DO loop initializes WORK array, * un-initialized in original code which caused complaints of some compilers * DO I = 1,LENWRK WORK(I) = 0.0D0 ENDDO IF ( N .GT. 20 .OR. N .LT. 1 ) THEN INFORM = 2 VALUE = 0 ERROR = 1 RETURN ENDIF INFORM = MVNNIT( N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E ) M = N - INFIS IF ( M .EQ. 0 ) THEN VALUE = 1 ERROR = 0 ELSE IF ( M .EQ. 1 ) THEN VALUE = E - D ERROR = 2E-16 ELSE * * Call the subregion adaptive integration subroutine * M = M - 1 RULCLS = 1 CALL ADAPT( M, RULCLS, 0, MVNFNC, ABSEPS, RELEPS, & LENWRK, WORK, ERROR, VALUE, INFORM ) MAXCLS = MIN( 10*RULCLS, MAXPTS ) TOTCLS = 0 CALL ADAPT(M, TOTCLS, MAXCLS, MVNFNC, ABSEPS, RELEPS, & LENWRK, WORK, ERROR, VALUE, INFORM) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN 10 OLDVAL = VALUE MAXCLS = MAX( 2*RULCLS, MIN( 3*MAXCLS/2, MAXPTS - TOTCLS ) ) NEWCLS = -1 CALL ADAPT(M, NEWCLS, MAXCLS, MVNFNC, ABSEPS, RELEPS, & LENWRK, WORK, ERROR, VALUE, INFORM) TOTCLS = TOTCLS + NEWCLS ERROR = ABS(VALUE-OLDVAL) + SQRT(RULCLS*ERROR**2/TOTCLS) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN IF ( MAXPTS - TOTCLS .GT. 2*RULCLS ) GO TO 10 ELSE INFORM = 0 END IF ENDIF ENDIF END *-------------------------------------------------------------------------- * SUBROUTINE ADAPT(NDIM, MINCLS, MAXCLS, FUNCTN, & ABSREQ, RELREQ, LENWRK, WORK, ABSEST, FINEST, INFORM) * * Adaptive Multidimensional Integration Subroutine * * Author: Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 USA * * This subroutine computes an approximation to the integral * * 1 1 1 * I I ... I FUNCTN(NDIM,X) dx(NDIM)...dx(2)dx(1) * 0 0 0 * *************** Parameters for ADAPT ******************************** * ****** Input Parameters * * NDIM Integer number of integration variables. * MINCLS Integer minimum number of FUNCTN calls to be allowed; MINCLS * must not exceed MAXCLS. If MINCLS < 0, then ADAPT assumes * that a previous call of ADAPT has been made with the same * integrand and continues that calculation. * MAXCLS Integer maximum number of FUNCTN calls to be used; MAXCLS * must be >= RULCLS, the number of function calls required for * one application of the basic integration rule. * IF ( NDIM .EQ. 1 ) THEN * RULCLS = 11 * ELSE IF ( NDIM .LT. 15 ) THEN * RULCLS = 2**NDIM + 2*NDIM*(NDIM+3) + 1 * ELSE * RULCLS = 1 + NDIM*(24-NDIM*(6-NDIM*4))/3 * ENDIF * FUNCTN Externally declared real user defined integrand. Its * parameters must be (NDIM, Z), where Z is a real array of * length NDIM. * ABSREQ Real required absolute accuracy. * RELREQ Real required relative accuracy. * LENWRK Integer length of real array WORK (working storage); ADAPT * needs LENWRK >= 16*NDIM + 27. For maximum efficiency LENWRK * should be about 2*NDIM*MAXCLS/RULCLS if MAXCLS FUNCTN * calls are needed. If LENWRK is significantly less than this, * ADAPT may be less efficient. * ****** Output Parameters * * MINCLS Actual number of FUNCTN calls used by ADAPT. * WORK Real array (length LENWRK) of working storage. This contains * information that is needed for additional calls of ADAPT * using the same integrand (input MINCLS < 0). * ABSEST Real estimated absolute accuracy. * FINEST Real estimated value of integral. * INFORM INFORM = 0 for normal exit, when ABSEST <= ABSREQ or * ABSEST <= |FINEST|*RELREQ with MINCLS <= MAXCLS. * INFORM = 1 if MAXCLS was too small for ADAPT to obtain the * result FINEST to within the requested accuracy. * INFORM = 2 if MINCLS > MAXCLS, LENWRK < 16*NDIM + 27 or * RULCLS > MAXCLS. * ************************************************************************ * * Begin driver routine. This routine partitions the working storage * array and then calls the main subroutine ADBASE. * EXTERNAL FUNCTN INTEGER NDIM, MINCLS, MAXCLS, LENWRK, INFORM DOUBLE PRECISION & FUNCTN, ABSREQ, RELREQ, WORK(LENWRK), ABSEST, FINEST INTEGER SBRGNS, MXRGNS, RULCLS, LENRUL, & INERRS, INVALS, INPTRS, INLWRS, INUPRS, INMSHS, INPNTS, INWGTS, & INLOWR, INUPPR, INWDTH, INMESH, INWORK IF ( NDIM .EQ. 1 ) THEN LENRUL = 5 RULCLS = 9 ELSE IF ( NDIM .LT. 12 ) THEN LENRUL = 6 RULCLS = 2**NDIM + 2*NDIM*(NDIM+2) + 1 ELSE LENRUL = 6 RULCLS = 1 + 2*NDIM*(1+2*NDIM) ENDIF IF ( LENWRK .GE. LENRUL*(NDIM+4) + 10*NDIM + 3 .AND. & RULCLS. LE. MAXCLS .AND. MINCLS .LE. MAXCLS ) THEN MXRGNS = ( LENWRK - LENRUL*(NDIM+4) - 7*NDIM )/( 3*NDIM + 3 ) INERRS = 1 INVALS = INERRS + MXRGNS INPTRS = INVALS + MXRGNS INLWRS = INPTRS + MXRGNS INUPRS = INLWRS + MXRGNS*NDIM INMSHS = INUPRS + MXRGNS*NDIM INWGTS = INMSHS + MXRGNS*NDIM INPNTS = INWGTS + LENRUL*4 INLOWR = INPNTS + LENRUL*NDIM INUPPR = INLOWR + NDIM INWDTH = INUPPR + NDIM INMESH = INWDTH + NDIM INWORK = INMESH + NDIM IF ( MINCLS .LT. 0 ) SBRGNS = WORK(LENWRK) CALL ADBASE(NDIM, MINCLS, MAXCLS, FUNCTN, ABSREQ, RELREQ, & ABSEST, FINEST, SBRGNS, MXRGNS, RULCLS, LENRUL, & WORK(INERRS), WORK(INVALS), WORK(INPTRS), WORK(INLWRS), & WORK(INUPRS), WORK(INMSHS), WORK(INWGTS), WORK(INPNTS), & WORK(INLOWR), WORK(INUPPR), WORK(INWDTH), WORK(INMESH), & WORK(INWORK), INFORM) WORK(LENWRK) = SBRGNS ELSE INFORM = 2 MINCLS = RULCLS ENDIF END * SUBROUTINE ADBASE(NDIM, MINCLS, MAXCLS, FUNCTN, ABSREQ, RELREQ, & ABSEST, FINEST, SBRGNS, MXRGNS, RULCLS, LENRUL, & ERRORS, VALUES, PONTRS, LOWERS, & UPPERS, MESHES, WEGHTS, POINTS, & LOWER, UPPER, WIDTH, MESH, WORK, INFORM) * * Main adaptive integration subroutine * EXTERNAL FUNCTN INTEGER I, J, NDIM, MINCLS, MAXCLS, SBRGNS, MXRGNS, & RULCLS, LENRUL, INFORM, NWRGNS DOUBLE PRECISION FUNCTN, ABSREQ, RELREQ, ABSEST, FINEST, & ERRORS(*), VALUES(*), PONTRS(*), & LOWERS(NDIM,*), UPPERS(NDIM,*), & MESHES(NDIM,*),WEGHTS(*), POINTS(*), & LOWER(*), UPPER(*), WIDTH(*), MESH(*), WORK(*) INTEGER DIVAXN, TOP, RGNCLS, FUNCLS, DIFCLS * * Initialization of subroutine * INFORM = 2 FUNCLS = 0 DIVAXN = 0 CALL BSINIT(NDIM, WEGHTS, LENRUL, POINTS) IF ( MINCLS .GE. 0) THEN * * When MINCLS >= 0 determine initial subdivision of the * integration region and apply basic rule to each subregion. * SBRGNS = 0 DO I = 1,NDIM LOWER(I) = 0 MESH(I) = 1 WIDTH(I) = 1/(2*MESH(I)) UPPER(I) = 1 END DO RGNCLS = RULCLS NWRGNS = 1 10 CALL DIFFER(NDIM, LOWER, UPPER, WIDTH, WORK, WORK(NDIM+1), & FUNCTN, DIVAXN, DIFCLS) FUNCLS = FUNCLS + DIFCLS IF ( FUNCLS + RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN) & .LE. MINCLS ) THEN RGNCLS = RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN) NWRGNS = NWRGNS*(MESH(DIVAXN)+1)/MESH(DIVAXN) MESH(DIVAXN) = MESH(DIVAXN) + 1 WIDTH(DIVAXN) = 1/( 2*MESH(DIVAXN) ) GO TO 10 ENDIF IF ( NWRGNS .LE. MXRGNS ) THEN DO I = 1,NDIM UPPER(I) = LOWER(I) + 2*WIDTH(I) MESH(I) = 1 END DO ENDIF * * Apply basic rule to subregions and store results in heap. * 20 SBRGNS = SBRGNS + 1 CALL BASRUL(NDIM, LOWER, UPPER, WIDTH, FUNCTN, & WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1), & ERRORS(SBRGNS),VALUES(SBRGNS)) CALL TRESTR(SBRGNS, SBRGNS, PONTRS, ERRORS) DO I = 1,NDIM LOWERS(I,SBRGNS) = LOWER(I) UPPERS(I,SBRGNS) = UPPER(I) MESHES(I,SBRGNS) = MESH(I) END DO DO I = 1,NDIM LOWER(I) = UPPER(I) UPPER(I) = LOWER(I) + 2*WIDTH(I) IF ( LOWER(I)+WIDTH(I) .LT. 1 ) GO TO 20 LOWER(I) = 0 UPPER(I) = LOWER(I) + 2*WIDTH(I) END DO FUNCLS = FUNCLS + SBRGNS*RULCLS ENDIF * * Check for termination * 30 FINEST = 0 ABSEST = 0 DO I = 1, SBRGNS FINEST = FINEST + VALUES(I) ABSEST = ABSEST + ERRORS(I) END DO IF ( ABSEST .GT. MAX( ABSREQ, RELREQ*ABS(FINEST) ) & .OR. FUNCLS .LT. MINCLS ) THEN * * Prepare to apply basic rule in (parts of) subregion with * largest error. * TOP = PONTRS(1) RGNCLS = RULCLS DO I = 1,NDIM LOWER(I) = LOWERS(I,TOP) UPPER(I) = UPPERS(I,TOP) MESH(I) = MESHES(I,TOP) WIDTH(I) = (UPPER(I)-LOWER(I))/(2*MESH(I)) RGNCLS = RGNCLS*MESH(I) END DO CALL DIFFER(NDIM, LOWER, UPPER, WIDTH, WORK, WORK(NDIM+1), & FUNCTN, DIVAXN, DIFCLS) FUNCLS = FUNCLS + DIFCLS RGNCLS = RGNCLS*(MESH(DIVAXN)+1)/MESH(DIVAXN) IF ( FUNCLS + RGNCLS .LE. MAXCLS ) THEN IF ( SBRGNS + 1 .LE. MXRGNS ) THEN * * Prepare to subdivide into two pieces. * NWRGNS = 1 WIDTH(DIVAXN) = WIDTH(DIVAXN)/2 ELSE NWRGNS = 0 WIDTH(DIVAXN) = WIDTH(DIVAXN) & *MESH(DIVAXN)/( MESH(DIVAXN) + 1 ) MESHES(DIVAXN,TOP) = MESH(DIVAXN) + 1 ENDIF IF ( NWRGNS .GT. 0 ) THEN * * Only allow local subdivision when space is available. * DO J = SBRGNS+1,SBRGNS+NWRGNS DO I = 1,NDIM LOWERS(I,J) = LOWER(I) UPPERS(I,J) = UPPER(I) MESHES(I,J) = MESH(I) END DO END DO UPPERS(DIVAXN,TOP) = LOWER(DIVAXN) + 2*WIDTH(DIVAXN) LOWERS(DIVAXN,SBRGNS+1) = UPPERS(DIVAXN,TOP) ENDIF FUNCLS = FUNCLS + RGNCLS CALL BASRUL(NDIM, LOWERS(1,TOP), UPPERS(1,TOP), WIDTH, & FUNCTN, WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1), & ERRORS(TOP), VALUES(TOP)) CALL TRESTR(TOP, SBRGNS, PONTRS, ERRORS) DO I = SBRGNS+1, SBRGNS+NWRGNS * * Apply basic rule and store results in heap. * CALL BASRUL(NDIM, LOWERS(1,I), UPPERS(1,I), WIDTH, & FUNCTN, WEGHTS, LENRUL, POINTS, WORK, WORK(NDIM+1), & ERRORS(I), VALUES(I)) CALL TRESTR(I, I, PONTRS, ERRORS) END DO SBRGNS = SBRGNS + NWRGNS GO TO 30 ELSE INFORM = 1 ENDIF ELSE INFORM = 0 ENDIF MINCLS = FUNCLS END SUBROUTINE BSINIT(NDIM, W, LENRUL, G) * * For initializing basic rule weights and symmetric sum parameters. * INTEGER NDIM, LENRUL, RULPTS(6), I, J, NUMNUL, SDIM PARAMETER ( NUMNUL = 4, SDIM = 12 ) DOUBLE PRECISION W(LENRUL,4), G(NDIM,LENRUL) DOUBLE PRECISION LAM1, LAM2, LAM3, LAMP, RULCON * * The following code determines rule parameters and weights for a * degree 7 rule (W(1,1),...,W(5,1)), two degree 5 comparison rules * (W(1,2),...,W(5,2) and W(1,3),...,W(5,3)) and a degree 3 * comparison rule (W(1,4),...W(5,4)). * * If NDIM = 1, then LENRUL = 5 and total points = 9. * If NDIM < SDIM, then LENRUL = 6 and * total points = 1+2*NDIM*(NDIM+2)+2**NDIM. * If NDIM > = SDIM, then LENRUL = 6 and * total points = 1+2*NDIM*(1+2*NDIM). * DO I = 1,LENRUL DO J = 1,NDIM G(J,I) = 0 END DO DO J = 1,NUMNUL W(I,J) = 0 END DO END DO RULPTS(5) = 2*NDIM*(NDIM-1) RULPTS(4) = 2*NDIM RULPTS(3) = 2*NDIM RULPTS(2) = 2*NDIM RULPTS(1) = 1 LAMP = 0.85 LAM3 = 0.4707 LAM2 = 4/(15 - 5/LAM3) W(5,1) = ( 3 - 5*LAM3 )/( 180*(LAM2-LAM3)*LAM2**2 ) IF ( NDIM .LT. SDIM ) THEN LAM1 = 8*LAM3*(31*LAM3-15)/( (3*LAM3-1)*(5*LAM3-3)*35 ) W(LENRUL,1) = 1/(3*LAM3)**3/2**NDIM ELSE LAM1 = ( LAM3*(15 - 21*LAM2) + 35*(NDIM-1)*(LAM2-LAM3)/9 ) & / ( LAM3*(21 - 35*LAM2) + 35*(NDIM-1)*(LAM2/LAM3-1)/9 ) W(6,1) = 1/(4*(3*LAM3)**3) ENDIF W(3,1) = ( 15 - 21*(LAM3+LAM1) + 35*LAM3*LAM1 ) & /( 210*LAM2*(LAM2-LAM3)*(LAM2-LAM1) ) - 2*(NDIM-1)*W(5,1) W(2,1) = ( 15 - 21*(LAM3+LAM2) + 35*LAM3*LAM2 ) & /( 210*LAM1*(LAM1-LAM3)*(LAM1-LAM2) ) IF ( NDIM .LT. SDIM ) THEN RULPTS(LENRUL) = 2**NDIM LAM3 = SQRT(LAM3) DO I = 1,NDIM G(I,LENRUL) = LAM3 END DO ELSE W(6,1) = 1/(4*(3*LAM3)**3) RULPTS(6) = 2*NDIM*(NDIM-1) LAM3 = SQRT(LAM3) DO I = 1,2 G(I,6) = LAM3 END DO ENDIF IF ( NDIM .GT. 1 ) THEN W(5,2) = 1/(6*LAM2)**2 W(5,3) = 1/(6*LAM2)**2 ENDIF W(3,2) = ( 3 - 5*LAM1 )/( 30*LAM2*(LAM2-LAM1) ) & - 2*(NDIM-1)*W(5,2) W(2,2) = ( 3 - 5*LAM2 )/( 30*LAM1*(LAM1-LAM2) ) W(4,3) = ( 3 - 5*LAM2 )/( 30*LAMP*(LAMP-LAM2) ) W(3,3) = ( 3 - 5*LAMP )/( 30*LAM2*(LAM2-LAMP) ) & - 2*(NDIM-1)*W(5,3) W(2,4) = 1/(6*LAM1) LAMP = SQRT(LAMP) LAM2 = SQRT(LAM2) LAM1 = SQRT(LAM1) G(1,2) = LAM1 G(1,3) = LAM2 G(1,4) = LAMP IF ( NDIM .GT. 1 ) THEN G(1,5) = LAM2 G(2,5) = LAM2 ENDIF DO J = 1, NUMNUL W(1,J) = 1 DO I = 2,LENRUL W(1,J) = W(1,J) - RULPTS(I)*W(I,J) END DO END DO RULCON = 2 CALL RULNRM( LENRUL, NUMNUL, RULPTS, W, RULCON ) END * SUBROUTINE RULNRM( LENRUL, NUMNUL, RULPTS, W, RULCON ) INTEGER LENRUL, NUMNUL, I, J, K, RULPTS(*) DOUBLE PRECISION ALPHA, NORMCF, NORMNL, W(LENRUL, *), RULCON * * Compute orthonormalized null rules. * NORMCF = 0 DO I = 1,LENRUL NORMCF = NORMCF + RULPTS(I)*W(I,1)*W(I,1) END DO DO K = 2,NUMNUL DO I = 1,LENRUL W(I,K) = W(I,K) - W(I,1) END DO DO J = 2,K-1 ALPHA = 0 DO I = 1,LENRUL ALPHA = ALPHA + RULPTS(I)*W(I,J)*W(I,K) END DO ALPHA = -ALPHA/NORMCF DO I = 1,LENRUL W(I,K) = W(I,K) + ALPHA*W(I,J) END DO END DO NORMNL = 0 DO I = 1,LENRUL NORMNL = NORMNL + RULPTS(I)*W(I,K)*W(I,K) END DO ALPHA = SQRT(NORMCF/NORMNL) DO I = 1,LENRUL W(I,K) = ALPHA*W(I,K) END DO END DO DO J = 2, NUMNUL DO I = 1,LENRUL W(I,J) = W(I,J)/RULCON END DO END DO END *-------------------------------------------------------------------------- DOUBLE PRECISION FUNCTION MVNFNC(N, W) * * Integrand subroutine * INTEGER N, INFIN(*), INFIS DOUBLE PRECISION W(*), LOWER(*), UPPER(*), CORREL(*), ONE INTEGER NL, IJ, I, J PARAMETER ( NL = 100, ONE = 1 ) DOUBLE PRECISION COV((NL*(NL+1))/2), A(NL), B(NL), Y(NL), BVN INTEGER INFI(NL) DOUBLE PRECISION PROD, D1, E1, DI, EI, SUM, PHINV, D, E, MVNNIT SAVE D1, E1, A, B, INFI, COV DI = D1 EI = E1 PROD = E1 - D1 IJ = 1 DO I = 1,N Y(I) = PHINV( DI + W(I)*(EI-DI) ) SUM = 0 DO J = 1,I IJ = IJ + 1 SUM = SUM + COV(IJ)*Y(J) END DO IJ = IJ + 1 IF ( COV(IJ) .GT. 0 ) THEN CALL LIMITS( A(I+1)-SUM, B(I+1)-SUM, INFI(I+1), DI, EI ) ELSE DI = ( 1 + SIGN( ONE, A(I+1)-SUM ) )/2 EI = ( 1 + SIGN( ONE, B(I+1)-SUM ) )/2 ENDIF PROD = PROD*(EI-DI) END DO MVNFNC = PROD RETURN * * Entry point for intialization. * ENTRY MVNNIT(N, CORREL, LOWER, UPPER, INFIN, INFIS, D, E) MVNNIT = 0 * * Initialization and computation of covariance Cholesky factor. * CALL NCVSRT(N, LOWER,UPPER,CORREL,INFIN,Y, INFIS,A,B,INFI,COV,D,E) D1 = D E1 = E IF ( N - INFIS .EQ. 2 ) THEN D = SQRT( 1 + COV(2)**2 ) A(2) = A(2)/D B(2) = B(2)/D E = BVN( A, B, INFI, COV(2)/D ) D = 0 INFIS = INFIS + 1 END IF END SUBROUTINE LIMITS( A, B, INFIN, LOWER, UPPER ) DOUBLE PRECISION A, B, LOWER, UPPER, PHI INTEGER INFIN LOWER = 0 UPPER = 1 IF ( INFIN .GE. 0 ) THEN IF ( INFIN .NE. 0 ) LOWER = PHI(A) IF ( INFIN .NE. 1 ) UPPER = PHI(B) ENDIF END *-------------------------------------------------------------------------- DOUBLE PRECISION FUNCTION PHI(Z) * * Normal distribution probabilities accurate to 1.e-15. * Z = no. of standard deviations from the mean. * * Based upon algorithm 5666 for the error function, from: * Hart, J.F. et al, 'Computer Approximations', Wiley 1968 * * Programmer: Alan Miller * * Latest revision - 30 March 1986 * DOUBLE PRECISION P0, P1, P2, P3, P4, P5, P6, & Q0, Q1, Q2, Q3, Q4, Q5, Q6, Q7, & Z, P, EXPNTL, CUTOFF, ROOTPI, ZABS PARAMETER( & P0 = 220.20 68679 12376 1D0, & P1 = 221.21 35961 69931 1D0, & P2 = 112.07 92914 97870 9D0, & P3 = 33.912 86607 83830 0D0, & P4 = 6.3739 62203 53165 0D0, & P5 = .70038 30644 43688 1D0, & P6 = .035262 49659 98910 9D0) PARAMETER( & Q0 = 440.41 37358 24752 2D0, & Q1 = 793.82 65125 19948 4D0, & Q2 = 637.33 36333 78831 1D0, & Q3 = 296.56 42487 79673 7D0, & Q4 = 86.780 73220 29460 8D0, & Q5 = 16.064 17757 92069 5D0, & Q6 = 1.7556 67163 18264 2D0, & Q7 = .088388 34764 83184 4D0) PARAMETER(ROOTPI = 2.5066 28274 63100 1D0) PARAMETER(CUTOFF = 7.0710 67811 86547 5D0) * ZABS = ABS(Z) * * |Z| > 37 * IF (ZABS .GT. 37) THEN P = 0 ELSE * * |Z| <= 37 * EXPNTL = EXP(-ZABS**2/2) * * |Z| < CUTOFF = 10/SQRT(2) * IF (ZABS .LT. CUTOFF) THEN P = EXPNTL*((((((P6*ZABS + P5)*ZABS + P4)*ZABS + P3)*ZABS & + P2)*ZABS + P1)*ZABS + P0)/(((((((Q7*ZABS + Q6)*ZABS & + Q5)*ZABS + Q4)*ZABS + Q3)*ZABS + Q2)*ZABS + Q1)*ZABS & + Q0) * * |Z| >= CUTOFF. * ELSE P = EXPNTL/(ZABS + 1/(ZABS + 2/(ZABS + 3/(ZABS + 4/ & (ZABS + 0.65D0)))))/ROOTPI END IF END IF IF (Z .GT. 0) P = 1 - P PHI = P END * DOUBLE PRECISION FUNCTION PHINV(P) * * ALGORITHM AS241 APPL. STATIST. (1988) VOL. 37, NO. 3 * * Produces the normal deviate Z corresponding to a given lower * tail area of P. * * The hash sums below are the sums of the mantissas of the * coefficients. They are included for use in checking * transcription. * DOUBLE PRECISION SPLIT1, SPLIT2, CONST1, CONST2, & A0, A1, A2, A3, A4, A5, A6, A7, B1, B2, B3, B4, B5, B6, B7, & C0, C1, C2, C3, C4, C5, C6, C7, D1, D2, D3, D4, D5, D6, D7, & E0, E1, E2, E3, E4, E5, E6, E7, F1, F2, F3, F4, F5, F6, F7, & P, Q, R PARAMETER (SPLIT1 = 0.425, SPLIT2 = 5, & CONST1 = 0.180625D0, CONST2 = 1.6D0) * * Coefficients for P close to 0.5 * PARAMETER ( & A0 = 3.38713 28727 96366 6080D0, & A1 = 1.33141 66789 17843 7745D+2, & A2 = 1.97159 09503 06551 4427D+3, & A3 = 1.37316 93765 50946 1125D+4, & A4 = 4.59219 53931 54987 1457D+4, & A5 = 6.72657 70927 00870 0853D+4, & A6 = 3.34305 75583 58812 8105D+4, & A7 = 2.50908 09287 30122 6727D+3, & B1 = 4.23133 30701 60091 1252D+1, & B2 = 6.87187 00749 20579 0830D+2, & B3 = 5.39419 60214 24751 1077D+3, & B4 = 2.12137 94301 58659 5867D+4, & B5 = 3.93078 95800 09271 0610D+4, & B6 = 2.87290 85735 72194 2674D+4, & B7 = 5.22649 52788 52854 5610D+3) * HASH SUM AB 55.88319 28806 14901 4439 * * Coefficients for P not close to 0, 0.5 or 1. * PARAMETER ( & C0 = 1.42343 71107 49683 57734D0, & C1 = 4.63033 78461 56545 29590D0, & C2 = 5.76949 72214 60691 40550D0, & C3 = 3.64784 83247 63204 60504D0, & C4 = 1.27045 82524 52368 38258D0, & C5 = 2.41780 72517 74506 11770D-1, & C6 = 2.27238 44989 26918 45833D-2, & C7 = 7.74545 01427 83414 07640D-4, & D1 = 2.05319 16266 37758 82187D0, & D2 = 1.67638 48301 83803 84940D0, & D3 = 6.89767 33498 51000 04550D-1, & D4 = 1.48103 97642 74800 74590D-1, & D5 = 1.51986 66563 61645 71966D-2, & D6 = 5.47593 80849 95344 94600D-4, & D7 = 1.05075 00716 44416 84324D-9) * HASH SUM CD 49.33206 50330 16102 89036 * * Coefficients for P near 0 or 1. * PARAMETER ( & E0 = 6.65790 46435 01103 77720D0, & E1 = 5.46378 49111 64114 36990D0, & E2 = 1.78482 65399 17291 33580D0, & E3 = 2.96560 57182 85048 91230D-1, & E4 = 2.65321 89526 57612 30930D-2, & E5 = 1.24266 09473 88078 43860D-3, & E6 = 2.71155 55687 43487 57815D-5, & E7 = 2.01033 43992 92288 13265D-7, & F1 = 5.99832 20655 58879 37690D-1, & F2 = 1.36929 88092 27358 05310D-1, & F3 = 1.48753 61290 85061 48525D-2, & F4 = 7.86869 13114 56132 59100D-4, & F5 = 1.84631 83175 10054 68180D-5, & F6 = 1.42151 17583 16445 88870D-7, & F7 = 2.04426 31033 89939 78564D-15) * HASH SUM EF 47.52583 31754 92896 71629 * Q = ( 2*P - 1 )/2 IF ( ABS(Q) .LE. SPLIT1 ) THEN R = CONST1 - Q*Q PHINV = Q*(((((((A7*R + A6)*R + A5)*R + A4)*R + A3) & *R + A2)*R + A1)*R + A0) / & (((((((B7*R + B6)*R + B5)*R + B4)*R + B3) & *R + B2)*R + B1)*R + 1) ELSE R = MIN( P, 1 - P ) IF (R .GT. 0) THEN R = SQRT( -LOG(R) ) IF ( R .LE. SPLIT2 ) THEN R = R - CONST2 PHINV = (((((((C7*R + C6)*R + C5)*R + C4)*R + C3) & *R + C2)*R + C1)*R + C0) / & (((((((D7*R + D6)*R + D5)*R + D4)*R + D3) & *R + D2)*R + D1)*R + 1) ELSE R = R - SPLIT2 PHINV = (((((((E7*R + E6)*R + E5)*R + E4)*R + E3) & *R + E2)*R + E1)*R + E0) / & (((((((F7*R + F6)*R + F5)*R + F4)*R + F3) & *R + F2)*R + F1)*R + 1) END IF ELSE PHINV = 9 END IF IF ( Q .LT. 0 ) PHINV = - PHINV END IF END DOUBLE PRECISION FUNCTION BVN ( LOWER, UPPER, INFIN, CORREL ) * * A function for computing bivariate normal probabilities. * * Parameters * * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, correlation coefficient. * DOUBLE PRECISION LOWER(*), UPPER(*), CORREL, BVNU INTEGER INFIN(*) IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 2 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) + - BVNU ( UPPER(1), LOWER(2), CORREL ) + - BVNU ( LOWER(1), UPPER(2), CORREL ) + + BVNU ( UPPER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 1 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) + - BVNU ( UPPER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 2 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) + - BVNU ( LOWER(1), UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 2 .AND. INFIN(2) .EQ. 0 ) THEN BVN = BVNU ( -UPPER(1), -UPPER(2), CORREL ) + - BVNU ( -LOWER(1), -UPPER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 2 ) THEN BVN = BVNU ( -UPPER(1), -UPPER(2), CORREL ) + - BVNU ( -UPPER(1), -LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 0 ) THEN BVN = BVNU ( LOWER(1), -UPPER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 1 ) THEN BVN = BVNU ( -UPPER(1), LOWER(2), -CORREL ) ELSE IF ( INFIN(1) .EQ. 1 .AND. INFIN(2) .EQ. 1 ) THEN BVN = BVNU ( LOWER(1), LOWER(2), CORREL ) ELSE IF ( INFIN(1) .EQ. 0 .AND. INFIN(2) .EQ. 0 ) THEN BVN = BVNU ( -UPPER(1), -UPPER(2), CORREL ) END IF END DOUBLE PRECISION FUNCTION BVNU( SH, SK, R ) * * A function for computing bivariate normal probabilities. * * Yihong Ge * Department of Computer Science and Electrical Engineering * Washington State University * Pullman, WA 99164-2752 * Email : yge@eecs.wsu.edu * and * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : alangenz@wsu.edu * * BVN - calculate the probability that X is larger than SH and Y is * larger than SK. * * Parameters * * SH REAL, integration limit * SK REAL, integration limit * R REAL, correlation coefficient * LG INTEGER, number of Gauss Rule Points and Weights * DOUBLE PRECISION BVN, SH, SK, R, ZERO, TWOPI INTEGER I, LG, NG PARAMETER ( ZERO = 0, TWOPI = 6.2831 85307 179586 ) DOUBLE PRECISION X(10,3), W(10,3), AS, A, B, C, D, RS, XS DOUBLE PRECISION PHI, SN, ASR, H, K, BS, HS, HK * Gauss Legendre Points and Weights, N = 6 DATA ( W(I,1), X(I,1), I = 1,3) / & 0.1713244923791705D+00,-0.9324695142031522D+00, & 0.3607615730481384D+00,-0.6612093864662647D+00, & 0.4679139345726904D+00,-0.2386191860831970D+00/ * Gauss Legendre Points and Weights, N = 12 DATA ( W(I,2), X(I,2), I = 1,6) / & 0.4717533638651177D-01,-0.9815606342467191D+00, & 0.1069393259953183D+00,-0.9041172563704750D+00, & 0.1600783285433464D+00,-0.7699026741943050D+00, & 0.2031674267230659D+00,-0.5873179542866171D+00, & 0.2334925365383547D+00,-0.3678314989981802D+00, & 0.2491470458134029D+00,-0.1252334085114692D+00/ * Gauss Legendre Points and Weights, N = 20 DATA ( W(I,3), X(I,3), I = 1,10) / & 0.1761400713915212D-01,-0.9931285991850949D+00, & 0.4060142980038694D-01,-0.9639719272779138D+00, & 0.6267204833410906D-01,-0.9122344282513259D+00, & 0.8327674157670475D-01,-0.8391169718222188D+00, & 0.1019301198172404D+00,-0.7463319064601508D+00, & 0.1181945319615184D+00,-0.6360536807265150D+00, & 0.1316886384491766D+00,-0.5108670019508271D+00, & 0.1420961093183821D+00,-0.3737060887154196D+00, & 0.1491729864726037D+00,-0.2277858511416451D+00, & 0.1527533871307259D+00,-0.7652652113349733D-01/ SAVE X, W IF ( ABS(R) .LT. 0.3 ) THEN NG = 1 LG = 3 ELSE IF ( ABS(R) .LT. 0.75 ) THEN NG = 2 LG = 6 ELSE NG = 3 LG = 10 ENDIF H = SH K = SK HK = H*K BVN = 0 IF ( ABS(R) .LT. 0.925 ) THEN HS = ( H*H + K*K )/2 ASR = ASIN(R) DO 10 I = 1, LG SN = SIN(ASR*( X(I,NG)+1 )/2) BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) ) SN = SIN(ASR*(-X(I,NG)+1 )/2) BVN = BVN + W(I,NG)*EXP( ( SN*HK - HS )/( 1 - SN*SN ) ) 10 CONTINUE BVN = BVN*ASR/(2*TWOPI) + PHI(-H)*PHI(-K) ELSE IF ( R .LT. 0 ) THEN K = -K HK = -HK ENDIF IF ( ABS(R) .LT. 1 ) THEN AS = ( 1 - R )*( 1 + R ) A = SQRT(AS) BS = ( H - K )**2 C = ( 4 - HK )/8 D = ( 12 - HK )/16 BVN = A*EXP( -(BS/AS + HK)/2 ) + *( 1 - C*(BS - AS)*(1 - D*BS/5)/3 + C*D*AS*AS/5 ) IF ( HK .GT. -160 ) THEN B = SQRT(BS) BVN = BVN - EXP(-HK/2)*SQRT(TWOPI)*PHI(-B/A)*B + *( 1 - C*BS*( 1 - D*BS/5 )/3 ) ENDIF A = A/2 DO 20 I = 1, LG XS = ( A*(X(I,NG)+1) )**2 RS = SQRT( 1 - XS ) BVN = BVN + A*W(I,NG)* + ( EXP( -BS/(2*XS) - HK/(1+RS) )/RS + - EXP( -(BS/XS+HK)/2 )*( 1 + C*XS*( 1 + D*XS ) ) ) XS = AS*(-X(I,NG)+1)**2/4 RS = SQRT( 1 - XS ) BVN = BVN + A*W(I,NG)*EXP( -(BS/XS + HK)/2 ) + *( EXP( -HK*(1-RS)/(2*(1+RS)) )/RS + - ( 1 + C*XS*( 1 + D*XS ) ) ) 20 CONTINUE BVN = -BVN/TWOPI ENDIF IF ( R .GT. 0 ) BVN = BVN + PHI( -MAX( H, K ) ) IF ( R .LT. 0 ) BVN = -BVN + MAX( ZERO, PHI(-H) - PHI(-K) ) ENDIF BVNU = BVN END * *-------------------------------------------------------------------------- SUBROUTINE NCVSRT( N, LOWER, UPPER, CORREL, INFIN, Y, INFIS, & A, B, INFI, COV, D, E ) * * Subroutine to sort integration limits. * INTEGER N, INFI(*), INFIN(*), INFIS, iflag DOUBLE PRECISION & A(*), B(*), COV(*), LOWER(*), UPPER(*), CORREL(*), Y(*), D, E INTEGER I, J, K, IJ, II, JMIN DOUBLE PRECISION SUMSQ, ZERO PARAMETER ( ZERO = 0 ) DOUBLE PRECISION AJ, BJ, SUM, SQTWPI DOUBLE PRECISION CVDIAG, AMIN, BMIN, DMIN, EMIN, YL, YU PARAMETER ( SQTWPI = 2.50662 82746 31000 50240 ) IJ = 0 II = 0 INFIS = 0 DO I = 1,N INFI(I) = INFIN(I) IF ( INFI(I) .LT. 0 ) THEN INFIS = INFIS + 1 ELSE A(I) = 0 B(I) = 0 IF ( INFI(I) .NE. 0 ) A(I) = LOWER(I) IF ( INFI(I) .NE. 1 ) B(I) = UPPER(I) ENDIF DO J = 1,I-1 IJ = IJ + 1 II = II + 1 COV(IJ) = CORREL(II) END DO IJ = IJ + 1 COV(IJ) = 1 END DO * * First move any doubly infinite limits to innermost positions * [AA, recoded to avoid GOTO jump outside IF block] * IF ( INFIS .LT. N ) THEN DO I = N,N-INFIS+1,-1 iflag = 0 IF ( INFI(I) .GE. 0 ) THEN DO J = 1,I-1 IF ( INFI(J) .LT. 0 .and. iflag .eq. 0) THEN CALL RCSWAP(J, I, A, B, INFI, N, COV) iflag = 1 ENDIF END DO ENDIF 10 END DO * * Sort remaining limits and determine Cholesky decomposition * II = 0 DO I = 1,N-INFIS * * Determine the integration limits for variable with minimum * expected probability and interchange that variable with Ith. * EMIN = 1 DMIN = 0 JMIN = I CVDIAG = 0 IJ = II DO J = I, N-INFIS SUM = 0 SUMSQ = 0 DO K = 1, I-1 SUM = SUM + COV(IJ+K)*Y(K) SUMSQ = SUMSQ + COV(IJ+K)**2 END DO IJ = IJ + J SUMSQ = SQRT( MAX( COV(IJ)-SUMSQ, ZERO ) ) IF ( SUMSQ .GT. 0 ) THEN IF ( INFI(J) .NE. 0 ) AJ = ( A(J) - SUM )/SUMSQ IF ( INFI(J) .NE. 1 ) BJ = ( B(J) - SUM )/SUMSQ CALL LIMITS( AJ, BJ, INFI(J), D, E ) IF ( EMIN - DMIN .GE. E - D ) THEN JMIN = J IF ( INFI(J) .NE. 0 ) AMIN = AJ IF ( INFI(J) .NE. 1 ) BMIN = BJ DMIN = D EMIN = E CVDIAG = SUMSQ ENDIF ENDIF END DO IF ( JMIN .NE. I) CALL RCSWAP(I, JMIN, A, B, INFI, N, COV) * * Compute Ith column of Cholesky factor. * IJ = II + I COV(IJ) = CVDIAG DO J = I+1, N-INFIS IF ( CVDIAG .GT. 0 ) THEN SUM = COV(IJ+I) DO K = 1, I-1 SUM = SUM - COV(II+K)*COV(IJ+K) END DO COV(IJ+I) = SUM/CVDIAG ELSE COV(IJ+I) = 0 ENDIF IJ = IJ + J END DO * * Compute expected value for Ith integration variable and * scale Ith covariance matrix row and limits. * IF ( CVDIAG .GT. 0 ) THEN IF ( EMIN .GT. DMIN + 1D-8 ) THEN YL = 0 YU = 0 IF ( INFI(I) .NE. 0 ) YL = -EXP( -AMIN**2/2 )/SQTWPI IF ( INFI(I) .NE. 1 ) YU = -EXP( -BMIN**2/2 )/SQTWPI Y(I) = ( YU - YL )/( EMIN - DMIN ) ELSE IF ( INFI(I) .EQ. 0 ) Y(I) = BMIN IF ( INFI(I) .EQ. 1 ) Y(I) = AMIN IF ( INFI(I) .EQ. 2 ) Y(I) = ( AMIN + BMIN )/2 END IF DO J = 1,I II = II + 1 COV(II) = COV(II)/CVDIAG END DO IF ( INFI(I) .NE. 0 ) A(I) = A(I)/CVDIAG IF ( INFI(I) .NE. 1 ) B(I) = B(I)/CVDIAG ELSE Y(I) = 0 II = II + I ENDIF END DO CALL LIMITS( A(1), B(1), INFI(1), D, E) ENDIF END *-------------------------------------------------------------------------- SUBROUTINE BASRUL( NDIM, A, B, WIDTH, FUNCTN, W, LENRUL, G, & CENTER, Z, RGNERT, BASEST ) * * For application of basic integration rule * EXTERNAL FUNCTN INTEGER I, LENRUL, NDIM DOUBLE PRECISION & A(NDIM), B(NDIM), WIDTH(NDIM), FUNCTN, W(LENRUL,4), & G(NDIM,LENRUL), CENTER(NDIM), Z(NDIM), RGNERT, BASEST DOUBLE PRECISION & FULSUM, FSYMSM, RGNCMP, RGNVAL, RGNVOL, RGNCPT, RGNERR * * Compute Volume and Center of Subregion * RGNVOL = 1 DO I = 1,NDIM RGNVOL = 2*RGNVOL*WIDTH(I) CENTER(I) = A(I) + WIDTH(I) END DO BASEST = 0 RGNERT = 0 * * Compute basic rule and error * 10 RGNVAL = 0 RGNERR = 0 RGNCMP = 0 RGNCPT = 0 DO I = 1,LENRUL FSYMSM = FULSUM(NDIM, CENTER, WIDTH, Z, G(1,I), FUNCTN) * Basic Rule RGNVAL = RGNVAL + W(I,1)*FSYMSM * First comparison rule RGNERR = RGNERR + W(I,2)*FSYMSM * Second comparison rule RGNCMP = RGNCMP + W(I,3)*FSYMSM * Third Comparison rule RGNCPT = RGNCPT + W(I,4)*FSYMSM END DO * * Error estimation * RGNERR = SQRT(RGNCMP**2 + RGNERR**2) RGNCMP = SQRT(RGNCPT**2 + RGNCMP**2) IF ( 4*RGNERR .LT. RGNCMP ) RGNERR = RGNERR/2 IF ( 2*RGNERR .GT. RGNCMP ) RGNERR = MAX( RGNERR, RGNCMP ) RGNERT = RGNERT + RGNVOL*RGNERR BASEST = BASEST + RGNVOL*RGNVAL * * When subregion has more than one piece, determine next piece and * loop back to apply basic rule. * DO I = 1,NDIM CENTER(I) = CENTER(I) + 2*WIDTH(I) IF ( CENTER(I) .LT. B(I) ) GO TO 10 CENTER(I) = A(I) + WIDTH(I) END DO END DOUBLE PRECISION FUNCTION FULSUM(S, CENTER, HWIDTH, X, G, F) * **** To compute fully symmetric basic rule sum * EXTERNAL F INTEGER S, IXCHNG, LXCHNG, I, L DOUBLE PRECISION CENTER(S), HWIDTH(S), X(S), G(S), F DOUBLE PRECISION INTSUM, GL, GI FULSUM = 0 * * Compute centrally symmetric sum for permutation of G * 10 INTSUM = 0 DO I = 1,S X(I) = CENTER(I) + G(I)*HWIDTH(I) END DO 20 INTSUM = INTSUM + F(S,X) DO I = 1,S G(I) = -G(I) X(I) = CENTER(I) + G(I)*HWIDTH(I) IF ( G(I) .LT. 0 ) GO TO 20 END DO FULSUM = FULSUM + INTSUM * * Find next distinct permuation of G and loop back for next sum * DO I = 2,S IF ( G(I-1) .GT. G(I) ) THEN GI = G(I) IXCHNG = I - 1 DO L = 1,(I-1)/2 GL = G(L) G(L) = G(I-L) G(I-L) = GL IF ( GL .LE. GI ) IXCHNG = IXCHNG - 1 IF ( G(L) .GT. GI ) LXCHNG = L END DO IF ( G(IXCHNG) .LE. GI ) IXCHNG = LXCHNG G(I) = G(IXCHNG) G(IXCHNG) = GI GO TO 10 ENDIF END DO * * End loop for permutations of G and associated sums * * Restore original order to G's * DO I = 1,S/2 GI = G(I) G(I) = G(S+1-I) G(S+1-I) = GI END DO END SUBROUTINE DIFFER(NDIM, A, B, WIDTH, Z, DIF, FUNCTN, & DIVAXN, DIFCLS) * * Compute fourth differences and subdivision axes * EXTERNAL FUNCTN INTEGER I, NDIM, DIVAXN, DIFCLS DOUBLE PRECISION & A(NDIM), B(NDIM), WIDTH(NDIM), Z(NDIM), DIF(NDIM), FUNCTN DOUBLE PRECISION FRTHDF, FUNCEN, WIDTHI DIFCLS = 0 DIVAXN = MOD( DIVAXN, NDIM ) + 1 IF ( NDIM .GT. 1 ) THEN DO I = 1,NDIM DIF(I) = 0 Z(I) = A(I) + WIDTH(I) END DO 10 FUNCEN = FUNCTN(NDIM, Z) DO I = 1,NDIM WIDTHI = WIDTH(I)/5 FRTHDF = 6*FUNCEN Z(I) = Z(I) - 4*WIDTHI FRTHDF = FRTHDF + FUNCTN(NDIM,Z) Z(I) = Z(I) + 2*WIDTHI FRTHDF = FRTHDF - 4*FUNCTN(NDIM,Z) Z(I) = Z(I) + 4*WIDTHI FRTHDF = FRTHDF - 4*FUNCTN(NDIM,Z) Z(I) = Z(I) + 2*WIDTHI FRTHDF = FRTHDF + FUNCTN(NDIM,Z) * Do not include differences below roundoff IF ( FUNCEN + FRTHDF/8 .NE. FUNCEN ) & DIF(I) = DIF(I) + ABS(FRTHDF)*WIDTH(I) Z(I) = Z(I) - 4*WIDTHI END DO DIFCLS = DIFCLS + 4*NDIM + 1 DO I = 1,NDIM Z(I) = Z(I) + 2*WIDTH(I) IF ( Z(I) .LT. B(I) ) GO TO 10 Z(I) = A(I) + WIDTH(I) END DO DO I = 1,NDIM IF ( DIF(DIVAXN) .LT. DIF(I) ) DIVAXN = I END DO ENDIF END *-------- SUBROUTINE TRESTR(POINTR, SBRGNS, PONTRS, RGNERS) ****BEGIN PROLOGUE TRESTR ****PURPOSE TRESTR maintains a heap for subregions. ****DESCRIPTION TRESTR maintains a heap for subregions. * The subregions are ordered according to the size of the * greatest error estimates of each subregion (RGNERS). * * PARAMETERS * * POINTR Integer. * The index for the subregion to be inserted in the heap. * SBRGNS Integer. * Number of subregions in the heap. * PONTRS Real array of dimension SBRGNS. * Used to store the indices for the greatest estimated errors * for each subregion. * RGNERS Real array of dimension SBRGNS. * Used to store the greatest estimated errors for each * subregion. * ****ROUTINES CALLED NONE ****END PROLOGUE TRESTR * * Global variables. * INTEGER POINTR, SBRGNS DOUBLE PRECISION PONTRS(*), RGNERS(*) * * Local variables. * * RGNERR Intermediate storage for the greatest error of a subregion. * SUBRGN Position of child/parent subregion in the heap. * SUBTMP Position of parent/child subregion in the heap. * INTEGER SUBRGN, SUBTMP, POINTP, POINTS DOUBLE PRECISION RGNERR * ****FIRST PROCESSING STATEMENT TRESTR * RGNERR = RGNERS(POINTR) IF ( POINTR .EQ. PONTRS(1) ) THEN * * Move the new subregion inserted at the top of the heap * to its correct position in the heap. * SUBRGN = 1 10 SUBTMP = 2*SUBRGN IF ( SUBTMP .LE. SBRGNS ) THEN IF ( SUBTMP .NE. SBRGNS ) THEN * * Find maximum of left and right child. * POINTS = PONTRS(SUBTMP) POINTP = PONTRS(SUBTMP+1) IF ( RGNERS(POINTS) .LT. + RGNERS(POINTP) ) SUBTMP = SUBTMP + 1 ENDIF * * Compare maximum child with parent. * If parent is maximum, then done. * POINTS = PONTRS(SUBTMP) IF ( RGNERR .LT. RGNERS(POINTS) ) THEN * * Move the pointer at position subtmp up the heap. * PONTRS(SUBRGN) = PONTRS(SUBTMP) SUBRGN = SUBTMP GO TO 10 ENDIF ENDIF ELSE * * Insert new subregion in the heap. * SUBRGN = SBRGNS 20 SUBTMP = SUBRGN/2 IF ( SUBTMP .GE. 1 ) THEN * * Compare child with parent. If parent is maximum, then done. * POINTS = PONTRS(SUBTMP) IF ( RGNERR .GT. RGNERS(POINTS) ) THEN * * Move the pointer at position subtmp down the heap. * PONTRS(SUBRGN) = PONTRS(SUBTMP) SUBRGN = SUBTMP GO TO 20 ENDIF ENDIF ENDIF PONTRS(SUBRGN) = POINTR * ****END TRESTR * END *-------------------------------------------------------------------------- SUBROUTINE RCSWAP(P, Q, A, B, INFIN, N, C) * * Swaps rows and columns P and Q in situ. * DOUBLE PRECISION A(*), B(*), C(*), T INTEGER INFIN(*), P, Q, N, I, J, II, JJ T = A(P) A(P) = A(Q) A(Q) = T T = B(P) B(P) = B(Q) B(Q) = T J = INFIN(P) INFIN(P) = INFIN(Q) INFIN(Q) = J JJ = (P*(P-1))/2 II = (Q*(Q-1))/2 T = C(JJ+P) C(JJ+P) = C(II+Q) C(II+Q) = T DO J = 1, P-1 T = C(JJ+J) C(JJ+J) = C(II+J) C(II+J) = T END DO JJ = JJ + P DO I = P+1, Q-1 T = C(JJ+P) C(JJ+P) = C(II+I) C(II+I) = T JJ = JJ + I END DO II = II + Q DO I = Q+1, N T = C(II+P) C(II+P) = C(II+Q) C(II+Q) = T II = II + I END DO END *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- *-------------------------------------------------------------------------- * SUBROUTINE SADMVT(N, NU, LOWER, UPPER, INFIN, CORREL, MAXPTS, * ABSEPS, RELEPS, ERROR, VALUE, INFORM) * * A subroutine for computing multivariate t probabilities. * Alan Genz * Department of Mathematics * Washington State University * Pullman, WA 99164-3113 * Email : AlanGenz@wsu.edu * * Parameters * * N INTEGER, the number of variables. * NU INTEGER, the number of degrees of freedom. * LOWER REAL, array of lower integration limits. * UPPER REAL, array of upper integration limits. * INFIN INTEGER, array of integration limits flags: * if INFIN(I) < 0, Ith limits are (-infinity, infinity); * if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)]; * if INFIN(I) = 1, Ith limits are [LOWER(I), infinity); * if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)]. * CORREL REAL, array of correlation coefficients; the correlation * coefficient in row I column J of the correlation matrix * should be stored in CORREL( J + ((I-2)*(I-1))/2 ), for J < I. * MAXPTS INTEGER, maximum number of function values allowed. This * parameter can be used to limit the time taken. A sensible * strategy is to start with MAXPTS = 1000*N, and then * increase MAXPTS if ERROR is too large. * ABSEPS REAL absolute error tolerance. * RELEPS REAL relative error tolerance. * ERROR REAL, estimated absolute error, with 99% confidence level. * VALUE REAL, estimated value for the integral * INFORM INTEGER, termination status parameter: * if INFORM = 0, normal completion with ERROR < EPS; * if INFORM = 1, completion with ERROR > EPS and MAXPTS * function vaules used; increase MAXPTS to * decrease ERROR; * if INFORM = 2, N > 20 or N < 1. * EXTERNAL FNCMVT INTEGER NL, N, NU, M, INFIN(*), LENWRK, MAXPTS, INFORM, INFIS, & RULCLS, TOTCLS, NEWCLS, MAXCLS DOUBLE PRECISION CORREL(*), LOWER(*), UPPER(*), ABSEPS, RELEPS, & ERROR, VALUE, OLDVAL, D, E, MVTNIT PARAMETER ( NL = 20 ) PARAMETER ( LENWRK = 20*NL**2 ) DOUBLE PRECISION WORK(LENWRK) DOUBLE PRECISION FNCMVT * * [AA (2014-06-25)] next DO loop initializes WORK array, * un-initialized in original code which caused complaints of some compilers * DO I = 1,LENWRK WORK(I) = 0.0D0 ENDDO IF ( N .GT. 20 .OR. N .LT. 1 ) THEN INFORM = 2 VALUE = 0 ERROR = 1 RETURN ENDIF INFORM = MVTNIT( N, NU, CORREL, LOWER, UPPER, INFIN, INFIS, D, E ) M = N - INFIS IF ( M .EQ. 0 ) THEN VALUE = 1 ERROR = 0 ELSE IF ( M .EQ. 1 ) THEN VALUE = E - D ERROR = 2E-16 ELSE * * Call the subregion adaptive integration subroutine * M = M - 1 RULCLS = 1 CALL ADAPT( M, RULCLS, 0, FNCMVT, ABSEPS, RELEPS, * LENWRK, WORK, ERROR, VALUE, INFORM ) MAXCLS = MIN( 10*RULCLS, MAXPTS ) TOTCLS = 0 CALL ADAPT( M, TOTCLS, MAXCLS, FNCMVT, ABSEPS, RELEPS, * LENWRK, WORK, ERROR, VALUE, INFORM ) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN 10 OLDVAL = VALUE MAXCLS = MAX( 2*RULCLS, MIN( 3*MAXCLS/2, MAXPTS - TOTCLS ) ) NEWCLS = -1 CALL ADAPT( M, NEWCLS, MAXCLS, FNCMVT, ABSEPS, RELEPS, * LENWRK, WORK, ERROR, VALUE, INFORM ) TOTCLS = TOTCLS + NEWCLS ERROR = ABS(VALUE-OLDVAL) + SQRT(RULCLS*ERROR**2/TOTCLS) IF ( ERROR .GT. MAX( ABSEPS, RELEPS*ABS(VALUE) ) ) THEN IF ( MAXPTS - TOTCLS .GT. 2*RULCLS ) GO TO 10 ELSE INFORM = 0 END IF ENDIF ENDIF END * DOUBLE PRECISION FUNCTION FNCMVT(N, W) * * Integrand subroutine * INTEGER N, NUIN, INFIN(*), INFIS DOUBLE PRECISION W(*), LOWER(*), UPPER(*), CORREL(*), D, E INTEGER NL, IJ, I, J, NU PARAMETER ( NL = 20 ) DOUBLE PRECISION COV((NL*(NL+1))/2), A(NL), B(NL), Y(NL) INTEGER INFI(NL) DOUBLE PRECISION PROD, D1, E1, DI, EI, SUM, STDINV, YD, UI, MVTNIT SAVE NU, D1, E1, A, B, INFI, COV DI = D1 EI = E1 PROD = EI - DI IJ = 1 YD = 1 DO I = 1, N UI = STDINV( NU+I-1, DI + W(I)*( EI - DI ) ) Y(I) = UI/YD YD = YD/SQRT( 1 + ( UI - 1 )*( UI + 1 )/( NU + I ) ) SUM = 0 DO J = 1, I IJ = IJ + 1 SUM = SUM + COV(IJ)*Y(J) END DO IJ = IJ + 1 CALL MVTLMS( NU+I, ( A(I+1) - SUM )*YD, ( B(I+1) - SUM )*YD, & INFI(I+1), DI, EI ) PROD = PROD*( EI - DI ) END DO FNCMVT = PROD RETURN * * Entry point for intialization * ENTRY MVTNIT( N, NUIN, CORREL, LOWER, UPPER, INFIN, INFIS, D, E ) MVTNIT = 0 * * Initialization and computation of covariance matrix Cholesky factor * CALL MVTSRT( N, NUIN, LOWER, UPPER, CORREL, INFIN, Y, INFIS, & A, B, INFI, COV, D, E ) NU = NUIN D1 = D E1 = E END SUBROUTINE MVTLMS( NU, A, B, INFIN, LOWER, UPPER ) DOUBLE PRECISION A, B, LOWER, UPPER, STUDNT INTEGER NU, INFIN LOWER = 0 UPPER = 1 IF ( INFIN .GE. 0 ) THEN IF ( INFIN .NE. 0 ) LOWER = STUDNT( NU, A ) IF ( INFIN .NE. 1 ) UPPER = STUDNT( NU, B ) ENDIF END * SUBROUTINE MVTSRT( N, NU, LOWER, UPPER, CORREL, INFIN, Y, INFIS, & A, B, INFI, COV, D, E ) * * Sort limits * INTEGER N, NU, INFI(*), INFIN(*), INFIS DOUBLE PRECISION & A(*), B(*), COV(*), LOWER(*), UPPER(*), CORREL(*), Y(*), D, E INTEGER I, J, K, IJ, II, JMIN, iflag DOUBLE PRECISION SUMSQ, ZERO, TWO, PI, CVDIAG DOUBLE PRECISION AI, BI, SUM, YL, YU, YD DOUBLE PRECISION AMIN, BMIN, DMIN, EMIN, CON, CONODD, CONEVN PARAMETER ( ZERO = 0, TWO = 2, PI = 3.14159 26535 89793 23844 ) IJ = 0 II = 0 INFIS = 0 DO I = 1, N INFI(I) = INFIN(I) IF ( INFI(I) .LT. 0 ) THEN INFIS = INFIS + 1 ELSE A(I) = 0 B(I) = 0 IF ( INFI(I) .NE. 0 ) A(I) = LOWER(I) IF ( INFI(I) .NE. 1 ) B(I) = UPPER(I) ENDIF DO J = 1,I-1 IJ = IJ + 1 II = II + 1 COV(IJ) = CORREL(II) END DO IJ = IJ + 1 COV(IJ) = 1 END DO CONODD = 1/PI CONEVN = 1/TWO DO I = 1, NU - 1 IF ( MOD(I,2) .EQ. 0 ) THEN IF ( I .GT. 2 ) CONEVN = CONEVN*(I-1)/(I-2) ELSE IF ( I .GT. 2 ) CONODD = CONODD*(I-1)/(I-2) ENDIF END DO * * First move any doubly infinite limits to innermost positions * [AA, recoded to avoid GOTO jump outside IF block] * IF ( INFIS .LT. N ) THEN DO I = N, N-INFIS+1, -1 iflag = 0 IF ( INFI(I) .GE. 0 ) THEN DO J = 1, I-1 IF ( INFI(J) .LT. 0 .and. iflag .eq. 0) THEN CALL RCSWAP( J, I, A, B, INFI, N, COV ) iflag = 1 ENDIF END DO ENDIF 10 END DO * * Sort remaining limits and determine Cholesky decomposition * II = 0 YD = 1 DO I = 1, N-INFIS * * Determine the integration limits for variable with minimum * expected probability and interchange that variable with Ith. * EMIN = 1 DMIN = 0 JMIN = I CVDIAG = 0 IJ = II DO J = I, N-INFIS SUM = 0 SUMSQ = 0 DO K = 1, I-1 SUM = SUM + COV(IJ+K)*Y(K) SUMSQ = SUMSQ + COV(IJ+K)**2 END DO IJ = IJ + J SUMSQ = SQRT( MAX( COV(IJ)-SUMSQ, ZERO ) ) IF ( SUMSQ .GT. 0 ) THEN AI = YD*( A(J) - SUM )/SUMSQ BI = YD*( B(J) - SUM )/SUMSQ CALL MVTLMS( NU+J-1, AI, BI, INFI(J), D, E ) IF ( EMIN - DMIN .GE. E - D ) THEN JMIN = J AMIN = AI BMIN = BI DMIN = D EMIN = E CVDIAG = SUMSQ ENDIF ENDIF END DO IF ( JMIN .NE. I ) CALL RCSWAP( I, JMIN, A,B, INFI, N,COV ) * * Compute Ith column of Cholesky factor. * IJ = II + I COV(IJ) = CVDIAG DO J = I+1, N-INFIS IF ( CVDIAG .GT. 0 ) THEN SUM = COV(IJ+I) DO K = 1, I-1 SUM = SUM - COV(II+K)*COV(IJ+K) END DO COV(IJ+I) = SUM/CVDIAG ELSE COV(IJ+I) = 0 ENDIF IJ = IJ + J END DO * * Compute expected value for Ith integration variable and * scale Ith covariance matrix row and limits. * IF ( MOD(NU+I-1,2) .EQ. 0 ) THEN IF ( NU+I-3 .GT. 0 ) CONEVN = CONEVN*(NU+I-2)/(NU+I-3) CON = CONEVN ELSE IF ( NU+I-3 .GT. 0 ) CONODD = CONODD*(NU+I-2)/(NU+I-3) CON = CONODD ENDIF IF ( CVDIAG .GT. 0 ) THEN YL = 0 YU = 0 IF ( INFI(I) .NE. 0 .AND. NU+I-2 .GT. 0 ) & YL = -CON*(NU+I-1)/(NU+I-2) & /( 1 + AMIN**2/(NU+I-1) )**( (NU+I-2)/TWO ) IF ( INFI(I) .NE. 1 .AND. NU+I-2 .GT. 0 ) & YU = -CON*(NU+I-1)/(NU+I-2) & /( 1 + BMIN**2/(NU+I-1) )**( (NU+I-2)/TWO ) Y(I) = ( YU - YL )/( EMIN - DMIN )/YD DO J = 1,I II = II + 1 COV(II) = COV(II)/CVDIAG END DO IF ( INFI(I) .NE. 0 ) A(I) = A(I)/CVDIAG IF ( INFI(I) .NE. 1 ) B(I) = B(I)/CVDIAG ELSE Y(I) = 0 II = II + I ENDIF YD = YD/SQRT( 1 + ( Y(I)*YD + 1 )*( Y(I)*YD - 1 )/(NU+I) ) END DO CALL MVTLMS( NU, A(1), B(1), INFI(1), D, E) ENDIF END *-- DOUBLE PRECISION FUNCTION STUDNT( NU, T ) * * Student t Distribution Function * * T * STUDNT = C I ( 1 + y*y/NU )**( -(NU+1)/2 ) dy * NU -INF * INTEGER NU, J DOUBLE PRECISION T, CSSTHE, SNTHE, POLYN, TT, TS, RN, PI, ZERO PARAMETER ( PI = 3.14159 26535 89793D0, ZERO = 0 ) IF ( NU .EQ. 1 ) THEN STUDNT = ( 1 + 2*ATAN(T)/PI )/2 ELSE IF ( NU .EQ. 2) THEN STUDNT = ( 1 + T/SQRT( 2 + T*T ))/2 ELSE TT = T*T CSSTHE = 1/( 1 + TT/NU ) POLYN = 1 DO J = NU-2, 2, -2 POLYN = 1 + ( J - 1 )*CSSTHE*POLYN/J END DO IF ( MOD( NU, 2 ) .EQ. 1 ) THEN RN = NU TS = T/SQRT(RN) STUDNT = ( 1 + 2*( ATAN(TS) + TS*CSSTHE*POLYN )/PI )/2 ELSE SNTHE = T/SQRT( NU + TT ) STUDNT = ( 1 + SNTHE*POLYN )/2 END IF STUDNT = MAX( ZERO, STUDNT ) ENDIF END *-- DOUBLE PRECISION FUNCTION STDINV( N, Z ) * * Inverse Student t Distribution Function * * STDINV * Z = C I (1 + y*y/N)**(-(N+1)/2) dy * N -INF * * Reference: G.W. Hill, Comm. ACM Algorithm 395 * Comm. ACM 13 (1970), pp. 619-620. * * Conversions to double precision and other modifications by * Alan Genz, 1993-4. * INTEGER N DOUBLE PRECISION Z, P, PHINV, A, B, C, D, X, Y, PI, TWO DOUBLE PRECISION STUDNT, STDJAC PARAMETER ( PI = 3.14159 26535 89793D0, TWO = 2 ) IF ( 0 .LT. Z .AND. Z .LT. 1 ) THEN IF ( N .EQ. 1 ) THEN STDINV = TAN( PI*( 2*Z - 1 )/2 ) ELSE IF ( N .EQ. 2) THEN STDINV = ( 2*Z - 1 )/SQRT( 2*Z*( 1 - Z ) ) ELSE IF ( 2*Z .GE. 1 ) THEN P = 2*( 1 - Z ) ELSE P = 2*Z END IF A = 1/( N - 0.5 ) B = 48/( A*A ) C = ( ( 20700*A/B - 98 )*A - 16 )*A + 96.36 D = ( ( 94.5/( B + C ) - 3 )/B + 1 )*SQRT( A*PI/2 )*N X = D*P Y = X**( TWO/N ) IF ( Y .GT. A + 0.05 ) THEN X = PHINV( P/2 ) Y = X*X IF ( N .LT. 5 ) C = C + 3*( N - 4.5 )*( 10*X + 6 )/100 C = ( ( (D*X - 100)*X/20 - 7 )*X - 2 )*X + B + C Y = ( ( ( ( (4*Y+63)*Y/10+36 )*Y+94.5 )/C-Y-3 )/B + 1 )*X Y = A*Y*Y IF ( Y .GT. 0.002 ) THEN Y = EXP(Y) - 1 ELSE Y = Y*( 1 + Y/2 ) ENDIF ELSE Y = ( ( 1/( ( (N+6)/(N*Y) - 0.089*D - 0.822 )*(3*N+6) ) & + 0.5/(N+4) )*Y - 1 )*(N+1)/(N+2) + 1/Y END IF STDINV = SQRT(N*Y) IF ( 2*Z .LT. 1 ) STDINV = -STDINV IF ( ABS( STDINV ) .GT. 0 ) THEN * * Use one third order correction to the single precision result * X = STDINV D = Z - STUDNT(N,X) STDINV = X + 2*D/( 2/STDJAC(N,X) - D*(N+1)/(N/X+X) ) END IF END IF ELSE * * Use cutoff values for Z near 0 or 1. * STDINV = SQRT( N/( 2D-16*SQRT( 2*PI*N ) )**( TWO/N ) ) IF ( 2*Z .LT. 1 ) STDINV = -STDINV END IF END *-- DOUBLE PRECISION FUNCTION STDJAC( NU, T ) * * Student t Distribution Transformation Jacobean * * T STDINV(NU,T) * I f(y) dy = I f(STDINV(NU,Z) STDJAC(NU,STDINV(NU,Z)) dZ * -INF 0 * INTEGER NU, J DOUBLE PRECISION CONST, NUOLD, PI, T, TT PARAMETER ( PI = 3.14159 26535 89793D0 ) SAVE NUOLD, CONST DATA NUOLD/ 0D0 / IF ( NU .EQ. 1 ) THEN STDJAC = PI*( 1 + T*T ) ELSE IF ( NU .EQ. 2 ) THEN STDJAC = SQRT( 2 + T*T )**3 ELSE IF ( NU .NE. NUOLD ) THEN NUOLD = NU IF ( MOD( NU, 2 ) .EQ. 0 ) THEN CONST = SQRT(NUOLD)*2 ELSE CONST = SQRT(NUOLD)*PI END IF DO J = NU-2, 1, -2 CONST = J*CONST/(J+1) END DO END IF TT = 1 + T*T/NU STDJAC = CONST*TT**( (NU+1)/2 ) IF ( MOD( NU, 2 ) .EQ. 0 ) STDJAC = STDJAC*SQRT( TT ) END IF END * mnormt/src/rtmng.f0000644000176200001440000000565614245346227013700 0ustar liggesusers* Subroutine rtmnG runs a Gibbs recursion for sampling from a multivariate * normal variable X=(X[1],...,X[d])^T ~ N_d(mean, varcov) truncated by * the limits (lower < X < upper), where the inequalities hold component-wise. * Is it assumed that some preliminary quantities are supplied in arrays regr * and sdc, which defined as * regr: (d, d-1) matrix whose j-th row is varcov[j,] (varcov[-j,-j])^{-1}, * sdc: d-vector with the std.dev's the conditional variables (X[j]|X[-j]), * sqrt(varcov[j,j] - varcov[j,] (varcov[-j,-j])^{-1} varcov[,j]) * where varcov[j,] denotes the j-th row of varcov, varcov[j,j] the [j,j]th * entry of varcov, and varcov[-j,-j] the matrix obtained removing by the j-th * row and column. * * Arguments: * name type size description * n integer 1 the number of random vectors to be generated * d integer 1 the dimension of X (condition: d>1) * mean double d the mean vector of X * regr double (d, d-1) see above * sdc double d see above * lower double d lower truncation limits * upper double d upper truncation limits * x double (n,d) (output) matrix of sampled values * start double d initial value of the Gibbs iteration * * Author: Adelchi Azzalini, Università degli Studi di Padova, 2022 * ****************************************************************************** subroutine rtmng(n, d, mean, regr, sdc, lower, upper, x, start) integer n, d, i, j, k double precision x(n, d), mean(d), regr(d,d-1), sdc(d) double precision lower(d), upper(d), start(d), meanc, work(d-1) double precision p1, p2, u, z, qnormr, pnormr, unifrnd if(d .lt. 2) return call rndstart() do i = 1, n ! DO loop over the row index if(i .eq. 1) then do j = 1, d x(i,j) = start(j) end do else do j = 1, d x(i,j) = x(i-1, j) end do endif do j = 1, d ! DO loop over the column index do k = 1, j-1 ! This and next DO loop build work(k) = x(i, k) - mean(k) ! (x[i,-j] - mean[-j]) end do do k = j+1, d work(k-1) = x(i, k) - mean(k) end do ! call dblepr("work:", -1, work, d-1) meanc = mean(j) ! initialize meanc do k = 1, d-1 ! DO loop building meanc meanc = meanc + regr(j, k) * work(k) end do p1 = pnormr(lower(j), meanc, sdc(j), 1, 0) p2 = pnormr(upper(j), meanc, sdc(j), 1, 0) u = unifrnd() ! call dblepr1("u", -1, u) z = qnormr(p1 + u*(p2-p1), 0.0d0, 1.0d0, 1, 0) x(i, j) = meanc + sdc(j) *z end do end do call rndend() return end mnormt/COPYING0000644000176200001440000004307010365160235012626 0ustar liggesusers GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. mnormt/R/0000755000176200001440000000000014314263017011770 5ustar liggesusersmnormt/R/misc_funct.R0000644000176200001440000000526314247454320014257 0ustar liggesusers# Miscellaneous functions of R package mnormt # Author: Adelchi Azzalini # sample_Mardia_measures <- function(data, correct=FALSE) {# Computes measures of Mardia (1970, Biometrika, vol.57, pp.519-530) and # (1974, Sankhya ser.B, vol.36, pp.115-128 - includes equations quoted below). # R function written in 2020. y <- data.matrix(data) y <- y[complete.cases(y), , drop=FALSE] n <- nrow(y) if(n < 4) stop("condition n>3 is required") d <- ncol(y) m <- if(d>1) apply(y, 2, mean) else mean(y) y0 <- y - outer(rep(1, n), m) t.y0 <- t(y0) f <- if(correct) 1 else (n-1)/n S <- var(y0)*f # f=(n-1)/n gives results as on p.127 of Mardia (1974) Sinv <- pd.solve(S) b1 <- mean((y0 %*% Sinv %*% t.y0)^3) # eq.(2.2) b2 <- mean(colSums((Sinv %*% t.y0) * t.y0)^2) # eq.(2.4) g1 <- n*(n-1)*b1/(n-2)^2 # eq.(2.10) g2 <- (n-1)*((n+1)*b2 - (n-1)*d*(d+2))/((n-2)*(n-3)) # eq.(2.11) k <- (d+1)*(n+1)*(n+3)/(n*((n+1)*(d+1)-6)) # eq.(5.5) p.b1 <- 1 - pchisq(b1*n*k/6, df=d*(d+1)*(d+2)/6) p.b2 <- if((n-d-1) > 0) { # next 3 lines \ r <- sqrt((n+3)*(n+5)/(n-d-1)) # use eq.(5.6) std.b2 <- ((n+1)*b2-d*(d+2)*(n-1))*r/((8*d*(d+2)*(n-3)*(n-d-1))) p.b2 <- 2*pnorm(-abs(std.b2)) } else NA return(c(b1=b1, b2=b2, g1=g1, g2=g2, p.b1=p.b1, p.b2=p.b2, n=n)) } # plot_fxy <- function(f, xlim, ylim, ..., npt=51, grf, grpar) { # 2022-06-01 dots <- list(...) dnm <- names(dots) # 'dots' names funct <- if(is.character(f)) get(f, inherits=TRUE) else f ff <- formals(funct) fnm <- names(ff[-1]) # 'formal' names nmm <- match(dnm, fnm) if(any(is.na(nmm))) stop("some arguments do not match those of 'f'") if(length(npt) < 2) npt <- rep(npt, 2) n1 <- npt[1] n2 <- npt[2] x <- x1 <- if(length(xlim) > 2) xlim else { if(length(xlim) ==2) seq(min(xlim), max(xlim), length=n1) else stop("invalid xlim") } y <- x2 <- if(length(ylim) > 2) ylim else { if(length(ylim) ==2) seq(min(ylim), max(ylim), length=n2) else stop("invalid ylim") } x1.x2 <- cbind(rep(x1, n2), as.vector(matrix(x2, n1, n2, byrow=TRUE))) X <- matrix(x1.x2, n1 * n2, 2, byrow = FALSE) f.val <- matrix(funct(X, ...), n1, n2) if(missing(grf)) grf <- "contour" if(!(grf %in% c("contour", "filled.contour", "persp", "image"))) stop(gettextf("'%s' is not a valid 'grf' function", grf)) cmd.char <- paste(paste("graphics::", grf, "(x, y, f.val", sep=""), if(missing(grpar)) ")" else paste(",", grpar, ")")) eval(parse(text=cmd.char)) invisible(list(x=x, y=y, pts=X, f.values=f.val)) } mnormt/R/mnormt.R0000644000176200001440000002431714313010630013424 0ustar liggesusers# R code of package 'mnormt' # Author: Adelchi Azzalini (University of Padua, Italy) dmnorm <- function(x, mean=rep(0,d), varcov, log=FALSE) { d <- if(is.matrix(varcov)) ncol(varcov) else 1 if(d==1) return(dnorm(x, mean, sqrt(varcov), log=log)) x <- if (is.vector(x)) t(matrix(x)) else data.matrix(x) if(ncol(x) != d) stop("mismatch of dimensions of 'x' and 'varcov'") if(is.matrix(mean)) { if ((nrow(x) != nrow(mean)) || (ncol(mean) != d)) stop("mismatch of dimensions of 'x' and 'mean'") } if(is.vector(mean)) mean <- outer(rep(1, nrow(x)), as.vector(matrix(mean,d))) X <- t(x - mean) conc <- pd.solve(varcov, log.det=TRUE) Q <- colSums((conc %*% X)* X) log.det <- attr(conc, "log.det") logPDF <- as.vector(Q + d*logb(2*pi) + log.det)/(-2) if(log) logPDF else exp(logPDF) } rmnorm <- function(n=1, mean=rep(0,d), varcov, sqrt=NULL) { sqrt.varcov <- if(is.null(sqrt)) chol(varcov) else sqrt d <- if(is.matrix(sqrt.varcov)) ncol(sqrt.varcov) else 1 mean <- outer(rep(1,n), as.vector(matrix(mean,d))) drop(mean + t(matrix(rnorm(n*d), d, n)) %*% sqrt.varcov) } pmnorm <- function(x, mean=rep(0, d), varcov, ...) { d <- NCOL(varcov) x <- if (is.vector(x)) matrix(x, 1, d) else data.matrix(x) n <- nrow(x) if(is.vector(mean)) mean <- outer(rep(1, n), as.vector(matrix(mean,d))) if(d == 1) p <- as.vector(pnorm(x, mean, sqrt(varcov))) else { pv <- numeric(n) for (j in 1:n) p <- pv[j] <- { if(d == 2) biv.nt.prob(Inf, lower=rep(-Inf, 2), upper=x[j,], mean[j,], varcov) else if(d == 3) ptriv.nt(Inf, x=x[j,], mean[j,], varcov) else sadmvn(lower=rep(-Inf, d), upper=x[j,], mean[j,], varcov, ...) } if(n > 1) p <- pv } return(p) } sadmvn <- function(lower, upper, mean, varcov, maxpts=2000*d, abseps=1e-6, releps=0) { if(any(lower > upper)) stop("lower>upper integration limits") if(any(lower == upper)) return(0) d <- as.integer(if(is.matrix(varcov)) ncol(varcov) else 1) varcov <- matrix(varcov, d, d) sd <- sqrt(diag(varcov)) rho <- cov2cor(varcov) lower <- as.double((lower-mean)/sd) upper <- as.double((upper-mean)/sd) if(d == 1) return(pnorm(upper) - pnorm(lower)) if(d == 2) return(biv.nt.prob(Inf, lower, upper, rep(0,2), rho)) infin <- rep(2,d) infin <- replace(infin, (upper == Inf) & (lower > -Inf), 1) infin <- replace(infin, (upper < Inf) & (lower == -Inf), 0) infin <- replace(infin, (upper == Inf) & (lower == -Inf), -1) infin <- as.integer(infin) if(any(infin == -1)) { if(all(infin == -1)) return(1) k <- which(infin != -1) d <- length(k) lower <- lower[k] upper <- upper[k] if(d == 1) return(pnorm(upper) - pnorm(lower)) rho <- rho[k, k] infin <- infin[k] if(d == 2) return(biv.nt.prob(Inf, lower, upper, rep(0,2), rho)) } if(d > 20) # 2022-09-21, overrides a "0 value & error msg" from sadmvn return(NA) lower <- replace(lower, lower == -Inf, 0) upper <- replace(upper, upper == Inf, 0) correl <- as.double(rho[upper.tri(rho, diag=FALSE)]) maxpts <- as.integer(maxpts) abseps <- as.double(abseps) releps <- as.double(releps) error <- as.double(0) value <- as.double(0) inform <- as.integer(0) result <- .Fortran("sadmvn", d, lower, upper, infin, correl, maxpts, abseps, releps, error, value, inform, PACKAGE="mnormt") prob <- result[[10]] attr(prob,"error") <- result[[9]] attr(prob,"status") <- switch(1 + result[[11]], "normal completion", "accuracy non achieved", "oversize") return(prob) } #---- dmt <- function (x, mean=rep(0,d), S, df = Inf, log = FALSE) { if (df == Inf) return(dmnorm(x, mean, S, log = log)) d <- if(is.matrix(S)) ncol(S) else 1 if (d==1) { y <- dt((x-mean)/sqrt(S), df=df, log=log) if(log) y <- (y - 0.5*logb(S)) else y <- y/sqrt(S) return(y) } x <- if (is.vector(x)) t(matrix(x)) else data.matrix(x) if (ncol(x) != d) stop("mismatch of dimensions of 'x' and 'varcov'") if (is.matrix(mean)) {if ((nrow(x) != nrow(mean)) || (ncol(mean) != d)) stop("mismatch of dimensions of 'x' and 'mean'") } if(is.vector(mean)) mean <- outer(rep(1, nrow(x)), as.vector(matrix(mean,d))) X <- t(x - mean) S.inv <- pd.solve(S, log.det=TRUE) Q <- colSums((S.inv %*% X) * X) logDet <- attr(S.inv, "log.det") logPDF <- (lgamma((df + d)/2) - 0.5 * (d * logb(pi * df) + logDet) - lgamma(df/2) - 0.5 * (df + d) * logb(1 + Q/df)) if(log) logPDF else exp(logPDF) } rmt <- function(n=1, mean=rep(0,d), S, df=Inf, sqrt=NULL) { sqrt.S <- if(is.null(sqrt)) chol(S) else sqrt d <- if(is.matrix(sqrt.S)) ncol(sqrt.S) else 1 # rs <<- .Random.seed v <- if(df==Inf) 1 else rchisq(n, df)/df # .Random.seed <<- rs z <- rmnorm(n, rep(0, d), sqrt=sqrt.S) mean <- outer(rep(1, n), as.vector(matrix(mean, d))) drop(mean + z/sqrt(v)) } pmt <- function(x, mean=rep(0, d), S, df=Inf, ...){ d <- NCOL(S) x <- if(is.vector(x)) matrix(x, 1, d) else data.matrix(x) n <- nrow(x) if(is.vector(mean)) mean <- outer(rep(1, n), as.vector(matrix(mean,d))) if(d == 1) p <- as.vector(pt((x-mean)/sqrt(S), df=df)) else { pv <- numeric(n) for (j in 1:n) p <- pv[j] <- { if(d == 2) biv.nt.prob(df, lower=rep(-Inf, 2), upper=x[j,], mean[j,], S) else if(d == 3) ptriv.nt(df, x=x[j,], mean=mean[j,], S) else sadmvt(df, lower=rep(-Inf, d), upper=x[j,], mean[j,], S, ...) } if(n > 1) p <- pv } return(p) } sadmvt <- function(df, lower, upper, mean, S, maxpts=2000*d, abseps=1e-6, releps=0) { if(df == Inf) return(sadmvn(lower, upper, mean, S, maxpts, abseps, releps)) if(any(lower > upper)) stop("lower>upper integration limits") if(any(lower == upper)) return(0) if(round(df) != df) warning("non integer df is rounded to integer") df <- as.integer(round(df)) d <- as.integer(if(is.matrix(S)) ncol(S) else 1) S <- matrix(S, d, d) sd <- sqrt(diag(S)) rho <- cov2cor(S) lower <- as.double((lower-mean)/sd) upper <- as.double((upper-mean)/sd) if(d == 1) return(pt(upper, df) - pt(lower, df)) if(d == 2) return(biv.nt.prob(df, lower, upper, rep(0,2), rho)) infin <- rep(2,d) infin <- replace(infin, (upper == Inf) & (lower > -Inf), 1) infin <- replace(infin, (upper < Inf) & (lower == -Inf), 0) infin <- replace(infin, (upper == Inf) & (lower == -Inf), -1) infin <- as.integer(infin) if(any(infin == -1)) { if(all(infin == -1)) return(1) k <- which(infin != -1) d <- length(k) lower <- lower[k] upper <- upper[k] if(d == 1) return(pt(upper, df=df) - pt(lower, df=df)) rho <- rho[k, k] infin <- infin[k] if(d == 2) return(biv.nt.prob(df, lower, upper, rep(0,2), rho)) } if(d > 20) # 2022-09-21, overrides a "0 value & error msg" from sadmvn return(NA) lower <- replace(lower, lower == -Inf, 0) upper <- replace(upper, upper == Inf, 0) correl <- rho[upper.tri(rho, diag=FALSE)] maxpts <- as.integer(maxpts) abseps <- as.double(abseps) releps <- as.double(releps) error <- as.double(0) value <- as.double(0) inform <- as.integer(0) result <- .Fortran("sadmvt", d, df, lower, upper, infin, correl, maxpts, abseps, releps, error, value, inform, PACKAGE="mnormt") prob <- result[[11]] attr(prob,"error") <- result[[10]] attr(prob,"status") <- switch(1+result[[12]], "normal completion", "accuracy non achieved", "oversize") return(prob) } biv.nt.prob <- function(df, lower, upper, mean, S){ if(any(dim(S) != c(2,2))) stop("dimensions mismatch") if(length(mean) != 2) stop("dimensions mismatch") if(round(df) != df) warning("non integer df is rounded to integer") nu <- if(df < Inf) as.integer(round(df)) else 0 sd <- sqrt(diag(S)) rho <- cov2cor(S)[1,2] lower <- as.double((lower-mean)/sd) upper <- as.double((upper-mean)/sd) if(any(lower > upper)) stop("lower>upper integration limits") if(any(lower == upper)) return(0) infin <- c(2,2) infin <- replace(infin, (upper == Inf) & (lower > -Inf), 1) infin <- replace(infin, (upper < Inf) & (lower == -Inf), 0) infin <- replace(infin, (upper == Inf) & (lower == -Inf), -1) infin <- as.integer(infin) if(any(infin == -1)) { if(all(infin == -1)) return(1) k <- which(infin != -1) return(pt(upper[k], df=df) - pt(lower[k], df=df)) } lower <- replace(lower, lower == -Inf, 0) upper <- replace(upper, upper == Inf, 0) rho <- as.double(rho) prob <- as.double(0) a <- .Fortran("smvbvt", prob, nu, lower, upper, infin, rho, PACKAGE="mnormt") return(a[[1]]) } ptriv.nt <- function(df, x, mean, S){ if(any(dim(S) != c(3,3))) stop("dimensions mismatch") if(length(mean) != 3) stop("dimensions mismatch") if(round(df) != df) warning("non integer df is rounded to integer") nu <- if(df < Inf) as.integer(round(df)) else 0 if(any(x == -Inf)) return(0) ok <- !is.infinite(x) p <- if(sum(ok) == 1) pt(df, (x[ok]-mean[ok])/sqrt(S[ok,ok])) else if(sum(ok) == 2) biv.nt.prob(nu, rep(2 -Inf), x[ok], mean[ok], S[ok,ok]) else { sd <- sqrt(diag(S)) h <- as.double((x-mean)/sd) cor <- cov2cor(S) rho <- as.double(c(cor[2,1], cor[3,1], cor[2,3])) prob <- as.double(0) epsi <- as.double(1e-14) a <- .Fortran("stvtl", prob, nu, h, rho, epsi, PACKAGE="mnormt") p <- a[[1]] } return(p) } pd.solve <- function(x, silent=FALSE, log.det=FALSE) { if(is.null(x)) return(NULL) if(any(is.na(x))) {if(silent) return (NULL) else stop("NA's in x") } if(length(x) == 1) x <- as.matrix(x) if(!(inherits(x, "matrix"))) {if(silent) return(NULL) else stop("x is not a matrix")} if(max(abs(x - t(x))) > .Machine$double.eps) {if(silent) return (NULL) else stop("x appears to be not symmetric") } x <- (x + t(x))/2 u <- try(chol(x, pivot = FALSE), silent = silent) if(inherits(u, "try-error")) { if(silent) return(NULL) else stop("x appears to be not positive definite") } inv <- chol2inv(u) if(log.det) attr(inv, "log.det") <- 2 * sum(log(diag(u))) dimnames(inv) <- rev(dimnames(x)) return(inv) } .onLoad <- function(library, pkg) { library.dynam("mnormt", pkg, library) invisible() } mnormt/R/truncNorm.R0000644000176200001440000003741514313357555014126 0ustar liggesusers# Code providing support for the truncated normal and "t" distributions. # A.Azzalini, 2020-2022. #-------------------------------------------------------------------------- dmtruncnorm <- function(x, mean, varcov, lower, upper, log= FALSE, ...) { d <- if(is.matrix(varcov)) ncol(varcov) else 1 if(missing(lower)) lower <- rep(-Inf,d) if(missing(upper)) upper <- rep(Inf,d) if(length(lower) != d | length(upper) != d) stop("dimension mismatch") if(!all(lower < upper)) stop("lowerlower & x 20) return(rep(NA, NROW(x))) if(is.matrix(mean)) { if((nrow(x) != nrow(mean)) || (ncol(mean) != d)) stop("mismatch of dimensions of 'x' and 'mean'") } ok <- apply((t(x)-lower)>0 & (upper-t(x))>0, 2, all) pdf <- rep(0, NROW(x)) if(sum(ok) > 0) { prob <- sadmvn(lower, upper, mean, varcov, ...) tmp <- dmnorm(x[ok,], mean, varcov, log=log) pdf[ok] <- if(log) {tmp - log(prob)} else {tmp/prob} } return(pdf) } pmtruncnorm <- function(x, mean, varcov, lower, upper, ...) { d <- if(is.matrix(varcov)) ncol(varcov) else 1 if(missing(lower)) lower <- rep(-Inf,d) if(missing(upper)) upper <- rep(Inf,d) if(length(lower) != d | length(upper) != d) stop("dimension mismatch") if(!all(lower < upper)) stop("lower= upper, 1) inside <- (x>lower & x 20) return(rep(NA, NROW(x))) if (ncol(x) != d) stop("mismatch of dimensions of 'x' and 'varcov'") if (is.matrix(mean)) { if ((nrow(x) != nrow(mean)) || (ncol(mean) != d)) stop("mismatch of dimensions of 'x' and 'mean'") } n <- NROW(x) p <- numeric(n) for(i in 1:n) p[i] <- if(any(x[i,] < lower)) 0 else sadmvn(lower, pmin(x[i,], upper), mean, varcov) return(p/sadmvn(lower, upper, mean, varcov, ...)) } rmtruncnorm <- function(n, mean, varcov, lower, upper, start, burnin=5, thinning=1) { d <- as.integer(if(is.matrix(varcov)) ncol(varcov) else 1) if(missing(lower)) lower <- rep(-Inf, d) if(missing(upper)) upper <- rep(Inf, d) if(!all(c(length(mean), length(lower), length(upper)) == rep(d,3))) stop("dimension mismatch") if(!all(upper>lower)) stop("upper>lower is required") if(d == 1) { sigma <- c(sqrt(varcov)) p1 <- pnorm((lower - mean)/sigma) p2 <- pnorm((upper - mean)/sigma) u <- runif(n) return(mean + sigma * qnorm(p1 + u*(p2-p1))) } if(missing(start)) start <- mom.mtruncnorm(powers=1, mean, varcov, lower, upper, cum=TRUE)$cum1 regr <- matrix(0, d, d-1) sd_c <- numeric(d) for(j in 1:d) { r <- c(varcov[j, -j, drop=FALSE] %*% solve(varcov[-j, -j, drop=FALSE])) regr[j,] <- r sd_c[j] <- sqrt(varcov[j,j] - sum(r * varcov[-j, j])) } nplus<- as.integer(burnin + n * thinning) x <- matrix(0, nplus, d) a <- .Fortran("rtmng", nplus, d, mean, regr, sd_c, lower, upper, x, start, NAOK=TRUE, PACKAGE="mnormt") x <- a[[8]] x[burnin+(1:n)*thinning, , drop=TRUE] } #------------------ mom.mtruncnorm <- function(powers=4, mean, varcov, lower, upper, cum=TRUE, ...) { d <- if(is.matrix(varcov)) ncol(varcov) else 1 if(d > 20) return(NA) # stop("maximal dimension is 20") if(any(powers < 0) | any(powers != round(powers))) stop("'powers' must be non-negative integers") if(length(powers) == 1) powers <- rep(powers, d) if(missing(lower)) lower <- rep(-Inf,d) if(missing(upper)) upper <- rep(Inf,d) if(!all(lower < upper)) stop("lower= upper)) stop("non-admissible bounds") M <- recintab(kappa=powers, a=lower, b=upper, mean, varcov, ...) mom <- M/M[1] out <- list(mom=mom) # if(mom[1] != 1) { warning("mom[1] != 1"); return(c(out, NA)) } cum <- if(cum) mom2cum(mom) else NULL return(c(out, cum)) } mom2cum <- function(mom){ # convert array of multivariate moments to cumulants, up to 4th order maximum get.entry <- function(array, subs, val) { # get entries with subscripts 'subs' equal to 'val' of 'array' (char) x <- get(array) ind <- rep(1, length(dim(x))) ind[subs] <- val + 1 subs.char <- paste(as.character(ind), collapse=",") eval(str2expression(paste(array, "[", subs.char, "]", sep=""))) } if(is.na(mom[1])) return(list(cum=NA, message="mom[1] must be 1")) if(mom[1] != 1) return(list(cum=NA, message="mom[1] must be 1")) if(is.vector(mom)) { # case d=1 treated separately m <- mom[-1] powers <- length(m) cum <- cmom <- g1 <- g2 <- NULL if(powers >= 1) { cum <- m[1] cmom <- 0 } if(powers >= 2) { cum <- c(cum, m[2] - m[1]^2) if(cum[2] <= 0 ) warning("cum[2] <= 0") cmom <- c(cmom, cum[2]) } if(powers >= 3) { cum <- c(cum, m[3] -3*m[1]*m[2] + 2*m[1]^3) cmom <- c(cmom, cum[3]) g1 <- cum[3]/cum[2]^1.5 } if(powers >= 4) { cum <- c(cum, m[4] -3*m[2]^2 - 4*m[1]*m[3] + 12*m[1]^2*m[2] -6*m[1]^4) cmom <- c(cmom, cum[4] + 3*cum[2]^2) g2 <- cum[4]/cum[2]^2 } out <- list(cum=cum, centr.mom=cmom, std.cum=c(gamma1=g1, gamma2=g2)) return(out) } # end of case d=1 # now case d>1: powers <- dim(mom) - 1 d <- length(powers) out <- list() if(all(powers >= 1)) { m1 <- numeric(d) for(i in 1:d) m1[i] <- get.entry("mom", i, 1) out$cum1 <- m1 } if(all(powers >= 2)) { m2 <- matrix(0, d, d) # moments of 2nd order for(i in 1:d) for(j in 1:d) m2[i,j] <- if(i == j) get.entry("mom", i, 2) else get.entry("mom", c(i, j), c(1,1)) vcov <- cum2 <- (m2 - m1 %*% t(m1)) if(any(eigen(cum2, symmetric=TRUE, only.values=TRUE)$values <= 0)) warning("matrix 'cum2' not positive-definite") conc <- pd.solve(vcov, silent=TRUE, log.det=TRUE) log.det <- attr(conc, "log.det") attr(conc, 'log.det') <- NULL out$order2 <- list(m2=m2, cum2=vcov, conc.matrix=conc, log.det.cum2=log.det) if(is.null(conc)) { out$message <- "Warning: input array 'mom' appears problematic" return(out) } } if(all(powers >= 3)) { mom2 <- m2[cbind(1:d,1:d)] # 2nd order marginal moments cmom2 <- vcov[cbind(1:d,1:d)] # 2nd order marginal central moments # sd <- sqrt(cmom2) cmom3 <- mom3 <- numeric(d) # 3rd order marginal (central) moments m3 <- array(NA, rep(d,3)) # array of 3rd order moments for(i in 1:d) for (j in 1:d) for(k in 1:d) { if(i==j & j==k) { subs <- i val <- 3 mom3[i] <- get.entry("mom", subs, val) # next line uses (15.4.4) of Cramér (1946, p.175) cmom3[i] <- mom3[i] - 3*m1[i]*mom2[i] + 2*m1[i]^3 } else { if (i==j | i==k | j==k) { val <- c(2,1) if(i==j) subs <- c(i,k) if(i==k) subs <- c(i,j) if(j==k) subs <- c(j,i) } else { subs <- c(i,j,k) val <- c(1,1,1) } } m3[i,j,k] <- get.entry("mom", subs, val) } #---- # compute 3rd order cumulants using (2.7) of McCullagh (1987) cum3 <- array(NA, rep(d, 3)) # 3rd order cumulants for(i in 1:d) for (j in 1:d) for(k in 1:d) cum3[i,j,k] <- (m3[i,j,k] - (m1[i]*m2[j,k] + m1[j]*m2[i,k] + m1[k]*m2[i,j]) + 2 * m1[i]*m1[j]*m1[k]) # compute Mardia`s gamma_{1,d} as \rho^2_{23} in (2.15) of McCullagh (1987) g1 <- 0 for(i in 1:d) for (j in 1:d) for(k in 1:d) for(l in 1:d) for (m in 1:d) for(n in 1:d) g1 <- g1 + cum3[i,j,k]*cum3[l,m,n]*conc[i,l]*conc[j,m]*conc[k,n] out$order3 <- list(m3=m3, cum3=cum3, m3.marginal=mom3, centr.mom3.marginal=cmom3, gamma1.marginal=cmom3/cmom2^(3/2), gamma1.Mardia=g1, beta1.Mardia=g1) } if(all(powers >= 4)) { cmom4 <- mom4 <- numeric(d) # marginal 4th order (central) moments m4 <- array(NA, rep(d,4)) # array of 4th order moments for(i in 1:d) for (j in 1:d) for(k in 1:d) for(l in 1:d) { if(i==j & j==k & k == l) { val <- 4 subs <- i mom4[i] <- get.entry("mom", subs, val) # next line uses (15.4.4) of Cramér (1946, p.175) cmom4[i] <- mom4[i] - 4*m1[i]*mom3[i] + 6*m1[i]^2*mom2[i] - 3*m1[i]^4 } else { if(i==j & j==k | i==k & k==l | i==j & j==l | j==k & k==l) { val <- c(3, 1) if(i==j & j==k) subs <- c(i,l) if(i==k & k==l) subs <- c(i,j) if(i==j & j==l) subs <- c(i,k) if(j==k & k==l) subs <- c(j,i) } else { if(i==j & k==l | i==k & j==l | i==l & j==k) { val <- c(2, 2) if(i==j & k==l) subs <- c(i,k) if(i==k & j==l) subs <- c(i,j) if(i==l & j==k) subs <- c(i,j) } else { if(i==j | i==k | i==l | j==k | j==l | k==l) { val <- c(2, 1, 1) if(i==j) subs <- c(i,k,l) if(i==k) subs <- c(i,j,l) if(i==l) subs <- c(i,j,k) if(j==k) subs <- c(j,i,l) if(j==l) subs <- c(j,i,k) if(k==l) subs <- c(k,i,j) } else { val <- c(1,1,1,1) subs <- c(i,j,k,l) }}}} m4[i,j,k,l] <- get.entry("mom", subs, val) } # compute 4th order cumulants using (2.7) of McCullagh (1987) cum4 <- array(NA, rep(d, 4)) for(i in 1:d) for (j in 1:d) for(k in 1:d) for(l in 1:d) cum4[i,j,k,l] <- ( m4[i,j,k,l] -(m1[i]*m3[j,k,l] + m1[j]*m3[i,k,l] + m1[k]*m3[i,j,l] + m1[l]*m3[i,j,k]) -(m2[i,j]*m2[k,l] + m2[i,k]*m2[j,l] + m2[i,l]*m2[j,k]) +2 * (m1[i]*m1[j]*m2[k,l] + m1[i]*m1[k]*m2[j,l] + m1[i]*m1[l]*m2[j,k] + m1[j]*m1[k]*m2[i,l] + m1[j]*m1[l]*m2[i,k] + m1[k]*m1[l]*m2[i,j]) -6 * m1[i]*m1[j]*m1[k]*m1[l] ) # end cum4[i,j,k,l] # compute Mardia`s gamma_{2,d} as \rho_4 in (2.16) of McCullagh (1987), g2 <- 0 for(i in 1:d) for (j in 1:d) g2 <- g2 + cum4[i,j,,] * conc * conc[i,j] g2 <- sum(g2) # for(i in 1:d) for (j in 1:d) for(k in 1:d) for(l in 1:d) # g2 <- g2 + cum4[i,j,k,l]*conc[i,j]*conc[k,l] b2 <- g2 + d*(d+2) out$order4 <- list(m4=m4, cum4=cum4, m4.marginal=mom4, centr.mom4.marginal=cmom4, gamma2.marginal=(cmom4/cmom2^2 - 3), gamma2.Mardia=g2, beta2.Mardia=b2) } return(out) } #------------------ recintab <- function(kappa, a, b, mu, S, ...) {# R translation of Matlab code in 'recintab.m' if(!all(a < b)) stop("a 0) { pdfa <- s1*dnorm(aa); pdfb <- s1*dnorm(bb); M[2] <- mu*M[1] + pdfa - pdfb; if(is.infinite(a)) a <- 0; if(is.infinite(b)) b <- 0; if(kappa > 1) for(i in 2:kappa) { pdfa <- pdfa*a; pdfb <- pdfb*b; M[i+1] <- mu*M[i] + (i-1)*S*M[i-1] + pdfa - pdfb; }}} else { # # Create a matrix M, with its nu-th element correpsonds to F_{nu-2}^n(mu,S). # M <- array(0, dim=kappa+1); pk <- prod(kappa+1); # # We create two long vectors G and H to store the two different sets # of integrals with dimension n-1. # nn <- round(pk/(kappa+1)); begind <- cumsum(c(0, nn)); pk1 <- begind[n+1]; # number of (n-1)-dimensional integrals # Each row of cp corresponds to a vector that allows us to map the subscripts # to the index in the long vectors G and H cp <- matrix(0, n, n); for(i in 1:n) { kk <- kappa; kk[i] <- 0; cp[i,] <- c(1, cumprod(kk[1:(n-1)] + 1)); } G <- rep(0, pk1); H <- rep(0, pk1); s <- sqrt(diag(S)); pdfa <- dnorm(a, mu, s) pdfb <- dnorm(b, mu, s) for(i in 1:n) { ind2 <- (1:n)[-i]; # ind2(i) <- []; kappai <- kappa[ind2]; ai <- a[ind2]; bi <- b[ind2]; mui <- mu[ind2]; Si <- S[ind2,i]; SSi <- S[ind2,ind2] - Si %*% t(Si)/S[i,i]; ind <- (begind[i]+1):begind[i+1]; if(a[i] > -Inf) { mai <- mui + Si/S[i,i] * (a[i]-mu[i]); G[ind] <- pdfa[i] * recintab(kappai, ai, bi, mai, SSi); } if(b[i] < Inf ) { mbi <- mui + Si/S[i,i] * (b[i]-mu[i]); H[ind] <- pdfb[i] * recintab(kappai, ai, bi, mbi, SSi); } } # # Use recursion to obtain M(nu). M[1] <- if(n < 3) biv.nt.prob(Inf, a, b, mu, S) else sadmvn(a, b, mu, S, ...) a[is.infinite(a)] <- 0; b[is.infinite(b)] <- 0; cp1 <- t(cp[n,,drop=FALSE]); for(i in 2:pk) { kk <- arrayInd(i, kappa+1) ii <- (kk-1) %*% cp1 + 1; i1 <- min(which(kk>1)); # find a nonzero element to start the recursion kk1 <- kk; kk1[i1] <- kk1[i1] - 1; ind3 <- ii - cp1[i1]; M[ii] <- mu[i1] %*% M[ind3]; for(j in 1:n) { kk2 <- kk1[j] - 1; if(kk2 > 0) M[ii] <- M[ii] + S[i1,j] %*% kk2 %*% M[ind3-cp1[j]]; ind4 <- begind[j] + cp[j,] %*% t(kk1-1) - cp[j,j]*kk2 + 1; M[ii] <- M[ii] + S[i1,j] %*% (a[j]^kk2*G[ind4] -b[j]^kk2*H[ind4]); } } } return(M) } #-------------------------------------------- # multivariate truncated t distribution # dmtrunct <- function(x, mean, S, df, lower, upper, log= FALSE, ...) { if(df == Inf) return(dmtruncnorm(x, mean, S, log = log)) d <- if(is.matrix(S)) ncol(S) else 1 x <- if (is.vector(x)) t(matrix(x)) else data.matrix(x) if(ncol(x) != d) stop("mismatch of dimensions of 'x' and 'S'") if(d > 20) return(rep(NA, NROW(x))) # stop("maximal dimension is 20") if(is.matrix(mean)) { if((nrow(x) != nrow(mean)) || (ncol(mean) != d)) stop("mismatch of dimensions of 'x' and 'mean'")} if(missing(lower)) lower <- rep(-Inf,d) if(missing(upper)) upper <- rep(Inf,d) if(length(lower) != d | length(upper) != d) stop("dimension mismatch") if(!all(lower < upper)) stop("lower0 & (upper-t(x))>0, 2, all) pdf <- rep(0, NROW(x)) if(sum(ok) > 0) { prob <- sadmvt(df, lower, upper, mean, S, ...) tmp <- dmt(x[ok,], mean, S, df, log=log) pdf[ok] <- if(log) tmp - log(prob) else tmp/prob } return(pdf) } pmtrunct <- function(x, mean, S, df, lower, upper, ...) { if(df == Inf) return(pmtruncnorm(x, mean, S, log = log)) d <- if(is.matrix(S)) ncol(S) else 1 x <- if (is.vector(x)) t(matrix(x)) else data.matrix(x) if(d > 20) return(rep(NA, NROW(x))) # stop("maximal dimension is 20") if (ncol(x) != d) stop("mismatch of dimensions of 'x' and 'S'") if (is.matrix(mean)) { if ((nrow(x) != nrow(mean)) || (ncol(mean) != d)) stop("mismatch of dimensions of 'x' and 'mean'") } if(missing(lower)) lower <- rep(-Inf,d) if(missing(upper)) upper <- rep(Inf,d) if(length(lower) != d | length(upper) != d) stop("dimension mismatch") if(!all(lower < upper)) stop("lower2 & df=Inf}. } } \section{Changes in mnormt version 1.3-3 (2009-03-21)}{ \itemize{ \item removed check on the R version on request of the R Core team. } } \section{Changes in mnormt version 1.3-2 (2009-01-26)}{ \itemize{ \item minor modification to Fortran 77 code to avoid GOTO jumps out of IF blocks. } } \section{Changes in mnormt version 1.3-0 (2008-06-12)}{ \itemize{ \item evaluation of normal and \emph{t} distribution functions in the bivariate case now uses specific Fortran code \item improved R coding. } } \section{Changes in mnormt version 1.2-1 (2007-03-16)}{ \itemize{ \item some amendments in documentation. } } \section{Changes in mnormt version 1.2-0 (2006-10-26)}{ \itemize{ \item fixed a bug in function \code{rmt}. } } \section{Changes in mnormt version 1.1-0 (2006-10-09)}{ \itemize{ \item amedend Fortran 77 code of Alan Genz (subtroutine TRESTR). } } \section{Changes in mnormt version 1.0-1 (2006-04-26)}{ \itemize{ \item fixed a bug of non-compliance to R programming standards. } } \section{Changes in mnormt version 1.0-0 (2006-01-23)}{ \itemize{ \item first version uploaded on CRAN. } } \section{Initial mnormt version 0.0-1 (2005-11-26)}{ \itemize{ \item built private version. } }