mvtnorm/0000755000176200001440000000000014740244273011763 5ustar liggesusersmvtnorm/tests/0000755000176200001440000000000014663333501013122 5ustar liggesusersmvtnorm/tests/regtest-scores.Rout.save0000644000176200001440000002112614422664643017714 0ustar liggesusers R version 4.2.3 (2023-03-15) -- "Shortstop Beagle" Copyright (C) 2023 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("mvtnorm") > > set.seed(29081975) > > chk <- function(...) + stopifnot(all.equal(..., tol = 1e-5, check.attributes = FALSE)) > > EVAL <- function(...) {} > > if (require("numDeriv", quietly = TRUE) && + require("qrng", quietly = TRUE)) + EVAL <- eval > > N <- 10 > M <- 10000 > MM <- M / N > > prb <- 1:3 / 4 > > ### chol > thischeck <- expression({ + J <- cJ + dJ + W <- NULL + if (dJ > 1) + W <- t(ghalton(M, d = dJ - 1)) + + prm <- matrix(runif(J * (J - 1) / 2), ncol = 1) + C <- ltMatrices(prm, byrow = BYROW) + Z <- matrix(rnorm(J * N), ncol = N) + Y <- Mult(C, Z) + obs <- NULL + if (cJ) + obs <- Y[1:cJ,,drop = FALSE] + lwr <- upr <- NULL + if (dJ) { + lwr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { + qy <- quantile(y, prob = prb) + c(-Inf, qy)[cut(y, breaks = c(-Inf, qy, Inf))] + })) + upr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { + qy <- quantile(y, prob = prb) + c(qy, Inf)[cut(y, breaks = c(-Inf, qy, Inf))] + })) + } + + ll <- function(prm) { + C <- ltMatrices(prm, byrow = BYROW) + -ldpmvnorm(obs = obs, lower = lwr, upper = upr, chol = C, M = MM, w = W) + } + + sc <- function(prm) { + C <- ltMatrices(prm, byrow = BYROW) + ret <- sldpmvnorm(obs = obs, lower = lwr, upper = upr, chol = C, + M = MM, w = W)$chol + -rowSums(Lower_tri(ret)) + } + + theta <- runif(J * (J - 1) / 2) + print(ll(theta)) + chk(grad(ll, theta), sc(theta)) + }) > > BYROW <- FALSE > cJ <- 4 > dJ <- 4 > EVAL(thischeck) [1] 110.5571 > > cJ <- 1 > dJ <- 4 > EVAL(thischeck) [1] 61.73499 > > cJ <- 4 > dJ <- 1 > EVAL(thischeck) [1] 101.5923 > > cJ <- 0 > dJ <- 4 > EVAL(thischeck) [1] 62.74771 > > cJ <- 4 > dJ <- 0 > EVAL(thischeck) [1] 68.67776 > > > BYROW <- TRUE > cJ <- 4 > dJ <- 4 > EVAL(thischeck) [1] 126.3142 > > cJ <- 1 > dJ <- 4 > EVAL(thischeck) [1] 75.82315 > > cJ <- 4 > dJ <- 1 > EVAL(thischeck) [1] 69.16547 > > cJ <- 0 > dJ <- 4 > EVAL(thischeck) [1] 55.98251 > > cJ <- 4 > dJ <- 0 > EVAL(thischeck) [1] 55.17074 > > ### invchol > thischeck <- expression({ + J <- cJ + dJ + W <- NULL + if (dJ > 1) + W <- t(ghalton(M, d = dJ - 1)) + + prm <- matrix(runif(J * (J - 1) / 2), ncol = 1) + C <- ltMatrices(prm, byrow = BYROW) + Z <- matrix(rnorm(J * N), ncol = N) + Y <- Mult(C, Z) + obs <- NULL + if (cJ) + obs <- Y[1:cJ,,drop = FALSE] + lwr <- upr <- NULL + if (dJ) { + lwr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { + qy <- quantile(y, prob = prb) + c(-Inf, qy)[cut(y, breaks = c(-Inf, qy, Inf))] + })) + upr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { + qy <- quantile(y, prob = prb) + c(qy, Inf)[cut(y, breaks = c(-Inf, qy, Inf))] + })) + } + + ll <- function(prm) { + L <- ltMatrices(prm, byrow = BYROW) + -ldpmvnorm(obs = obs, + lower = lwr, upper = upr, invchol = L, M = MM, w = W) + } + + sc <- function(prm) { + L <- ltMatrices(prm, byrow = BYROW) + ret <- sldpmvnorm(obs = obs, + lower = lwr, upper = upr, invchol = L, + M = MM, w = W)$invchol + -rowSums(Lower_tri(ret)) + } + + theta <- runif(J * (J - 1) / 2) + C <- ltMatrices(matrix(theta, ncol = 1), byrow = BYROW) + theta <- Lower_tri(solve(C)) + print(ll(theta)) + chk(grad(ll, theta), sc(theta)) + }) > > > BYROW <- FALSE > cJ <- 4 > dJ <- 4 > EVAL(thischeck) [1] 119.9084 > > cJ <- 1 > dJ <- 4 > EVAL(thischeck) [1] 84.83088 > > cJ <- 4 > dJ <- 1 > EVAL(thischeck) [1] 79.17239 > > cJ <- 0 > dJ <- 4 > EVAL(thischeck) [1] 62.52789 > > cJ <- 4 > dJ <- 0 > EVAL(thischeck) [1] 70.16437 > > > BYROW <- TRUE > cJ <- 4 > dJ <- 4 > EVAL(thischeck) [1] 125.3092 > > cJ <- 1 > dJ <- 4 > EVAL(thischeck) [1] 69.96545 > > cJ <- 4 > dJ <- 1 > EVAL(thischeck) [1] 74.51345 > > cJ <- 0 > dJ <- 4 > EVAL(thischeck) [1] 54.76586 > > cJ <- 4 > dJ <- 0 > EVAL(thischeck) [1] 56.95164 > > ### chol standardized > thischeck <- expression({ + J <- cJ + dJ + W <- NULL + if (dJ > 1) + W <- t(ghalton(M, d = dJ - 1)) + + prm <- matrix(runif(J * (J - 1) / 2), ncol = 1) + C <- ltMatrices(prm) + C <- ltMatrices(C, byrow = BYROW) + Z <- matrix(rnorm(J * N), ncol = N) + Y <- Mult(C, Z) + obs <- NULL + if (cJ) + obs <- Y[1:cJ,,drop = FALSE] + lwr <- upr <- NULL + if (dJ) { + lwr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { + qy <- quantile(y, prob = prb) + c(-Inf, qy)[cut(y, breaks = c(-Inf, qy, Inf))] + })) + upr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { + qy <- quantile(y, prob = prb) + c(qy, Inf)[cut(y, breaks = c(-Inf, qy, Inf))] + })) + } + + ll <- function(prm) { + C <- ltMatrices(prm, byrow = BYROW) + Cs <- standardize(chol = C) + -ldpmvnorm(obs = obs, lower = lwr, upper = upr, chol = Cs, M = MM, w = W) + } + + sc <- function(prm) { + C <- ltMatrices(prm, byrow = BYROW) + Cs <- standardize(chol = C) + ret <- sldpmvnorm(obs = obs, lower = lwr, upper = upr, chol = Cs, + M = MM, w = W)$chol + ret <- destandardize(chol = C, score_schol = ret) + -rowSums(Lower_tri(ret)) + } + + theta <- runif(J * (J - 1) / 2) + print(ll(theta)) + chk(grad(ll, theta), sc(theta)) + }) > > BYROW <- FALSE > cJ <- 4 > dJ <- 4 > EVAL(thischeck) [1] 181.3173 > > cJ <- 1 > dJ <- 4 > EVAL(thischeck) [1] 64.84017 > > cJ <- 4 > dJ <- 1 > EVAL(thischeck) [1] 92.57033 > > cJ <- 0 > dJ <- 4 > EVAL(thischeck) [1] 57.32839 > > cJ <- 4 > dJ <- 0 > EVAL(thischeck) [1] 56.09638 > > > BYROW <- TRUE > cJ <- 4 > dJ <- 4 > EVAL(thischeck) [1] 133.3763 > > cJ <- 1 > dJ <- 4 > EVAL(thischeck) [1] 83.61253 > > cJ <- 4 > dJ <- 1 > EVAL(thischeck) [1] 77.96918 > > cJ <- 0 > dJ <- 4 > EVAL(thischeck) [1] 56.77728 > > cJ <- 4 > dJ <- 0 > EVAL(thischeck) [1] 61.12252 > > ### invchol standardized > thischeck <- expression({ + J <- cJ + dJ + W <- NULL + if (dJ > 1) + W <- t(ghalton(M, d = dJ - 1)) + + prm <- matrix(runif(J * (J - 1) / 2), ncol = 1) + C <- ltMatrices(prm, byrow = BYROW) + Z <- matrix(rnorm(J * N), ncol = N) + Y <- Mult(C, Z) + obs <- NULL + if (cJ) + obs <- Y[1:cJ,,drop = FALSE] + lwr <- upr <- NULL + if (dJ) { + lwr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { + qy <- quantile(y, prob = prb) + c(-Inf, qy)[cut(y, breaks = c(-Inf, qy, Inf))] + })) + upr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { + qy <- quantile(y, prob = prb) + c(qy, Inf)[cut(y, breaks = c(-Inf, qy, Inf))] + })) + } + + ll <- function(prm) { + L <- ltMatrices(prm, byrow = BYROW) + Ls <- standardize(invchol = L) + -ldpmvnorm(obs = obs, + lower = lwr, upper = upr, invchol = Ls, M = MM, w = W) + } + + sc <- function(prm) { + L <- ltMatrices(prm, byrow = BYROW) + Cs <- standardize(chol = solve(L)) + ret <- sldpmvnorm(obs = obs, + lower = lwr, upper = upr, chol = Cs, + M = MM, w = W)$chol + ret <- destandardize(invchol = L, score_schol = ret) + -rowSums(Lower_tri(ret)) + } + + theta <- runif(J * (J - 1) / 2) + C <- ltMatrices(matrix(theta, ncol = 1), byrow = BYROW) + theta <- Lower_tri(solve(C)) + print(ll(theta)) + chk(grad(ll, theta), sc(theta)) + }) > > > BYROW <- FALSE > cJ <- 4 > dJ <- 4 > EVAL(thischeck) [1] 144.6606 > > cJ <- 1 > dJ <- 4 > EVAL(thischeck) [1] 99.0809 > > cJ <- 4 > dJ <- 1 > EVAL(thischeck) [1] 69.28283 > > cJ <- 0 > dJ <- 4 > EVAL(thischeck) [1] 52.48012 > > cJ <- 4 > dJ <- 0 > EVAL(thischeck) [1] 52.48746 > > > BYROW <- TRUE > cJ <- 4 > dJ <- 4 > EVAL(thischeck) [1] 178.2047 > > cJ <- 1 > dJ <- 4 > EVAL(thischeck) [1] 98.60784 > > cJ <- 4 > dJ <- 1 > EVAL(thischeck) [1] 87.51641 > > cJ <- 0 > dJ <- 4 > EVAL(thischeck) [1] 49.60575 > > cJ <- 4 > dJ <- 0 > EVAL(thischeck) [1] 64.79248 > > proc.time() user system elapsed 10.731 0.088 10.832 mvtnorm/tests/regtest_mvnorm.R0000644000176200001440000001135014663333465016331 0ustar liggesusers library("mvtnorm") options(digits = 5) tol <- sqrt(sqrt(.Machine$double.eps)) set.seed(29078) EVAL <- function(...) {} if (require("numDeriv", quietly = TRUE)) EVAL <- eval chk <- function(...) stopifnot(isTRUE(all.equal(..., check.attributes = FALSE, tol = tol))) x <- mvnorm() J <- 3 M <- diag(1:J) rownames(M) <- colnames(M) <- LETTERS[1:J] (x <- mvnorm(mean = runif(J), chol = M)) margDist(x, which = 2:J) margDist(x, which = 2:J) condDist(x, which_given = 1, given = matrix(1)) logLik(x, obs = M[-1,-1]) logLik(margDist(x, which = 2:J), obs = M[-1,-1]) thischeck <- expression({ #set.seed(29) l <- matrix(pl <- runif(J * (J - 1) / 2 * Ns), ncol = Ns) colnames(l) <- paste0("i", 1:Ns) L <- ltMatrices(l, byrow = BYROW, names = LETTERS[1:J]) m <- matrix(pm <- rnorm(J * Nm), ncol = Nm) rownames(m) <- LETTERS[1:J] colnames(m) <- paste0("i", 1:Nm) if (CHOL) { x <- mvnorm(mean = m, chol = L) } else { x <- mvnorm(mean = m, invchol = L) } obs <- simulate(x, nsim = N, standardize = TRUE) tfun <- function(parm, perm = LETTERS[1:J], FUN = "logLik", chol = TRUE, ...) { args <- list(...) p1 <- parm[1:length(pm)] p2 <- parm[length(pm) + 1:length(pl)] p3 <- parm[-(1:(length(pm) + length(pl)))] p2 <- matrix(p2, ncol = Ns) L <- ltMatrices(p2, names = LETTERS[1:J]) L <- ltMatrices(p2, byrow = BYROW, names = LETTERS[1:J]) m <- matrix(p1, ncol = Nm) rownames(m) <- LETTERS[1:J] obs <- matrix(p3, ncol = N) rownames(obs) <- LETTERS[1:J] if (chol) { x <- mvnorm(mean = m, invchol = L) } else { x <- mvnorm(mean = m, chol = L) } args$object <- x args$obs <- obs[perm,,drop = FALSE] do.call(FUN, args) } ll <- tfun sc <- function(...) tfun(..., FUN = "lLgrad") l1 <- logLik(x, obs) #lLgrad(x, obs) prm <- c(pm, pl, obs) ll(prm) s <- sc(prm) sa <- c(if (Nm > 1) s$mean else rowSums(s$mean), if (Ns > 1) Lower_tri(s$scale) else rowSums(Lower_tri(s$scale)), s$obs) sn <- grad(ll, prm) chk(sa, sn) l2 <- logLik(x, obs, standardize = TRUE) # lLgrad(x, obs, standardize = TRUE) ll(prm, standardize = TRUE) s <- sc(prm, standardize = TRUE) sa <- c(if (Nm > 1) s$mean else rowSums(s$mean), if (Ns > 1) Lower_tri(s$scale) else rowSums(Lower_tri(s$scale)), s$obs) sn <- grad(ll, prm, standardize = TRUE) chk(sa, sn) l1p <- logLik(x, obs = obs[perm <- sample(rownames(obs)),,drop = FALSE]) #lLgrad(x, obs = obs[perm,,drop = FALSE]) chk(l1, l1p) ll(prm, perm = perm) s <- sc(prm, perm = perm) sa <- c(if (Nm > 1) s$mean else rowSums(s$mean), if (Ns > 1) Lower_tri(s$scale) else rowSums(Lower_tri(s$scale)), s$obs[LETTERS[1:J],]) sn <- grad(ll, prm, perm = perm) chk(sa, sn) l2p <- logLik(x, obs = obs[perm,,drop = FALSE], standardize = TRUE) # lLgrad(x, obs = obs[perm,,drop = FALSE], standardize = TRUE) chk(l2, l2p) ll(prm, perm = perm, standardize = TRUE) s <- sc(prm, perm = perm, standardize = TRUE) sa <- c(if (Nm > 1) s$mean else rowSums(s$mean), if (Ns > 1) Lower_tri(s$scale) else rowSums(Lower_tri(s$scale)), s$obs[LETTERS[1:J],]) sn <- grad(ll, prm, perm = perm, standardize = TRUE) chk(sa, sn) logLik(x, obs = obs[perm[-1],,drop = FALSE]) # lLgrad(x, obs = obs[perm,,drop = FALSE]) ll(prm, perm = perm[-1]) s <- sc(prm, perm = perm[-1]) s$obs <- rbind(s$obs, 0) rownames(s$obs)[nrow(s$obs)] <- perm[1] sa <- c(if (Nm > 1) s$mean else rowSums(s$mean), if (Ns > 1) Lower_tri(s$scale) else rowSums(Lower_tri(s$scale)), s$obs[LETTERS[1:J],]) sn <- grad(ll, prm, perm = perm[-1]) logLik(x, obs = obs[perm[-1],,drop = FALSE], standardize = TRUE) # lLgrad(x, obs = obs[perm[-1],,drop = FALSE], standardize = TRUE) ll(prm, perm = perm[-1], standardize = TRUE) s <- sc(prm, perm = perm[-1], standardize = TRUE) s$obs <- rbind(s$obs, 0) rownames(s$obs)[nrow(s$obs)] <- perm[1] sa <- c(if (Nm > 1) s$mean else rowSums(s$mean), if (Ns > 1) Lower_tri(s$scale) else rowSums(Lower_tri(s$scale)), s$obs[LETTERS[1:J],]) sn <- grad(ll, prm, perm = perm[-1], standardize = TRUE) chk(sa, sn) }) J <- 4 Ns <- 1 Nm <- 1 N <- 3 #max(Ns, Nm) BYROW <- FALSE CHOL <- FALSE EVAL(thischeck) J <- 4 Ns <- 3 Nm <- 3 N <- max(Ns, Nm) BYROW <- TRUE CHOL <- TRUE EVAL(thischeck) J <- 4 Ns <- 1 Nm <- 3 N <- max(Ns, Nm) BYROW <- TRUE CHOL <- TRUE EVAL(thischeck) J <- 4 Ns <- 3 Nm <- 1 N <- max(Ns, Nm) BYROW <- TRUE CHOL <- TRUE EVAL(thischeck) J <- 4 Ns <- 3 Nm <- 1 N <- max(Ns, Nm) BYROW <- TRUE CHOL <- FALSE EVAL(thischeck) J <- 4 Ns <- 3 Nm <- 3 N <- max(Ns, Nm) BYROW <- FALSE CHOL <- TRUE EVAL(thischeck) J <- 4 Ns <- 3 Nm <- 3 N <- max(Ns, Nm) BYROW <- FALSE CHOL <- FALSE EVAL(thischeck) J <- 4 Ns <- 3 Nm <- 3 N <- max(Ns, Nm) BYROW <- FALSE CHOL <- FALSE EVAL(thischeck) mvtnorm/tests/rmvnorm.R0000644000176200001440000000246414410602346014747 0ustar liggesusers library("mvtnorm") chk <- function(...) isTRUE(all.equal(...)) m <- 1:3 s <- diag(1:3) s[2,1] <- 1 s[3,1] <- 2 s[3,2] <- 3 s <- s+t(s) set.seed(1) x <- rmvnorm(10000, m, s) stopifnot(chk(m, colMeans(x), tolerance=0.01)) stopifnot(chk(s, var(x), tolerance=0.1)) x <- rmvnorm(10000, m, s, method="svd") stopifnot(chk(m, colMeans(x), tolerance=0.01)) stopifnot(chk(s, var(x), tolerance=0.1)) x <- rmvnorm(10000, m, s, method="chol") stopifnot(chk(m, colMeans(x), tolerance=0.01)) stopifnot(chk(s, var(x), tolerance=0.1)) ### suggested by Paul Johnson set.seed(29) x <- rmvnorm(2, sigma = diag(2)) set.seed(29) y <- rmvnorm(3, sigma = diag(2))[1:2,] stopifnot(chk(x, y)) ### Speed p <- 200 set.seed(17) rcond(Sig <- cov(matrix(rnorm((p+p)*p), ncol = p))) # 0.00286, ok mu <- 1:p set.seed(101) system.time(x <- rmvnorm(10000, mu, Sig)) stopifnot(chk(mu, colMeans(x), tolerance= 0.001), chk(Sig, cov(x), tolerance= 0.2)) set.seed(101) system.time(x <- rmvnorm(10000, mu, Sig, method="svd")) stopifnot(chk(mu, colMeans(x), tolerance= 0.001), chk(Sig, cov(x), tolerance= 0.2)) set.seed(101) system.time(x <- rmvnorm(10000, mu, Sig, method="chol")) ## 'chol' is 5-10 % faster than the other two stopifnot(chk(mu, colMeans(x), tolerance= 0.001), chk(Sig, cov(x), tolerance= 0.2)) mvtnorm/tests/regtest-scores.R0000644000176200001440000001523514422664046016230 0ustar liggesusers library("mvtnorm") set.seed(29081975) chk <- function(...) stopifnot(all.equal(..., tol = 1e-5, check.attributes = FALSE)) EVAL <- function(...) {} if (require("numDeriv", quietly = TRUE) && require("qrng", quietly = TRUE)) EVAL <- eval N <- 10 M <- 10000 MM <- M / N prb <- 1:3 / 4 ### chol thischeck <- expression({ J <- cJ + dJ W <- NULL if (dJ > 1) W <- t(ghalton(M, d = dJ - 1)) prm <- matrix(runif(J * (J - 1) / 2), ncol = 1) C <- ltMatrices(prm, byrow = BYROW) Z <- matrix(rnorm(J * N), ncol = N) Y <- Mult(C, Z) obs <- NULL if (cJ) obs <- Y[1:cJ,,drop = FALSE] lwr <- upr <- NULL if (dJ) { lwr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { qy <- quantile(y, prob = prb) c(-Inf, qy)[cut(y, breaks = c(-Inf, qy, Inf))] })) upr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { qy <- quantile(y, prob = prb) c(qy, Inf)[cut(y, breaks = c(-Inf, qy, Inf))] })) } ll <- function(prm) { C <- ltMatrices(prm, byrow = BYROW) -ldpmvnorm(obs = obs, lower = lwr, upper = upr, chol = C, M = MM, w = W) } sc <- function(prm) { C <- ltMatrices(prm, byrow = BYROW) ret <- sldpmvnorm(obs = obs, lower = lwr, upper = upr, chol = C, M = MM, w = W)$chol -rowSums(Lower_tri(ret)) } theta <- runif(J * (J - 1) / 2) print(ll(theta)) chk(grad(ll, theta), sc(theta)) }) BYROW <- FALSE cJ <- 4 dJ <- 4 EVAL(thischeck) cJ <- 1 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 1 EVAL(thischeck) cJ <- 0 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 0 EVAL(thischeck) BYROW <- TRUE cJ <- 4 dJ <- 4 EVAL(thischeck) cJ <- 1 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 1 EVAL(thischeck) cJ <- 0 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 0 EVAL(thischeck) ### invchol thischeck <- expression({ J <- cJ + dJ W <- NULL if (dJ > 1) W <- t(ghalton(M, d = dJ - 1)) prm <- matrix(runif(J * (J - 1) / 2), ncol = 1) C <- ltMatrices(prm, byrow = BYROW) Z <- matrix(rnorm(J * N), ncol = N) Y <- Mult(C, Z) obs <- NULL if (cJ) obs <- Y[1:cJ,,drop = FALSE] lwr <- upr <- NULL if (dJ) { lwr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { qy <- quantile(y, prob = prb) c(-Inf, qy)[cut(y, breaks = c(-Inf, qy, Inf))] })) upr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { qy <- quantile(y, prob = prb) c(qy, Inf)[cut(y, breaks = c(-Inf, qy, Inf))] })) } ll <- function(prm) { L <- ltMatrices(prm, byrow = BYROW) -ldpmvnorm(obs = obs, lower = lwr, upper = upr, invchol = L, M = MM, w = W) } sc <- function(prm) { L <- ltMatrices(prm, byrow = BYROW) ret <- sldpmvnorm(obs = obs, lower = lwr, upper = upr, invchol = L, M = MM, w = W)$invchol -rowSums(Lower_tri(ret)) } theta <- runif(J * (J - 1) / 2) C <- ltMatrices(matrix(theta, ncol = 1), byrow = BYROW) theta <- Lower_tri(solve(C)) print(ll(theta)) chk(grad(ll, theta), sc(theta)) }) BYROW <- FALSE cJ <- 4 dJ <- 4 EVAL(thischeck) cJ <- 1 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 1 EVAL(thischeck) cJ <- 0 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 0 EVAL(thischeck) BYROW <- TRUE cJ <- 4 dJ <- 4 EVAL(thischeck) cJ <- 1 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 1 EVAL(thischeck) cJ <- 0 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 0 EVAL(thischeck) ### chol standardized thischeck <- expression({ J <- cJ + dJ W <- NULL if (dJ > 1) W <- t(ghalton(M, d = dJ - 1)) prm <- matrix(runif(J * (J - 1) / 2), ncol = 1) C <- ltMatrices(prm) C <- ltMatrices(C, byrow = BYROW) Z <- matrix(rnorm(J * N), ncol = N) Y <- Mult(C, Z) obs <- NULL if (cJ) obs <- Y[1:cJ,,drop = FALSE] lwr <- upr <- NULL if (dJ) { lwr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { qy <- quantile(y, prob = prb) c(-Inf, qy)[cut(y, breaks = c(-Inf, qy, Inf))] })) upr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { qy <- quantile(y, prob = prb) c(qy, Inf)[cut(y, breaks = c(-Inf, qy, Inf))] })) } ll <- function(prm) { C <- ltMatrices(prm, byrow = BYROW) Cs <- standardize(chol = C) -ldpmvnorm(obs = obs, lower = lwr, upper = upr, chol = Cs, M = MM, w = W) } sc <- function(prm) { C <- ltMatrices(prm, byrow = BYROW) Cs <- standardize(chol = C) ret <- sldpmvnorm(obs = obs, lower = lwr, upper = upr, chol = Cs, M = MM, w = W)$chol ret <- destandardize(chol = C, score_schol = ret) -rowSums(Lower_tri(ret)) } theta <- runif(J * (J - 1) / 2) print(ll(theta)) chk(grad(ll, theta), sc(theta)) }) BYROW <- FALSE cJ <- 4 dJ <- 4 EVAL(thischeck) cJ <- 1 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 1 EVAL(thischeck) cJ <- 0 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 0 EVAL(thischeck) BYROW <- TRUE cJ <- 4 dJ <- 4 EVAL(thischeck) cJ <- 1 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 1 EVAL(thischeck) cJ <- 0 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 0 EVAL(thischeck) ### invchol standardized thischeck <- expression({ J <- cJ + dJ W <- NULL if (dJ > 1) W <- t(ghalton(M, d = dJ - 1)) prm <- matrix(runif(J * (J - 1) / 2), ncol = 1) C <- ltMatrices(prm, byrow = BYROW) Z <- matrix(rnorm(J * N), ncol = N) Y <- Mult(C, Z) obs <- NULL if (cJ) obs <- Y[1:cJ,,drop = FALSE] lwr <- upr <- NULL if (dJ) { lwr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { qy <- quantile(y, prob = prb) c(-Inf, qy)[cut(y, breaks = c(-Inf, qy, Inf))] })) upr <- t(apply(Y[cJ + (1:dJ),,drop = FALSE], 1, function(y) { qy <- quantile(y, prob = prb) c(qy, Inf)[cut(y, breaks = c(-Inf, qy, Inf))] })) } ll <- function(prm) { L <- ltMatrices(prm, byrow = BYROW) Ls <- standardize(invchol = L) -ldpmvnorm(obs = obs, lower = lwr, upper = upr, invchol = Ls, M = MM, w = W) } sc <- function(prm) { L <- ltMatrices(prm, byrow = BYROW) Cs <- standardize(chol = solve(L)) ret <- sldpmvnorm(obs = obs, lower = lwr, upper = upr, chol = Cs, M = MM, w = W)$chol ret <- destandardize(invchol = L, score_schol = ret) -rowSums(Lower_tri(ret)) } theta <- runif(J * (J - 1) / 2) C <- ltMatrices(matrix(theta, ncol = 1), byrow = BYROW) theta <- Lower_tri(solve(C)) print(ll(theta)) chk(grad(ll, theta), sc(theta)) }) BYROW <- FALSE cJ <- 4 dJ <- 4 EVAL(thischeck) cJ <- 1 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 1 EVAL(thischeck) cJ <- 0 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 0 EVAL(thischeck) BYROW <- TRUE cJ <- 4 dJ <- 4 EVAL(thischeck) cJ <- 1 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 1 EVAL(thischeck) cJ <- 0 dJ <- 4 EVAL(thischeck) cJ <- 4 dJ <- 0 EVAL(thischeck) mvtnorm/tests/test-noisy-root.Rout.save0000644000176200001440000000514414172227731020037 0ustar liggesusers R Under development (unstable) (2019-02-28 r76174) -- "Unsuffered Consequences" Copyright (C) 2019 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("mvtnorm") > > set.seed(1) > dim <- 10 > df <- 5 > > D <- diag(dim)+crossprod(matrix(runif(25,-1,1),dim,dim)) > corr <- cov2cor(D) > > ## one-sided, lower tail > qu <- qmvt(0.95, df=df, corr=corr)$quantile > pmvt(lower=rep(-Inf, dim), upper=rep(qu,dim), corr=corr, df=df) [1] 0.9499886 attr(,"error") [1] 8.394993e-05 attr(,"msg") [1] "Normal Completion" > > qu <- qmvnorm(0.95, corr=corr)$quantile > pmvnorm(lower=rep(-Inf, dim), upper=rep(qu,dim), corr=corr) [1] 0.9499785 attr(,"error") [1] 6.265055e-05 attr(,"msg") [1] "Normal Completion" > > ## two-sided > qu <- qmvt(0.95, df=df, corr=corr, tail="both.tails")$quantile > pmvt(lower=rep(-qu, dim), upper=rep(qu,dim), corr=corr, df=df) [1] 0.949925 attr(,"error") [1] 9.635837e-05 attr(,"msg") [1] "Normal Completion" > > qu <- qmvnorm(0.95, corr=corr, tail="both.tails")$quantile > pmvnorm(lower=rep(-qu, dim), upper=rep(qu,dim), corr=corr) [1] 0.949927 attr(,"error") [1] 0.0001545113 attr(,"msg") [1] "Normal Completion" > > ## one-sided, upper tail > qu <- qmvt(0.95, df=df, corr=corr, tail="upper.tail")$quantile > pmvt(lower=rep(qu, dim), upper=rep(Inf,dim), corr=corr, df=df) [1] 0.9499528 attr(,"error") [1] 9.714629e-05 attr(,"msg") [1] "Normal Completion" > > qu <- qmvnorm(0.95, corr=corr, tail="upper.tail")$quantile > pmvnorm(lower=rep(qu, dim), upper=rep(Inf,dim), corr=corr) [1] 0.9500897 attr(,"error") [1] 7.617415e-05 attr(,"msg") [1] "Normal Completion" > > ## cross-check interval works > ## one-sided, lower tail > qu <- qmvt(0.95, df=df , corr=corr, interval=c(0,10))$quantile > pmvt(lower=rep(-Inf, dim), upper=rep(qu,dim), corr=corr, df=df) [1] 0.9500624 attr(,"error") [1] 0.0001741215 attr(,"msg") [1] "Normal Completion" > > qu <- qmvnorm(0.95, corr=corr, interval=c(0,10))$quantile > pmvnorm(lower=rep(-Inf, dim), upper=rep(qu,dim), corr=corr) [1] 0.9500022 attr(,"error") [1] 9.231686e-05 attr(,"msg") [1] "Normal Completion" > > proc.time() user system elapsed 14.736 0.052 14.783 mvtnorm/tests/regtest-aperm.R0000644000176200001440000001435214662070542016033 0ustar liggesusers library("mvtnorm") library("numDeriv") options(digits = 3) tol <- 1e-1 set.seed(29) EVAL <- function(...) {} if (require("numDeriv", quietly = TRUE)) EVAL <- eval chk <- function(...) stopifnot(isTRUE(all.equal(..., check.attributes = FALSE, tol = sqrt(sqrt(.Machine$double.eps))))) thischeck <- expression({ J <- 5 p <- sample(1:J) if (isTRUE(all.equal(p, 1:J))) warning("Checks for id permutation meaningless") P <- matrix(0, nrow = J, ncol = J) P[cbind(1:J, p)] <- 1 L <- as.invchol(ltMatrices(1 + runif(J * (J + 1) / 2), diag = TRUE, byrow = BYROW)) mL <- as.array(L)[,,1] S <- invchol2cov(L) mS <- as.array(S)[,,1] mSp <- mS[p,p] chk(P %*% mS %*% t(P), mSp) O <- invchol2pre(L) mO <- as.array(O)[,,1] chk(solve(P %*% mO %*% t(P)), mSp) chk(solve(P %*% t(mL) %*% mL %*% t(P)), mSp) C <- invchol2chol(L) mC <- as.array(C)[,,1] chk(P %*% mC %*% t(mC) %*% t(P), mSp) Ct <- t(chol(mS[p,p])) chk(Ct %*% t(Ct), mSp) chk(as.array(invchol2cov(aperm(L, perm = p)))[,,1], mSp) chk(as.array(chol2cov(aperm(C, perm = p)))[,,1], mSp) N <- 10000 obs <- matrix(rnorm(J * N), ncol = N) obs <- Mult(C, obs) ll1 <- ldmvnorm(obs = obs, chol = C) ll2 <- ldmvnorm(obs = obs[p,], chol = aperm(C, perm = p)) ll3 <- ldmvnorm(obs = obs, invchol = L) ll4 <- ldmvnorm(obs = obs[p,], invchol = aperm(L, perm = p)) chk(ll1, ll2) chk(ll1, ll3) chk(ll1, ll4) ### C ### diag = TRUE w/o stand ll <- function(x) { C <- as.chol(ltMatrices(x, diag = TRUE, byrow = BYROW)) Ct <- aperm(C, perm = p) -ldmvnorm(obs = obs[p,], chol = Ct) } s <- function(x) { C <- as.chol(ltMatrices(x, diag = TRUE, byrow = BYROW)) Ct <- aperm(C, perm = p) sC <- sldmvnorm(obs = obs[p,], chol = Ct)$chol ret <- deperma(chol = C, permuted_chol = Ct, perm = p, score_schol = sC) -rowSums(Lower_tri(ret, diag = TRUE)) } g1 <- grad(ll, c(C)) s1 <- s(c(C)) chk(g1, s1) op1 <- optim(c(C), fn = ll, gr = s, method = "L-BFGS-B") max(abs(ltMatrices(op1$par, diag = TRUE, byrow = BYROW) - C)) ### check against unpermuted (expect same results) ll <- function(x) { C <- ltMatrices(x, diag = TRUE, byrow = BYROW) -ldmvnorm(obs = obs, chol = C) } s <- function(x) { C <- ltMatrices(x, diag = TRUE, byrow = BYROW) ret <- sldmvnorm(obs = obs, chol = C)$chol -rowSums(Lower_tri(ret, diag = TRUE)) } op2 <- optim(c(C), fn = ll, gr = s, method = "L-BFGS-B") chk(max(abs(ltMatrices(op2$par, diag = TRUE, byrow = BYROW) - C)) < tol, TRUE) chk(op1, op2) ### diag = FALSE Cd <- ltMatrices(runif(J * (J - 1) / 2), byrow = BYROW) ### w/ standardisation (1. stand, 2. perm) ll <- function(x) { C <- as.chol(ltMatrices(x, diag = FALSE, byrow = BYROW)) Cs <- standardize(chol = C) Ct <- aperm(Cs, perm = p) -ldmvnorm(obs = obs[p,], chol = Ct) } s <- function(x) { C <- ltMatrices(x, diag = FALSE, byrow = BYROW) Cs <- standardize(chol = C) Ct <- aperm(Cs, perm = p) sC <- sldmvnorm(obs = obs[p,], chol = Ct)$chol ret <- deperma(chol = Cs, permuted_chol = Ct, perm = p, score_schol = sC) ret <- destandardize(chol = C, score_schol = ret) -rowSums(Lower_tri(ret, diag = FALSE)) } chk(grad(ll, c(Cd)), s(c(Cd))) ### w/o standardisation ll <- function(x) { C <- as.chol(ltMatrices(x, diag = FALSE, byrow = BYROW)) Ct <- aperm(C, perm = p) -ldmvnorm(obs = obs[p,], chol = Ct) } s <- function(x) { C <- as.chol(ltMatrices(x, diag = FALSE, byrow = BYROW)) diagonals(C) <- 1 ### deperma expects diagonals Ct <- aperm(as.chol(C), perm = p) sC <- sldmvnorm(obs = obs[p,], chol = Ct)$chol ret <- deperma(chol = C, permuted_chol = Ct, perm = p, score_schol = sC) -rowSums(Lower_tri(ret, diag = FALSE)) } chk(grad(ll, c(Cd)), s(c(Cd))) ### L ### diag = TRUE w/o stand ll <- function(x) { C <- as.invchol(ltMatrices(x, diag = TRUE, byrow = BYROW)) Ct <- aperm(C, perm = p) -ldmvnorm(obs = obs[p,], invchol = Ct) } s <- function(x) { C <- as.invchol(ltMatrices(x, diag = TRUE, byrow = BYROW)) Ct <- aperm(C, perm = p) sC <- sldmvnorm(obs = obs[p,], invchol = Ct)$invchol ret <- deperma(invchol = C, permuted_invchol = Ct, perm = p, score_schol = -vectrick(Ct, sC)) -rowSums(Lower_tri(ret, diag = TRUE)) } g2 <- grad(ll, c(L)) chk(g2, s(c(L))) chk(g2, c(Lower_tri(-vectrick(C, ltMatrices(g1, byrow = BYROW, diag = TRUE)), diag = TRUE))) op3 <- optim(c(L), fn = ll, gr = s, method = "L-BFGS-B") chk(max(abs(ltMatrices(op3$par, diag = TRUE, byrow = BYROW) - L)) < tol, TRUE) ### check against unpermuted (expect same results) ll <- function(x) { C <- ltMatrices(x, diag = TRUE, byrow = BYROW) -ldmvnorm(obs = obs, invchol = C) } s <- function(x) { C <- ltMatrices(x, diag = TRUE, byrow = BYROW) ret <- sldmvnorm(obs = obs, invchol = C)$invchol -rowSums(Lower_tri(ret, diag = TRUE)) } op4 <- optim(c(L), fn = ll, gr = s, method = "L-BFGS-B") chk(max(abs(ltMatrices(op4$par, diag = TRUE, byrow = BYROW) - L)) < tol, TRUE) ### diag = FALSE Ld <- ltMatrices(runif(J * (J - 1) / 2), byrow = BYROW) ### w/ standardisation (1. stand, 2. perm) ll <- function(x) { C <- as.invchol(ltMatrices(x, diag = FALSE, byrow = BYROW)) Cs <- standardize(invchol = C) Ct <- aperm(Cs, perm = p) -ldmvnorm(obs = obs[p,], invchol = Ct) } s <- function(x) { C <- as.invchol(ltMatrices(x, diag = FALSE, byrow = BYROW)) Cs <- standardize(invchol = C) Ct <- aperm(Cs, perm = p) sC <- sldmvnorm(obs = obs[p,], invchol = Ct)$invchol ret <- deperma(invchol = Cs, permuted_invchol = Ct, perm = p, score_schol = -vectrick(Ct, sC)) ret <- destandardize(invchol = C, score_schol = -vectrick(Cs, ret)) -rowSums(Lower_tri(ret, diag = FALSE)) } chk(grad(ll, c(Ld)), s(c(Ld))) ### w/o standardisation ll <- function(x) { C <- as.invchol(ltMatrices(x, diag = FALSE, byrow = BYROW)) Ct <- aperm(C, perm = p) -ldmvnorm(obs = obs[p,], invchol = Ct) } s <- function(x) { C <- as.invchol(ltMatrices(x, diag = FALSE, byrow = BYROW)) diagonals(C) <- 1 ### deperma expects diagonals Ct <- aperm(as.invchol(C), perm = p) sC <- sldmvnorm(obs = obs[p,], invchol = Ct)$invchol ret <- deperma(invchol = C, permuted_invchol = Ct, perm = p, score_schol = -vectrick(Ct, sC)) -rowSums(Lower_tri(ret, diag = FALSE)) } chk(grad(ll, c(Ld)), s(c(Ld))) }) BYROW <- FALSE EVAL(thischeck) BYROW <- TRUE EVAL(thischeck) mvtnorm/tests/plmvnorm-Ex.R0000644000176200001440000000334114437561317015501 0ustar liggesusers library("mvtnorm") pmvnorm <- function(lower = -Inf, upper = Inf, mean = rep(0, length(lower)), corr = NULL, sigma = NULL, algorithm = GenzBretz(), ...) { if (!inherits(algorithm, "GenzBretz")) return(mvtnorm::pmvnorm(lower = lower, upper = upper, mean = mean, sigma = sigma, corr = corr, algorithm = algorithm, ...)) args <- mvtnorm:::checkmvArgs(lower = lower, upper = upper, mean = mean, sigma = sigma, corr = corr) if (args$uni) return(mvtnorm::pmvnorm(lower = lower, upper = upper, mean = mean, sigma = sigma, corr = corr, algorithm = algorithm, ...)) if (!is.null(args$corr)) args$sigma <- args$corr Chol <- try(chol(args$sigma), silent = TRUE) if (inherits(Chol, "try-error")) return(mvtnorm::pmvnorm(lower = lower, upper = upper, mean = mean, sigma = sigma, corr = corr, algorithm = algorithm, ...)) Chol <- matrix(t(Chol)[lower.tri(Chol, diag = TRUE)], ncol = 1) Chol <- ltMatrices(Chol, diag = TRUE, byrow = FALSE) args$chol <- Chol M <- algorithm$maxpts if (require("qrng", quietly = TRUE)) { w <- t(ghalton(M, d = length(args$lower) - 1)) } else { w <- NULL } args$w <- w args$M <- M args$seed <- 290875 args$logLik <- FALSE args$corr <- args$sigma <- args$uni <- NULL args$lower <- matrix(args$lower, ncol = 1) args$upper <- matrix(args$upper, ncol = 1) ret <- exp(do.call("lpmvnorm", args)) ret[ret < .Machine$double.eps] <- 0 ret } try(source("regtest-TVPACK.R", echo = TRUE)) try(source("test-noisy-root.R", echo = TRUE)) try(source("bugfix-tests.R", echo = TRUE)) mvtnorm/tests/test-getInt.R0000644000176200001440000000401214172227731015453 0ustar liggesuserslibrary("mvtnorm") p <- 0.8 mean <- c(6.75044368, 0.04996326) sigmas <- rbind( c(0.10260550, 0.02096418), c(0.02096418, 0.16049956) ) ## qmvnorm qmvnorm(p = p, tail = "lower.tail", mean = mean, sigma = sigmas, interval=c(5,8))$quantile qmvnorm(p = p, tail = "upper.tail", mean = mean, sigma = sigmas, interval=c(-0.5,0))$quantile qmvnorm(p = p, tail = "both.tails", mean = mean, sigma = sigmas, interval=c(5,8))$quantile mvtnorm:::getInt(p,delta=mean, sigma=sigmas,tail="lower.tail",df=Inf) mvtnorm:::getInt(p,delta=mean, sigma=sigmas,tail="upper.tail",df=Inf) mvtnorm:::getInt(p,delta=mean, sigma=sigmas,tail="both.tails",df=Inf) ## qmvt, shifted qmvt(p = p, tail = "lower.tail", delta = mean, sigma = sigmas, interval=c(5,8), df=1, type="shifted")$quantile qmvt(p = p, tail = "upper.tail", delta = mean, sigma = sigmas, interval=c(-0.5,0), df=1, type="shifted")$quantile qmvt(p = p, tail = "both.tails", delta = mean, sigma = sigmas, interval=c(5,8), df=1, type="shifted")$quantile mvtnorm:::getInt(p,delta=mean, sigma=sigmas,tail="lower.tail", type="shifted",df=1) mvtnorm:::getInt(p,delta=mean, sigma=sigmas,tail="upper.tail", type="shifted",df=1) mvtnorm:::getInt(p,delta=mean, sigma=sigmas,tail="both.tails", type="shifted",df=1) ## qmvt, Kshirsagar sigmas <- cov2cor(sigmas) ## use unit variances qmvt(p = p, tail = "lower.tail", delta = mean, sigma = sigmas, interval=c(5,8), df=1, type="Kshirsagar")$quantile qmvt(p = p, tail = "upper.tail", delta = mean, sigma = sigmas, interval=c(-4,0), df=1, type="Kshirsagar")$quantile qmvt(p = p, tail = "both.tails", delta = mean, sigma = sigmas, interval=c(5,8), df=1, type="Kshirsagar")$quantile mvtnorm:::getInt(p,delta=mean, sigma=sigmas,tail="lower.tail", type="Kshirsagar",df=1) ##mvtnorm:::getInt(p,delta=mean, sigma=sigmas,tail="upper.tail", ## type="Kshirsagar",df=1) # will produce warnings mvtnorm:::getInt(p,delta=mean, sigma=sigmas,tail="both.tails", type="Kshirsagar",df=1) mvtnorm/tests/plmvnorm-Ex.Rout.save0000644000176200001440000005616014623074726017175 0ustar liggesusers R version 4.3.0 (2023-04-21) -- "Already Tomorrow" Copyright (C) 2023 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > > library("mvtnorm") > > pmvnorm <- function(lower = -Inf, upper = Inf, mean = rep(0, length(lower)), + corr = NULL, sigma = NULL, algorithm = GenzBretz(), ...) { + + if (!inherits(algorithm, "GenzBretz")) + return(mvtnorm::pmvnorm(lower = lower, upper = upper, mean = mean, + sigma = sigma, corr = corr, algorithm = algorithm, ...)) + + args <- mvtnorm:::checkmvArgs(lower = lower, upper = upper, mean = mean, + sigma = sigma, corr = corr) + if (args$uni) + return(mvtnorm::pmvnorm(lower = lower, upper = upper, mean = mean, + sigma = sigma, corr = corr, algorithm = algorithm, ...)) + + if (!is.null(args$corr)) args$sigma <- args$corr + + Chol <- try(chol(args$sigma), silent = TRUE) + if (inherits(Chol, "try-error")) + return(mvtnorm::pmvnorm(lower = lower, upper = upper, mean = mean, + sigma = sigma, corr = corr, algorithm = algorithm, ...)) + Chol <- matrix(t(Chol)[lower.tri(Chol, diag = TRUE)], ncol = 1) + Chol <- ltMatrices(Chol, diag = TRUE, byrow = FALSE) + + args$chol <- Chol + + M <- algorithm$maxpts + if (require("qrng", quietly = TRUE)) { + w <- t(ghalton(M, d = length(args$lower) - 1)) + } else { + w <- NULL + } + args$w <- w + args$M <- M + args$seed <- 290875 + args$logLik <- FALSE + args$corr <- args$sigma <- args$uni <- NULL + args$lower <- matrix(args$lower, ncol = 1) + args$upper <- matrix(args$upper, ncol = 1) + + ret <- exp(do.call("lpmvnorm", args)) + ret[ret < .Machine$double.eps] <- 0 + ret + } > > try(source("regtest-TVPACK.R", echo = TRUE)) > library("mvtnorm") > chk <- function(...) isTRUE(all.equal(...)) > (cor1 <- toeplitz(c(1, 1/4, -1/8))) [,1] [,2] [,3] [1,] 1.000 0.25 -0.125 [2,] 0.250 1.00 0.250 [3,] -0.125 0.25 1.000 > (up1 <- c(1/4, 7/4, 5/8)) [1] 0.250 1.750 0.625 > d <- length(up1) > pmvt.. <- function(df, algorithm) vapply(df, function(df) pmvt(upper = up1, + corr = cor1, df = df, algorithm = algorithm), numeric(1)) > dfs <- 1:9 > pmvt_TV.7 <- replicate(7, pmvt..(dfs, TVPACK())) > stopifnot(identical(unique(c(pmvt_TV.7 - pmvt_TV.7[, + 1])), 0)) > (pmvt.TV. <- pmvt_TV.7[, 1]) [1] 0.3554119 0.3817313 0.3923546 0.3980570 0.4016042 0.4040204 0.4057708 [8] 0.4070968 0.4081358 > (pmvt.TV <- pmvt..(dfs, TVPACK(1e-14))) [1] 0.3554119 0.3817313 0.3923546 0.3980570 0.4016042 0.4040204 0.4057708 [8] 0.4070968 0.4081358 > chk(max(abs(pmvt.TV - pmvt.TV.)), 0) [1] TRUE > set.seed(47) > pmvt_7 <- replicate(7, vapply(dfs, function(df) pmvt(df = df, + upper = up1, corr = cor1), numeric(1))) > relE <- 1 - pmvt_7/pmvt.TV > rng.rE <- range(abs(relE)) > stopifnot(1e-06 < rng.rE[1], rng.rE[2] < 7e-04) > stopifnot(chk(colMeans(abs(relE)), c(88, 64, 105, + 73, 52, 90, 87) * 1e-06, tol = 0.001)) > set.seed(29) > corr <- cov2cor(crossprod(matrix(runif(9, -1, 1), + 3, 3)) + diag(3)) > df <- rpois(1, 3) + 1 > ctrl <- GenzBretz(maxpts = 2500000, abseps = 1e-06, + releps = 0) > upper <- rexp(3, 1) > pmvt(upper = upper, corr = corr, df = df, algorithm = ctrl) [1] 0.3920567 attr(,"error") [1] 6.089669e-07 attr(,"msg") [1] "Normal Completion" > pmvt(upper = upper, corr = corr, df = df, algorithm = TVPACK()) [1] 0.3920566 attr(,"error") [1] 1e-06 attr(,"msg") [1] "Normal Completion" > lower <- -rexp(3, 1) > pmvt(lower = lower, upper = rep(Inf, 3), corr = corr, + df = df, algorithm = ctrl) [1] 0.4634843 attr(,"error") [1] 6.46065e-07 attr(,"msg") [1] "Normal Completion" > pmvt(lower = lower, upper = rep(Inf, 3), corr = corr, + df = df, algorithm = TVPACK()) [1] 0.4634844 attr(,"error") [1] 1e-06 attr(,"msg") [1] "Normal Completion" > delt <- rexp(3, 1/10) > upper <- delt + runif(3) > ctrl <- GenzBretz(maxpts = 2500000, abseps = 1e-06, + releps = 0) > pmvt(upper = upper, corr = corr, df = df, algorithm = ctrl, + delta = delt) [1] 0.3235424 attr(,"error") [1] 9.86407e-07 attr(,"msg") [1] "Normal Completion" > tools::assertError(pmvt(upper = upper, corr = corr, + df = df, algorithm = TVPACK(), delta = delt)) > upper <- rexp(3, 1) > pmvnorm(upper = upper, corr = corr, algorithm = ctrl) [1] 0.7733946 > pmvnorm(upper = upper, corr = corr, algorithm = TVPACK()) [1] 0.7733949 attr(,"error") [1] 1e-06 attr(,"msg") [1] "Normal Completion" > lower <- rexp(3, 5) > pmvnorm(lower = lower, upper = rep(Inf, 3), corr = corr, + algorithm = ctrl) [1] 0.07507118 > pmvnorm(lower = lower, upper = rep(Inf, 3), corr = corr, + algorithm = TVPACK()) [1] 0.07507119 attr(,"error") [1] 1e-06 attr(,"msg") [1] "Normal Completion" > delt <- rexp(3, 1/10) > upper <- delt + rexp(3, 1) > pmvnorm(upper = upper, corr = corr, algorithm = ctrl, + mean = delt) [1] 0.3986757 > pmvnorm(upper = upper, corr = corr, algorithm = TVPACK(), + mean = delt) [1] 0.3986758 attr(,"error") [1] 1e-06 attr(,"msg") [1] "Normal Completion" > corr <- cov2cor(crossprod(matrix(runif(4, -1, 1), + 2, 2)) + diag(2)) > upper <- rexp(2, 1) > df <- rpois(1, runif(1, 0, 20)) > pmvt(upper = upper, corr = corr, df = df, algorithm = ctrl) [1] 0.4565892 attr(,"error") [1] 1e-15 attr(,"msg") [1] "Normal Completion" > pmvt(upper = upper, corr = corr, df = df, algorithm = TVPACK()) [1] 0.4565892 attr(,"error") [1] NA attr(,"msg") [1] "Normal Completion" > pmvt(lower = -upper, upper = rep(Inf, 2), corr = corr, + df = df, algorithm = ctrl) [1] 0.4565892 attr(,"error") [1] 1e-15 attr(,"msg") [1] "Normal Completion" > pmvt(lower = -upper, upper = rep(Inf, 2), corr = corr, + df = df, algorithm = TVPACK()) [1] 0.4565892 attr(,"error") [1] NA attr(,"msg") [1] "Normal Completion" > delt <- rexp(2, 1/5) > upper <- delt + rexp(2, 1) > pmvnorm(upper = upper, corr = corr, algorithm = ctrl, + mean = delt) [1] 0.320247 > pmvnorm(upper = upper, corr = corr, algorithm = TVPACK(), + mean = delt) [1] 0.320247 attr(,"error") [1] NA attr(,"msg") [1] "Normal Completion" > corr <- cov2cor(crossprod(matrix(runif(4, -1, 1), + 2, 2)) + diag(2)) > upper <- rexp(2, 1) > pmvnorm(upper = upper, corr = corr, algorithm = Miwa(steps = 128)) [1] 0.4466655 attr(,"error") [1] NA attr(,"msg") [1] "Normal Completion" > pmvnorm(upper = upper, corr = corr, algorithm = TVPACK()) [1] 0.4466655 attr(,"error") [1] NA attr(,"msg") [1] "Normal Completion" > corr <- cov2cor(crossprod(matrix(runif(9, -1, 1), + 3, 3)) + diag(3)) > upper <- rexp(3, 1) > ctrl <- Miwa(steps = 128) > pmvnorm(upper = upper, corr = corr, algorithm = ctrl) [1] 0.4499242 attr(,"error") [1] NA attr(,"msg") [1] "Normal Completion" > pmvnorm(upper = upper, corr = corr, algorithm = TVPACK()) [1] 0.4499242 attr(,"error") [1] 1e-06 attr(,"msg") [1] "Normal Completion" > S <- toeplitz(c(1, 1/2, 1/4)) > set.seed(11) > P0 <- pmvnorm(lower = c(-Inf, 0, 0), upper = Inf, + corr = S) > P1 <- pmvnorm(lower = c(-Inf, 0, 0), upper = Inf, + corr = S, algorithm = TVPACK()) > P2 <- pmvnorm(lower = c(-Inf, 0, 0), upper = Inf, + corr = S, algorithm = Miwa()) > P2a <- pmvnorm(lower = c(-Inf, 0, 0), upper = Inf, + corr = S, algorithm = Miwa(512)) > P2. <- pmvnorm(lower = c(-Inf, 0, 0), upper = Inf, + corr = S, algorithm = Miwa(2048)) > stopifnot(chk(1/3, c(P0), tol = 1e-14), chk(1/3, c(P1), + tol = 1e-14), chk(1/3, c(P2), tol = 1e-09), chk(1/3, c(P2a), + tol = 4e-12), chk .... [TRUNCATED] Error : chk(1/3, c(P0), tol = 1e-14) is not TRUE > try(source("test-noisy-root.R", echo = TRUE)) > library("mvtnorm") > set.seed(1) > dim <- 10 > df <- 5 > D <- diag(dim) + crossprod(matrix(runif(25, -1, 1), + dim, dim)) > corr <- cov2cor(D) > qu <- qmvt(0.95, df = df, corr = corr)$quantile > pmvt(lower = rep(-Inf, dim), upper = rep(qu, dim), + corr = corr, df = df) [1] 0.9499886 attr(,"error") [1] 8.394993e-05 attr(,"msg") [1] "Normal Completion" > qu <- qmvnorm(0.95, corr = corr)$quantile > pmvnorm(lower = rep(-Inf, dim), upper = rep(qu, dim), + corr = corr) [1] 0.949977 > qu <- qmvt(0.95, df = df, corr = corr, tail = "both.tails")$quantile > pmvt(lower = rep(-qu, dim), upper = rep(qu, dim), + corr = corr, df = df) [1] 0.9500024 attr(,"error") [1] 0.0001403885 attr(,"msg") [1] "Normal Completion" > qu <- qmvnorm(0.95, corr = corr, tail = "both.tails")$quantile > pmvnorm(lower = rep(-qu, dim), upper = rep(qu, dim), + corr = corr) [1] 0.9500143 > qu <- qmvt(0.95, df = df, corr = corr, tail = "upper.tail")$quantile > pmvt(lower = rep(qu, dim), upper = rep(Inf, dim), + corr = corr, df = df) [1] 0.9499675 attr(,"error") [1] 0.0001052159 attr(,"msg") [1] "Normal Completion" > qu <- qmvnorm(0.95, corr = corr, tail = "upper.tail")$quantile > pmvnorm(lower = rep(qu, dim), upper = rep(Inf, dim), + corr = corr) [1] 0.9500265 > qu <- qmvt(0.95, df = df, corr = corr, interval = c(0, + 10))$quantile > pmvt(lower = rep(-Inf, dim), upper = rep(qu, dim), + corr = corr, df = df) [1] 0.950041 attr(,"error") [1] 0.000113758 attr(,"msg") [1] "Normal Completion" > qu <- qmvnorm(0.95, corr = corr, interval = c(0, 10))$quantile > pmvnorm(lower = rep(-Inf, dim), upper = rep(qu, dim), + corr = corr) [1] 0.9499789 > try(source("bugfix-tests.R", echo = TRUE)) > invisible(options(echo = TRUE)) > library("mvtnorm") > set.seed(290875) > chk <- function(...) isTRUE(all.equal(...)) > a <- 4.048 > shi <- -9 > slo <- -10 > mu <- -5 > sig <- matrix(c(1, 1, 1, 2), ncol = 2) > pmvnorm(lower = c(-a, slo), upper = c(a, shi), mean = c(mu, + 2 * mu), sigma = sig) [1] 0.04210637 > n <- 5 > lower <- -1 > upper <- 3 > df <- 4 > corr <- diag(5) > corr[lower.tri(corr)] <- 0.5 > delta <- rep(0, 5) > set.seed(290875) > prob1 <- pmvt(lower = lower, upper = upper, delta = delta, + df = df, corr = corr) > set.seed(290875) > prob2 <- pmvt(lower = lower, upper = upper, delta = delta, + df = df, corr = corr) > stopifnot(chk(prob1, prob2)) > a <- pmvnorm(lower = -Inf, upper = 2, mean = 0, sigma = matrix(1.5)) > attributes(a) <- NULL > stopifnot(chk(a, pnorm(2, sd = sqrt(1.5)))) > a <- pmvnorm(lower = -Inf, upper = 2, mean = 0, sigma = matrix(0.5)) > attributes(a) <- NULL > stopifnot(chk(a, pnorm(2, sd = sqrt(0.5)))) > a <- pmvnorm(lower = -Inf, upper = 2, mean = 0, sigma = 0.5) > attributes(a) <- NULL > stopifnot(chk(a, pnorm(2, sd = sqrt(0.5)))) > dmvnorm(x = c(0, 0), mean = c(1, 1), log = TRUE) [1] -2.837877 > dmvnorm(x = c(0, 0), mean = c(25, 25), log = TRUE) [1] -626.8379 > dmvnorm(x = c(0, 0), mean = c(30, 30), log = TRUE) [1] -901.8379 > stopifnot(chk(dmvnorm(x = 0, mean = 30, log = TRUE), + dnorm(0, 30, log = TRUE))) > stopifnot(chk(f. <- dmvnorm(x = c(0, 0), mean = c(30, + 30), log = TRUE), dmvt(x = c(0, 0), delta = c(30, 30), log = TRUE, + df = Inf)), c .... [TRUNCATED] > pnorm(2)^2 [1] 0.9550173 > pmvt(lower = c(-Inf, -Inf), upper = c(2, 2), delta = c(0, + 0), df = 25, corr = diag(2)) [1] 0.9446454 attr(,"error") [1] 1e-15 attr(,"msg") [1] "Normal Completion" > pmvt(lower = c(-Inf, -Inf), upper = c(2, 2), delta = c(0, + 0), df = 250, corr = diag(2)) [1] 0.9539846 attr(,"error") [1] 1e-15 attr(,"msg") [1] "Normal Completion" > pmvt(lower = c(-Inf, -Inf), upper = c(2, 2), delta = c(0, + 0), df = 1340, corr = diag(2)) [1] 0.9548248 attr(,"error") [1] 1e-15 attr(,"msg") [1] "Normal Completion" > pmvt(lower = c(-Inf, -Inf), upper = c(2, 2), delta = c(0, + 0), df = 2500, corr = diag(2)) [1] 0.9549141 attr(,"error") [1] 1e-15 attr(,"msg") [1] "Normal Completion" > pmvt(lower = c(-100, -100), upper = c(2, 2), delta = c(0, + 0), df = 2500, corr = diag(2)) [1] 0.9549141 attr(,"error") [1] 1e-15 attr(,"msg") [1] "Normal Completion" > pmvt(lower = c(-Inf, -Inf), upper = c(2, 2), delta = c(0, + 0), df = 0, corr = diag(2)) [1] 0.9550173 attr(,"error") [1] 1e-15 attr(,"msg") [1] "Normal Completion" > pmvt(lower = -Inf, upper = 2, delta = 0, df = 0, corr = 1) upper 0.9772499 attr(,"error") [1] 0 attr(,"msg") [1] "univariate: using pnorm" > pnorm(2) [1] 0.9772499 > pnorm(2)^2 [1] 0.9550173 > pmvnorm(lower = rep(-Inf, 2), upper = rep(2, 2), sigma = diag(2)) [1] 0.9550173 > pnorm(2)^90 [1] 0.1260393 > pmvnorm(lower = rep(-Inf, 90), upper = rep(2, 90), + sigma = diag(90)) [1] 0.1260393 > pnorm(2)^199 [1] 0.01025932 > pmvnorm(lower = rep(-Inf, 199), upper = rep(2, 199), + sigma = diag(199)) [1] 0.01025932 > cr = matrix(0.5, nr = 4, nc = 4) > diag(cr) = 1 > cr [,1] [,2] [,3] [,4] [1,] 1.0 0.5 0.5 0.5 [2,] 0.5 1.0 0.5 0.5 [3,] 0.5 0.5 1.0 0.5 [4,] 0.5 0.5 0.5 1.0 > a <- pmvt(low = -rep(1, 4), upp = rep(1, 4), df = 999, + corr = cr) > b <- pmvt(low = -rep(1, 4), upp = rep(1, 4), df = 4999, + corr = cr) > b [1] 0.2892618 attr(,"error") [1] 0.000110303 attr(,"msg") [1] "Normal Completion" > attributes(a) <- NULL > attributes(b) <- NULL > stopifnot(chk(round(a, 3), round(b, 3))) > stopifnot(chk(c(pmvnorm(upper = c(-Inf, 1))), 0)) > stopifnot(chk(c(pmvnorm(lower = c(Inf, 1))), 0)) > stopifnot(chk(c(pmvnorm(lower = c(-2, 0), upper = c(-1, + 1), corr = matrix(rep(1, 4), 2, 2))), 0)) > stopifnot(chk(c(pmvnorm(-Inf, c(Inf, 0), 0, diag(2))), + c(pmvnorm(-Inf, c(Inf, 0), 0)))) > stopifnot(chk(c(pmvnorm(lo = c(-Inf, -Inf), up = c(Inf, + Inf), mean = c(0, 0))), 1)) > dm <- 250000 > iters <- 2 > corr <- 0.7 > dim <- 100 > abserr <- 3.5e-06 > cutoff <- -5.199338 > mn <- rep(0, dim) > mat <- diag(dim) > for (i in 1:dim) { + for (j in 1:(i - 1)) { + mat[i, j] = mat[j, i] = corr^(i - j) + } + } > ll <- rep(cutoff, dim) > mn <- rep(0, dim) > p <- matrix(0, iters, 1) > set.seed(290875) > for (i in 1:iters) { + pp <- pmvnorm(lower = ll, sigma = mat, maxpts = dm, abseps = abserr) + p[i] <- 1 - pp + } > stopifnot(abs(p[1] - p[2]) < 2 * abserr) > ptmp <- p > set.seed(290875) > for (i in 1:iters) { + pp <- pmvnorm(lower = ll, sigma = mat, maxpts = dm, abseps = abserr) + p[i] <- 1 - pp + } > stopifnot(chk(p, ptmp)) > pmvnormM <- function(...) pmvnorm(..., algorithm = Miwa()) > a <- 4.048 > shi <- -9 > slo <- -10 > mu <- -5 > sig <- matrix(c(1, 1, 1, 2), ncol = 2) > pmvnormM(lower = c(-a, slo), upper = c(a, shi), mean = c(mu, + 2 * mu), sigma = sig) [1] 0.04210555 attr(,"error") [1] NA attr(,"msg") [1] "Normal Completion" > n <- 5 > lower <- -1 > upper <- 3 > df <- 4 > corr <- diag(5) > corr[lower.tri(corr)] <- 0.5 > delta <- rep(0, 5) > set.seed(290875) > prob1 <- pmvnormM(lower = lower, upper = upper, mean = delta, + corr = corr) > set.seed(290875) > prob2 <- pmvnormM(lower = lower, upper = upper, mean = delta, + corr = corr) > stopifnot(chk(prob1, prob2)) > a <- pmvnormM(lower = -Inf, upper = 2, mean = 0, sigma = matrix(1.5)) > attributes(a) <- NULL > stopifnot(chk(a, pnorm(2, sd = sqrt(1.5)))) > a <- pmvnormM(lower = -Inf, upper = 2, mean = 0, sigma = matrix(0.5)) > attributes(a) <- NULL > stopifnot(chk(a, pnorm(2, sd = sqrt(0.5)))) > a <- pmvnormM(lower = -Inf, upper = 2, mean = 0, sigma = 0.5) > attributes(a) <- NULL > stopifnot(chk(a, pnorm(2, sd = sqrt(0.5)))) > stopifnot(chk(c(pmvnormM(upper = c(-Inf, 1))), 0)) > stopifnot(chk(c(pmvnormM(lower = c(Inf, 1))), 0)) > stopifnot(chk(pmvnormM(-Inf, c(Inf, 0), 0, diag(2)), + pmvnormM(-Inf, c(Inf, 0), 0))) > stopifnot(chk(c(pmvnormM(lo = c(-Inf, -Inf), up = c(Inf, + Inf), mean = c(0, 0))), 1)) > dm <- 250000 > iters <- 2 > corr <- 0.7 > dim <- 10 > abserr <- 3.5e-06 > cutoff <- -5.199338 > mn <- rep(0, dim) > mat <- diag(dim) > for (i in 1:dim) { + for (j in 1:(i - 1)) { + mat[i, j] = mat[j, i] = corr^(i - j) + } + } > ll <- rep(cutoff, dim) > mn <- rep(0, dim) > p <- matrix(0, iters, 1) > set.seed(290875) > for (i in 1:iters) { + pp <- pmvnormM(lower = ll, sigma = mat, maxpts = dm, abseps = abserr) + p[i] <- 1 - pp + } > stopifnot(abs(p[1] - p[2]) < 2 * abserr) > ptmp <- p > set.seed(290875) > for (i in 1:iters) { + pp <- pmvnormM(lower = ll, sigma = mat, maxpts = dm, abseps = abserr) + p[i] <- 1 - pp + } > stopifnot(chk(p, ptmp)) > stopifnot(chk(c(pmvnorm(c(-Inf, -Inf, 0, 0))), 0.25)) > set.seed(290875) > n <- 1e+05 > df <- rpois(1, 1/rexp(1, 1)) + 1 > dim <- rpois(1, runif(1, 0, 10)) + 2 > mn <- rnorm(dim, 0, 4) > sigma <- matrix(runif(dim^2, -1, 1), nrow = dim, ncol = dim) > sigma <- crossprod(sigma) + diag(dim) > d <- runif(dim, 0.3, 20) > sigma <- diag(d) %*% sigma %*% diag(d) > corrMat <- cov2cor(sigma) > sims1 <- rmvt(n, sigma = sigma, delta = mn, df = df, + type = "shifted", pre0.9_9994 = TRUE) > sims2 <- rmvt(n, sigma = sigma, delta = mn, df = df, + type = "Kshirsagar", pre0.9_9994 = TRUE) > lower <- mn - d * 2 > upper <- mn + d * 3 > comp <- function(x, lower, upper) { + all(x > lower) & all(x < upper) + } > ind1 <- apply(sims1, 1, comp, lower = lower, upper = upper) > mean(ind1) [1] 0.247 > pmvt(lower, upper, sigma = sigma, delta = mn, df = df, + type = "shifted") [1] 0.2459638 attr(,"error") [1] 8.791565e-05 attr(,"msg") [1] "Normal Completion" > ind2 <- apply(sims2, 1, comp, lower = lower, upper = upper) > mean(ind2) [1] 0.24729 > pmvt(lower, upper, sigma = sigma, delta = mn, df = df, + type = "Kshirsagar") [1] 0.2462984 attr(,"error") [1] 6.430839e-05 attr(,"msg") [1] "Normal Completion" > sims1 <- rmvt(n, sigma = corrMat, delta = mn, df = df, + type = "shifted", pre0.9_9994 = TRUE) > sims2 <- rmvt(n, sigma = corrMat, delta = mn, df = df, + type = "Kshirsagar", pre0.9_9994 = TRUE) > lower <- mn - d * 0.5 > upper <- mn + d > comp <- function(x, lower, upper) { + all(x > lower) & all(x < upper) + } > ind1 <- apply(sims1, 1, comp, lower = lower, upper = upper) > mean(ind1) [1] 0.99669 > pmvt(lower, upper, corr = corrMat, delta = mn, df = df, + type = "shifted") [1] 0.996872 attr(,"error") [1] 2.461945e-05 attr(,"msg") [1] "Normal Completion" > ind2 <- apply(sims2, 1, comp, lower = lower, upper = upper) > mean(ind2) [1] 0.98827 > pmvt(lower, upper, corr = corrMat, delta = mn, df = df, + type = "Kshirsagar") [1] 0.9882905 attr(,"error") [1] 6.344011e-05 attr(,"msg") [1] "Normal Completion" > m <- 10 > rho <- 0.1 > k <- 2 > alpha <- 0.05 > cc_z <- numeric(m) > var <- matrix(c(1, rho, rho, 1), nrow = 2, ncol = 2, + byrow = T) > i <- 1 > q1 <- qmvnorm((k * (k - 1))/(m * (m - 1)) * alpha, + tail = "upper", sigma = var, ptol = 1e-05)$quantile > q2 <- qmvnorm((k * (k - 1))/(m * (m - 1)) * alpha, + tail = "upper", sigma = var, interval = c(0, 5), ptol = 1e-05)$quantile > stopifnot(chk(round(q1, 4), round(q2, 4))) > qmvnorm(0.95, sigma = tcrossprod(c(0.009, 0.75, 0.25)))$quantile [1] 1.23364 > stopifnot(is.finite(qmvt(0.95, df = 0, corr = matrix(1))$quantile)) > corr <- matrix(1, ncol = 2, nrow = 2) > p <- c(pmvnorm(lower = c(-Inf, -Inf), upper = c(1.96, + 1.96), mean = c(1.72, 1.72), corr = corr), pmvt(lower = c(-Inf, + -Inf), upper = c .... [TRUNCATED] > stopifnot(all(abs(p - mean(p)) < 1/100)) > m <- 3 > S <- diag(m) > S[2, 1] <- S[1, 2] <- 1/4 > S[3, 1] <- S[1, 3] <- 1/5 > S[3, 2] <- S[2, 3] <- 1/3 > p <- pmvnorm(lower = c(-Inf, 0, 0), upper = c(0, Inf, + Inf), mean = c(0, 0, 0), sigma = S, algorithm = Miwa()) > stopifnot(!is.na(p)) > set.seed(29) > d1 <- function(x, mean, sigma) { + distval <- mahalanobis(x, center = mean, cov = sigma) + logdet <- sum(log(eigen(sigma, symmetric = TRUE, .... [TRUNCATED] > d2 <- function(...) dmvnorm(..., log = TRUE) > for (i in 1:100) { + p <- sample(2:10, 1) + Sigma <- tcrossprod(matrix(runif(p^2) * 2, ncol = p)) + x <- matrix(rnorm(p), nr = 1) + .... [TRUNCATED] > L <- diag(10 * (1:4)) > L[lower.tri(L)] <- 1:6 > L[3, 3] <- 0 > L [,1] [,2] [,3] [,4] [1,] 10 0 0 0 [2,] 1 20 0 0 [3,] 2 4 0 0 [4,] 3 5 6 40 > (Sig <- tcrossprod(L)) [,1] [,2] [,3] [,4] [1,] 100 10 20 30 [2,] 10 401 82 103 [3,] 20 82 20 26 [4,] 30 103 26 1670 > set.seed(123) > fx <- dmvnorm(rbind(0, 1:4, matrix(rnorm(4 * 10), + ncol = 4)), sigma = Sig) > stopifnot(chk(fx, c(Inf, rep(0, 1 + 10)))) > ret <- structure(list(N = 10, NU = 25, LOWER = c(-0.430060315238938, + -0.430060315238938, -0.430060315238938, -0.430060315238938, + -0.43 .... [TRUNCATED] > RS <- c(403, 480, 641015092, 1848202935, -2124158291, + -2116162620, 1818211306, -796165035, -1592745489, -483415562, + -77025504, -170853 .... [TRUNCATED] > f <- function() { + error <- 0 + value <- 0 + inform <- 0 + ret <- .C(C_mvtdst, N = as.integer(ret$N), NU = as.integer(ret$NU), + .... [TRUNCATED] > .Random.seed <- RS > p <- 0.95 > stopifnot(chk(round(qmvnorm(p, sigma = diag(3), tail = "upper")$quantile, + 2), round(qnorm(p^(1/3), lower = FALSE), 2))) > stopifnot(chk(round(qmvnorm(p, sigma = diag(3), tail = "lower")$quantile, + 2), round(qnorm(p^(1/3), lower = TRUE), 2))) > set.seed(29) > p <- 0.95 > d <- 4 > qmvnorm(p, sigma = diag(d), tail = "lower")$quantile [1] 2.23395 > qmvnorm(p, sigma = diag(d), tail = "upper")$quantile [1] -2.23395 > qmvnorm(p, sigma = diag(d), tail = "both")$quantile [1] 2.490844 > p <- 1 - 0.95 > d <- 4 > qmvnorm(p, sigma = diag(d), tail = "lower")$quantile [1] -0.06784195 > qmvnorm(p, sigma = diag(d), tail = "upper")$quantile [1] 0.06784195 > qmvnorm(p = 0.5, tail = "lower", mean = c(6.75044368, + 0.04996326), sigma = rbind(c(0.1026055, 0.02096418), c(0.02096418, + 0.16049956))) .... [TRUNCATED] [1] 6.750444 > stint <- c(6.75044332319072, 6.75044368) > qmvnorm(p = 0.5, tail = "lower", mean = c(6.75044368, + 0.04996326), sigma = rbind(c(0.1026055, 0.02096418), c(0.02096418, + 0.16049956)), .... [TRUNCATED] [1] 6.750444 > R2 = matrix(c(0.7071068, 0.6924398, 0.7054602, 0.7054602, + 0.6292745, 0.6924398, 0.7071068, 0.6909812, 0.6909712, 0.612867, + 0.7054602, .... [TRUNCATED] > call <- try(qmvnorm(p = 1 - 0.0001726701, mean = c(-0.8752332, + -0.9487915, -0.9719237, -0.5855204, -0.9046457), sigma = R2, + tail = "lo ..." ... [TRUNCATED] > inherits(call, "try-error") [1] TRUE > grepl("Covariance matrix not positive semidefinite", + geterrmessage()) [1] TRUE > call <- try(qmvt(p = 1 - 0.0001726701, mean = c(-0.8752332, + -0.9487915, -0.9719237, -0.5855204, -0.9046457), sigma = R2, + tail = "lower ..." ... [TRUNCATED] > inherits(call, "try-error") [1] TRUE > grepl("Covariance matrix not positive semidefinite", + geterrmessage()) [1] TRUE > all.equal(qnorm(p = 0.2397501, mean = 1, sd = sqrt(2)), + qmvnorm(p = 0.2397501, mean = 1, sigma = 2)$quantile) [1] TRUE > > proc.time() user system elapsed 17.825 0.175 18.012 mvtnorm/tests/Examples/0000755000176200001440000000000014172227731014702 5ustar liggesusersmvtnorm/tests/Examples/mvtnorma-Ex.Rout.save0000644000176200001440000002656414172227731020744 0ustar liggesusers R version 3.2.3 (2015-12-10) -- "Wooden Christmas-Tree" Copyright (C) 2015 The R Foundation for Statistical Computing Platform: x86_64-pc-linux-gnu (64-bit) R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. Natural language support but running in an English locale R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > pkgname <- "mvtnorm" > source(file.path(R.home("share"), "R", "examples-header.R")) > options(warn = 1) > base::assign(".ExTimings", "mvtnorm-Ex.timings", pos = 'CheckExEnv') > base::cat("name\tuser\tsystem\telapsed\n", file=base::get(".ExTimings", pos = 'CheckExEnv')) > base::assign(".format_ptime", + function(x) { + if(!is.na(x[4L])) x[1L] <- x[1L] + x[4L] + if(!is.na(x[5L])) x[2L] <- x[2L] + x[5L] + options(OutDec = '.') + format(x[1L:3L], digits = 7L) + }, + pos = 'CheckExEnv') > > ### * > library('mvtnorm') > > base::assign(".oldSearch", base::search(), pos = 'CheckExEnv') > cleanEx() > nameEx("Mvnorm") > ### * Mvnorm > > flush(stderr()); flush(stdout()) > > base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: Mvnorm > ### Title: Multivariate Normal Density and Random Deviates > ### Aliases: dmvnorm rmvnorm > ### Keywords: distribution multivariate > > ### ** Examples > > dmvnorm(x=c(0,0)) [1] 0.1591549 > dmvnorm(x=c(0,0), mean=c(1,1)) [1] 0.05854983 > > sigma <- matrix(c(4,2,2,3), ncol=2) > x <- rmvnorm(n=500, mean=c(1,2), sigma=sigma) > colMeans(x) [1] 0.9492868 1.9916602 > var(x) [,1] [,2] [1,] 4.276371 2.105874 [2,] 2.105874 3.186058 > > x <- rmvnorm(n=500, mean=c(1,2), sigma=sigma, method="chol") > colMeans(x) [1] 0.8724731 1.9804160 > var(x) [,1] [,2] [1,] 4.804847 2.430442 [2,] 2.430442 3.148344 > > plot(x) > > > > base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") > base::cat("Mvnorm", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("Mvt") > ### * Mvt > > flush(stderr()); flush(stdout()) > > base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: Mvt > ### Title: The Multivariate t Distribution > ### Aliases: dmvt rmvt > ### Keywords: distribution multivariate > > ### ** Examples > > ## basic evaluation > dmvt(x = c(0,0), sigma = diag(2)) [1] -1.837877 > > ## check behavior for df=0 and df=Inf > x <- c(1.23, 4.56) > mu <- 1:2 > Sigma <- diag(2) > x0 <- dmvt(x, delta = mu, sigma = Sigma, df = 0) # default log = TRUE! > x8 <- dmvt(x, delta = mu, sigma = Sigma, df = Inf) # default log = TRUE! > xn <- dmvnorm(x, mean = mu, sigma = Sigma, log = TRUE) > stopifnot(identical(x0, x8), identical(x0, xn)) > > ## X ~ t_3(0, diag(2)) > x <- rmvt(100, sigma = diag(2), df = 3) # t_3(0, diag(2)) sample > plot(x) > > ## X ~ t_3(mu, Sigma) > n <- 1000 > mu <- 1:2 > Sigma <- matrix(c(4, 2, 2, 3), ncol=2) > set.seed(271) > x <- rep(mu, each=n) + rmvt(n, sigma=Sigma, df=3) > plot(x) > > ## Note that the call rmvt(n, mean=mu, sigma=Sigma, df=3) does *not* > ## give a valid sample from t_3(mu, Sigma)! [and thus throws an error] > try(rmvt(n, mean=mu, sigma=Sigma, df=3)) Error in rmvt(n, mean = mu, sigma = Sigma, df = 3) : Providing 'mean' does *not* sample from a multivariate t distribution! > > ## df=Inf correctly samples from a multivariate normal distribution > set.seed(271) > x <- rep(mu, each=n) + rmvt(n, sigma=Sigma, df=Inf) > set.seed(271) > x. <- rmvnorm(n, mean=mu, sigma=Sigma) > stopifnot(identical(x, x.)) > > > > base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") > base::cat("Mvt", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("pmvnorm") > ### * pmvnorm > > flush(stderr()); flush(stdout()) > > base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: pmvnorm > ### Title: Multivariate Normal Distribution > ### Aliases: pmvnorm > ### Keywords: distribution > > ### ** Examples > > > n <- 5 > mean <- rep(0, 5) > lower <- rep(-1, 5) > upper <- rep(3, 5) > corr <- diag(5) > corr[lower.tri(corr)] <- 0.5 > corr[upper.tri(corr)] <- 0.5 > prob <- pmvnorm(lower, upper, mean, corr) > print(prob) [1] 0.5800051 attr(,"error") [1] 0.0002696831 attr(,"msg") [1] "Normal Completion" > > stopifnot(pmvnorm(lower=-Inf, upper=3, mean=0, sigma=1) == pnorm(3)) > > a <- pmvnorm(lower=-Inf,upper=c(.3,.5),mean=c(2,4),diag(2)) > > stopifnot(round(a,16) == round(prod(pnorm(c(.3,.5),c(2,4))),16)) > > a <- pmvnorm(lower=-Inf,upper=c(.3,.5,1),mean=c(2,4,1),diag(3)) > > stopifnot(round(a,16) == round(prod(pnorm(c(.3,.5,1),c(2,4,1))),16)) > > # Example from R News paper (original by Genz, 1992): > > m <- 3 > sigma <- diag(3) > sigma[2,1] <- 3/5 > sigma[3,1] <- 1/3 > sigma[3,2] <- 11/15 > pmvnorm(lower=rep(-Inf, m), upper=c(1,4,2), mean=rep(0, m), corr=sigma) [1] 0.8279847 attr(,"error") [1] 2.658133e-07 attr(,"msg") [1] "Normal Completion" > > # Correlation and Covariance > > a <- pmvnorm(lower=-Inf, upper=c(2,2), sigma = diag(2)*2) > b <- pmvnorm(lower=-Inf, upper=c(2,2)/sqrt(2), corr=diag(2)) > stopifnot(all.equal(round(a,5) , round(b, 5))) > > > > > base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") > base::cat("pmvnorm", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("pmvt") > ### * pmvt > > flush(stderr()); flush(stdout()) > > base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: pmvt > ### Title: Multivariate t Distribution > ### Aliases: pmvt > ### Keywords: distribution > > ### ** Examples > > > n <- 5 > lower <- -1 > upper <- 3 > df <- 4 > corr <- diag(5) > corr[lower.tri(corr)] <- 0.5 > delta <- rep(0, 5) > prob <- pmvt(lower=lower, upper=upper, delta=delta, df=df, corr=corr) > print(prob) [1] 0.5063832 attr(,"error") [1] 0.0002426557 attr(,"msg") [1] "Normal Completion" > > pmvt(lower=-Inf, upper=3, df = 3, sigma = 1) == pt(3, 3) upper TRUE > > # Example from R News paper (original by Edwards and Berry, 1987) > > n <- c(26, 24, 20, 33, 32) > V <- diag(1/n) > df <- 130 > C <- c(1,1,1,0,0,-1,0,0,1,0,0,-1,0,0,1,0,0,0,-1,-1,0,0,-1,0,0) > C <- matrix(C, ncol=5) > ### scale matrix > cv <- C %*% V %*% t(C) > ### correlation matrix > dv <- t(1/sqrt(diag(cv))) > cr <- cv * (t(dv) %*% dv) > delta <- rep(0,5) > > myfct <- function(q, alpha) { + lower <- rep(-q, ncol(cv)) + upper <- rep(q, ncol(cv)) + pmvt(lower=lower, upper=upper, delta=delta, df=df, + corr=cr, abseps=0.0001) - alpha + } > > ### uniroot for this simple problem > round(uniroot(myfct, lower=1, upper=5, alpha=0.95)$root, 3) [1] 2.561 > > # compare pmvt and pmvnorm for large df: > > a <- pmvnorm(lower=-Inf, upper=1, mean=rep(0, 5), corr=diag(5)) > b <- pmvt(lower=-Inf, upper=1, delta=rep(0, 5), df=rep(300,5), + corr=diag(5)) Warning in if (df < 0) stop("cannot compute multivariate t distribution with ", : the condition has length > 1 and only the first element will be used Warning in if (isInf(df)) df <- 0 : the condition has length > 1 and only the first element will be used > a [1] 0.4215702 attr(,"error") [1] 0 attr(,"msg") [1] "Normal Completion" > b [1] 0.4211423 attr(,"error") [1] 2.31377e-06 attr(,"msg") [1] "Normal Completion" > > stopifnot(round(a, 2) == round(b, 2)) > > # correlation and scale matrix > > a <- pmvt(lower=-Inf, upper=2, delta=rep(0,5), df=3, + sigma = diag(5)*2) > b <- pmvt(lower=-Inf, upper=2/sqrt(2), delta=rep(0,5), + df=3, corr=diag(5)) > attributes(a) <- NULL > attributes(b) <- NULL > a [1] 0.5653944 > b [1] 0.5654 > stopifnot(all.equal(round(a,3) , round(b, 3))) > > a <- pmvt(0, 1,df=10) > attributes(a) <- NULL > b <- pt(1, df=10) - pt(0, df=10) > stopifnot(all.equal(round(a,10) , round(b, 10))) > > > > > base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") > base::cat("pmvt", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("qmvnorm") > ### * qmvnorm > > flush(stderr()); flush(stdout()) > > base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: qmvnorm > ### Title: Quantiles of the Multivariate Normal Distribution > ### Aliases: qmvnorm > ### Keywords: distribution > > ### ** Examples > > qmvnorm(0.95, sigma = diag(2), tail = "both") $quantile [1] 2.236358 $f.quantile [1] -1.681424e-06 attr(,"message") [1] "Normal Completion" > > > > base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") > base::cat("qmvnorm", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > cleanEx() > nameEx("qmvt") > ### * qmvt > > flush(stderr()); flush(stdout()) > > base::assign(".ptime", proc.time(), pos = "CheckExEnv") > ### Name: qmvt > ### Title: Quantiles of the Multivariate t Distribution > ### Aliases: qmvt > ### Keywords: distribution > > ### ** Examples > > ## basic evaluation > qmvt(0.95, df = 16, tail = "both") $quantile [1] 2.119905 $f.quantile [1] 0.975 > > ## check behavior for df=0 and df=Inf > Sigma <- diag(2) > set.seed(29) > q0 <- qmvt(0.95, sigma = Sigma, df = 0, tail = "both")$quantile > set.seed(29) > q8 <- qmvt(0.95, sigma = Sigma, df = Inf, tail = "both")$quantile > set.seed(29) > qn <- qmvnorm(0.95, sigma = Sigma, tail = "both")$quantile > stopifnot(identical(q0, q8), + isTRUE(all.equal(q0, qn, tol = (.Machine$double.eps)^(1/3)))) > > ## if neither sigma nor corr are provided, corr = 1 is used internally > df <- 0 > set.seed(29) > qt95 <- qmvt(0.95, df = df, tail = "both")$quantile > set.seed(29) > qt95.c <- qmvt(0.95, df = df, corr = 1, tail = "both")$quantile > set.seed(29) > qt95.s <- qmvt(0.95, df = df, sigma = 1, tail = "both")$quantile > stopifnot(identical(qt95, qt95.c), + identical(qt95, qt95.s)) > > df <- 4 > set.seed(29) > qt95 <- qmvt(0.95, df = df, tail = "both")$quantile > set.seed(29) > qt95.c <- qmvt(0.95, df = df, corr = 1, tail = "both")$quantile > set.seed(29) > qt95.s <- qmvt(0.95, df = df, sigma = 1, tail = "both")$quantile > stopifnot(identical(qt95, qt95.c), + identical(qt95, qt95.s)) > > > > base::assign(".dptime", (proc.time() - get(".ptime", pos = "CheckExEnv")), pos = "CheckExEnv") > base::cat("qmvt", base::get(".format_ptime", pos = 'CheckExEnv')(get(".dptime", pos = "CheckExEnv")), "\n", file=base::get(".ExTimings", pos = 'CheckExEnv'), append=TRUE, sep="\t") > ### *