的多元正态分布是球对称的。您寻找的分布在处将半径截短。因为此条件仅取决于的长度,所以截断的分布保持球形对称。由于与球角无关 并且具有分布,因此您可以通过几个简单的步骤就从截断的分布中生成值:ρ = | | X | | 2一个X ρ X / | | X | | ρXρ=||X||2aXρX/||X||χ (Ñ )ρσχ(n)
生成。X∼N(0,In)
生成作为分布的平方根,截断为。χ 2(d )(一/ σ )2Pχ2(d)(a/σ)2
令。Y=σPX/||X||
在步骤1中,将作为标准正态变量的独立实现的序列获得。dXd
在步骤2中,可容易地通过反转位数函数生成一个的分布:产生一个均匀的可变之间支撑在所述范围(分位数的)和并设置。˚F - 1 χ 2(d )Ü ˚F ((一/ σ )2)1 P = √PF−1χ2(d)UF((a/σ)2)1P=F(U)−−−−−√
下面是一个直方图的这样的独立的实现为在的尺寸,在截断低于。生成大约花了一秒钟,证明了该算法的效率。 σ P σ = 3 Ñ = 11 一个= 7105σPσ=3n=11a=7
红色曲线是截断的分布的密度,该分布由缩放。它与直方图非常匹配,证明了该技术的有效性。σ = 3χ(11)σ=3
为了获得截断的直觉,请考虑,在维中的情况。这是对的散点图(对于独立实现)。它清楚地显示了半径为的孔:σ = 1个ñ = 2 ý 2 ý 1 10 4一a=3σ=1n=2Y2Y1104a
最后,请注意,(1)分量必须具有相同的分布(由于球对称性),以及(2)除了,该公共分布不是正态分布。实际上,随着增大,(单变量)正态分布的迅速减小会导致球形截断的多元正态分布在(半径为)球表面附近的大部分概率。因此,边际分布必须近似集中在区间的缩放对称Beta分布。这在上一个散点图中很明显,其中一个= 0 一ñ - 1 一((ñ - 1 )/ 2 ,(Ñ - 1 )/ 2 )(- 一,一)一个= 3 σ 2 - 1 3 σXia=0an−1a((n−1)/2,(n−1)/2)(−a,a)a=3σ在两个维度上已经很大:点沿半径为的环(球体)倾斜。2−13σ
以下是在维中大小为且,的边际分布的直方图(其近似Beta分布是均匀的): 3 一个= 10 σ = 1 (1 ,1 )1053a=10σ=1(1,1)
由于问题中描述的过程的前边际是正常的(通过构造),因此该过程是不正确的。n−1
以下R
代码生成了第一个图形。它被构造成并行步骤1-3用于产生。它被修改以产生通过改变变量第二图形,,,和然后发出绘图命令后产生。Ya
d
n
sigma
plot(y[1,], y[2,], pch=16, cex=1/2, col="#00000010")
y
的产生在代码修改较高数值分辨率:代码实际上产生,并使用该计算到。1 − U PU1−UP
根据假定的算法对数据进行模拟,将其与直方图进行汇总并叠加直方图的相同技术可用于测试问题中所述的方法。它将确认该方法无法按预期工作。
a <- 7 # Lower threshold
d <- 11 # Dimensions
n <- 1e5 # Sample size
sigma <- 3 # Original SD
#
# The algorithm.
#
set.seed(17)
u.max <- pchisq((a/sigma)^2, d, lower.tail=FALSE)
if (u.max == 0) stop("The threshold is too large.")
u <- runif(n, 0, u.max)
rho <- sigma * sqrt(qchisq(u, d, lower.tail=FALSE))
x <- matrix(rnorm(n*d, 0, 1), ncol=d)
y <- t(x * rho / apply(x, 1, function(y) sqrt(sum(y*y))))
#
# Draw histograms of the marginal distributions.
#
h <- function(z) {
s <- sd(z)
hist(z, freq=FALSE, ylim=c(0, 1/sqrt(2*pi*s^2)),
main="Marginal Histogram",
sub="Best Normal Fit Superimposed")
curve(dnorm(x, mean(z), s), add=TRUE, lwd=2, col="Red")
}
par(mfrow=c(1, min(d, 4)))
invisible(apply(y, 1, h))
#
# Draw a nice histogram of the distances.
#
#plot(y[1,], y[2,], pch=16, cex=1/2, col="#00000010") # For figure 2
rho.max <- min(qchisq(1 - 0.001*pchisq(a/sigma, d, lower.tail=FALSE), d)*sigma,
max(rho), na.rm=TRUE)
k <- ceiling(rho.max/a)
hist(rho, freq=FALSE, xlim=c(0, rho.max),
breaks=seq(0, max(rho)+a, by=a/ceiling(50/k)))
#
# Superimpose the theoretical distribution.
#
dchi <- function(x, d) {
exp((d-1)*log(x) + (1-d/2)*log(2) - x^2/2 - lgamma(d/2))
}
curve((x >= a)*dchi(x/sigma, d) / (1-pchisq((a/sigma)^2, d))/sigma, add=TRUE,
lwd=2, col="Red", n=257)