Answers:
这是著名的生日问题的一个概括:给定个在一组可能性中具有随机且均匀分布的“生日”的个体,那么不超过个体不共享生日的机会是多少?
精确的计算得出答案为(以双精度表示)。我将概述该理论,并提供通用的代码 该代码的渐近时序为,这使其适合于非常大的生日并提供合理的性能,直到达到数千为止。那时,在大多数情况下,将生日悖论扩展到2个以上的人中讨论的Poisson近似应该可以正常工作。
面模具的独立辊的结果的概率生成函数(pgf)为
在该多项式展开式中,的系数给出了可以准确出现次的方式,我Ê 我我= 1 ,2 ,... ,d 。
将我们的兴趣限制为任何面孔最多不超过外观,就等于以为模,以生成的理想为模 要执行此评估,请递归使用二项式定理来获得f n I x m + 1 1,x m + 1 2,… ,x m + 1 d。
当为偶数时。写(项),我们有
当为奇数时,使用类似的分解
给予
在这两种情况下,我们都可以减少所有以为模的模数,这很容易从
提供递归的起始值,
使之有效的原因是,将变量分为变量的两个相等大小的组,并将所有变量值设置为我们只需要对一组计算所有值一次,然后合并结果。这要求最多计算项,每个项都需要对组合进行计算。我们甚至不需要2D数组来存储,因为在计算仅需要和。
步骤的总数比的二进制展开式中的位数(在公式中将拆分分为相等的组计数的位数少一,再加上展开式中的位数(对所有奇数进行计数)遇到值,需要应用公式)。那仍然只是步骤。
在R
具有十年历史的工作站上,工作在0.007秒内完成。该代码在这篇文章的结尾列出。它使用概率的对数(而不是概率本身),以避免可能的上溢或累积太多下溢。这样就可以消除解决方案中的因子,因此我们可以计算作为概率基础的计数。
请注意,此过程导致一次计算概率的整个序列,这很容易使我们能够研究机会如何随变化。
广义生日问题的分布由函数计算tmultinom.full
。唯一的挑战在于找到在发生碰撞的机会变得太大之前必须存在的人数上限。以下代码通过蛮力执行此操作,从小开始并将其加倍,直到足够大。因此,整个计算需要时间,其中是解。计算直至人数的整体概率分布。
#
# The birthday problem: find the number of people where the chance of
# a collision of `m+1` birthdays first exceeds `alpha`.
#
birthday <- function(m=1, d=365, alpha=0.50) {
n <- 8
while((p <- tmultinom.full(n, m, d))[n] > alpha) n <- n * 2
return(p)
}
例如,根据计算发现,使人群中至少有8个人共同生日的可能性最小的人数是。只需要几秒钟。这是部分输出的图:birthday(7)
将生日悖论扩展到2个以上的人可以解决此问题的特殊版本,这涉及到面骰子被滚动很多次的情况。
# Compute the chance that in `n` independent rolls of a `d`-sided die,
# no side appears more than `m` times.
#
tmultinom <- function(n, m, d, count=FALSE) tmultinom.full(n, m, d, count)[n+1]
#
# Compute the chances that in 0, 1, 2, ..., `n` independent rolls of a
# `d`-sided die, no side appears more than `m` times.
#
tmultinom.full <- function(n, m, d, count=FALSE) {
if (n < 0) return(numeric(0))
one <- rep(1.0, n+1); names(one) <- 0:n
if (d <= 0 || m >= n) return(one)
if(count) log.p <- 0 else log.p <- -log(d)
f <- function(n, m, d) { # The recursive solution
if (d==1) return(one) # Base case
r <- floor(d/2)
x <- double(f(n, m, r), m) # Combine two equal values
if (2*r < d) x <- combine(x, one, m) # Treat odd `d`
return(x)
}
one <- c(log.p*(0:m), rep(-Inf, n-m)) # Reduction modulo x^(m+1)
double <- function(x, m) combine(x, x, m)
combine <- function(x, y, m) { # The Binomial Theorem
z <- sapply(1:length(x), function(n) { # Need all powers 0..n
z <- x[1:n] + lchoose(n-1, 1:n-1) + y[n:1]
z.max <- max(z)
log(sum(exp(z - z.max), na.rm=TRUE)) + z.max
})
return(z)
}
x <- exp(f(n, m, d)); names(x) <- 0:n
return(x)
}
答案是与
print(tmultinom(100,20,6), digits=15)
0.267747907805267
我在R中运行了这段代码,将100次掷骰复制了一百万次:
y <-复制(1000000,全部(表(样本(1:6,大小= 100,替换= TRUE))<= 20))
如果所有面都小于或等于20次,则复制函数中代码的输出为true。y是具有一百万个正确或错误值的向量。
总数 y中的真实值除以100万应等于您期望的概率。在我的案例中为266872/1000000,表明概率约为26.6%
此代码在我的笔记本电脑上需要几秒钟
total = 0
pb <- txtProgressBar(min = 0, max = 20^2, style = 3)
for (i in 0:20) {
for (j in 0:20) {
for (k in 0:20) {
for (l in 0:20) {
for (m in 0:20) {
n = 100-sum(i,j,k,l,m)
if (n<=20) {
total = total+dmultinom(c(i,j,k,l,m,n),100,prob=rep(1/6,6))
}
}
}
}
setTxtProgressBar(pb, i*20+j) # update progression bar
}
}
total
输出:0.2677479
但是,如果您希望进行大量此类计算或使用更高的值,或者只是为了获得更优雅的方法,找到一个更直接的方法可能仍然很有趣。
至少此计算给出了一个简单计算但有效的数字,以检查其他(更复杂的)方法。