generating a discrete random probability distribution, by perturbing an existing one - r

Question

If I wanted to efficiently generate a random discrete probability distribution of N probabilities which sum up to 1, I could go with Hadley's comment here:
prop.table(runif(N))
If I repeat this many times, the average probability for each of the N elements should be ~1/N.
What if I want the average probability for each of the N elements not to be 1/N but a specified number a priori?
E.g. N = 4 elements, I have the apriori distribution:
apriori <- c(0.2, 0.3, 0.1, 0.4)
And I would like random distributions based on this a priori, e.g.:
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)
Etc.
Where we go by either of these rules:
1) On average each of the elements probabilities would be (approx.) its probability in the a priori distribution
2) There's a "perturbation" parameter, say perturbation = 0.05 which means either: (a) we're letting each of the probabilities i to be in the apriori[i] +- perturbation range or (b) we're letting each of the probabilities i to be in the apriori[i] +- perturbation * apriori[i] range (i.e. plus/minus 5% of that apriori probability, not absolute 5%)
I have no idea how to do this while keeping rule 1.
Regarding rule 2, my initial inefficient thought would be perturbing each of the first N - 1 elements by a random allowed amount, setting the last element to be 1 - sum(N-1_probs) and wrapping this with a while loop until the last element is also legitimate.
I didn't even implement it yet because that's very inefficient (say I want 100K of such distributions...). Ideas?

Answer 1

As proposed by prof.Bolker, you ought to look at Dirichlet distribution. Let's denote mean apriori values by capital letters Ci and sampled values by small letters ci. It will automatically, from distribution properties, provide you with two features:
Sum i ci = 1
Each ci is within [0...1] range
so right away you could use them as probabilities.
Given Ci, and looking at distribution definition (check the link), the only free parameter left is
a0 = Sum i ai
and each ai = Ci * a0
Such choice of ai will (again, automatically) provide proper mean value E[ci] = Ci.
Bigger a0 - ci would be more narrow around Ci. Variance is roughly speaking Var[ci] ~ Ci/a0, so for 5% you might try to use a0 of 50.
Some R code
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

I have a solution, but it will end up with the draws being normal. I think you can probably do something similar to draw a uniform distribution. Don't have much experience with this, but I would lean towards a rejection kind of policy where you draw lots of things quickly, and then reject the ones that don't fit your criteria
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

Answer 3

and using a normal distribution for each of your probability ?
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