Question

如果我想有效地生成总计为1的N个概率的随机离散概率分布，我可以使用Hadley的评论here：

prop.table(runif(N))

如果我重复多次，N个元素中每个元素的平均概率应为~1 / N.

如果我希望N个元素中每个元素的平均概率不是1 / N而是指定数字先验，该怎么办？

E.g。 N = 4元素，我有apriori分布：

apriori <- c(0.2, 0.3, 0.1, 0.4)

我希望基于此先验的随机分发，例如：

c(0.21, 0.29, 0.12, 0.38) c(0.19, 0.29, 0.08, 0.44) c(0.19, 0.33, 0.1, 0.38)

等

我们遵守以下任何一条规则：

1）平均每个元素概率（近似）在先验分布中的概率

2）＆＃34;扰动＆＃34;参数，比如perturbation = 0.05，这意味着：（a）我们让每个概率i都在apriori[i] +- perturbation范围内，或者（b）我们让...每个概率i都在apriori[i] +- perturbation * apriori[i]范围内（即该先验概率的加/减5％，而不是绝对的5％）

我不知道在保持规则1的同时如何做到这一点。

关于规则2，我最初的低效率思想是以随机允许量扰乱每个前N-1个元素，将最后一个元素设置为1 - sum(N-1_probs)并用while循环包装它直到最后一个元素也是合法的。

我甚至没有实现它，因为效率非常低（说我想要100K这样的发行......）。想法？

Answer 1

正如prof.Bolker所提议的那样，你应该看看Dirichlet distribution。让我们用大写字母C _i表示平均apriori值，用小写字母c _i表示采样值。它将自动从分发属性中为您提供两个功能：

Sum _i c _i = 1
每个c _i都在[0 ... 1]范围内

所以马上就可以将它们用作概率。

鉴于C _i，并查看分布定义（检查链接），剩下的唯一免费参数是

a ₀ = Sum _i a _i

并且每个_i = C _i * a ₀

_i的这种选择将（再次，自动）提供适当的平均值E [c _i] = C _i。

更大₀ - c _i在C _i周围会更窄。方差粗略地说Var [c _i] ~C _i / a ₀，因此对于5％你可能会尝试使用₀为50。

一些R代码

library(MCMCpack)

apriori <- c(0.2, 0.3, 0.1, 0.4) # your C_i
a0 <- 50
a <- a0*apriori

set.seed(12345)
# sample your c_i and use it, for example, to throw uneven dice
ci <- rdirichlet(1, a)
dice <- rmultinom(1, 1, ci)

# another dice throw
ci <- rdirichlet(1, a)
dice <- rmultinom(1, 1, ci)

...

Answer 2

并为每个概率使用正态分布？

perturbation <- 0.05
plouf <- sapply(apriori,function(x){max(rnorm(1,mean = x, sd = perturbation*x),0)})
plouf <- plouf/sum(plouf)
> plouf
[1] 0.2020629 0.3057111 0.0994482 0.3927778

Answer 3

我有一个解决方案，但最终会有平局。我认为你可以做类似的事情来绘制统一的分布。没有多少经验，但我倾向于拒绝一种政策，你很快就抽出很多东西，然后拒绝那些不符合你标准的政策

rm(list = ls())

library(parallel)
library(data.table)
library(tictoc)

# set up the distribution informatoin
P <- 4
values <- 1:P
dist_scores <- data.table(param = values,
                          prob = c(0.2, 0.3, 0.1, 0.4), key = "param")
perturbation <- 0.05
method = "a"

switch (method,
  "a" = {dist_scores[, min := prob - perturbation]
    dist_scores[, max := prob + perturbation]},
  "b" = {dist_scores[, min := prob * (1-perturbation)]
    dist_scores[, max := prob * (1+perturbation)]}
)

# turn this in to a set of data that can be sampled
N <- 10000
v <- unlist(sapply(values, FUN = function(x){
  rep(x, round(dist_scores$prob[x]*N, 0))
}))
table(v)/N

# set number of samples, and number of draws for each iteration
sams <- 10000
reps <- 200

tic()
# loop through and draw reps from the sample. Rejection policy will remove
# ones that dont meet the conditions
new_iters <- mclapply(1:sams, FUN = function(x){
  y <- data.table(param = sample(v, reps, replace = TRUE))
  out <- y[, .(val = .N/reps), keyby = param]
  out <- dist_scores[out,]
  if(out[,all(val >= min & val <= max)]){
    return(out[, c("param", "val"), with = FALSE])
  }else{
    return(NULL)
  }
})
reject_rate <- sum(sapply(new_iters, is.null))/sams
# number of samples
sams - reject_rate*sams
toc()

out <- rbindlist(new_iters)

par(mfrow = c(2,2))
for(i in values){
  hist(out[param == i, val])
}enter code here

通过扰乱现有的

3 个答案: