Si je vous comprends bien, vous voulez échantillonner valeurs de la distribution multinomiale avec des probabilités p 1 , … , p k telles que ∑ i x i = n , mais vous voulez que la distribution soit tronquée donc a i ≤ x i ≤ b i pour tout x i .X1, … , Xkp1, … , Pk∑jeXje= nuneje≤ xje≤biXje
Je vois trois solutions (ni aussi élégantes que dans le cas non tronqué):
- Accepter-rejeter. Échantillon à partir de multinomiaux non tronqués, acceptez l'échantillon s'il correspond aux limites de troncature, sinon rejetez et répétez le processus. C'est rapide, mais peut être très inefficace.
rtrmnomReject <- function(R, n, p, a, b) {
x <- t(rmultinom(R, n, p))
x[apply(a <= x & x <= b, 1, all) & rowSums(x) == n, ]
}
- Simulation directe. Échantillonnez à la mode qui ressemble au processus de génération de données, c'est-à-dire échantillonnez une seule bille dans une urne aléatoire et répétez ce processus jusqu'à ce que vous ayez échantillonné billes au total, mais lorsque vous déployez le nombre total de billes à partir d'une urne donnée ( x i est déjà égal à b i ) puis arrêtez de tirer de cette urne. J'ai implémenté cela dans un script ci-dessous.nXjebje
# single draw from truncated multinomial with a,b truncation points
rtrmnomDirect <- function(n, p, a, b) {
k <- length(p)
repeat {
pp <- p # reset pp
x <- numeric(k) # reset x
repeat {
if (sum(x<b) == 1) { # if only a single category is left
x[x<b] <- x[x<b] + n-sum(x) # fill this category with reminder
break
}
i <- sample.int(k, 1, prob = pp) # sample x[i]
x[i] <- x[i] + 1
if (x[i] == b[i]) pp[i] <- 0 # if x[i] is filled do
# not sample from it
if (sum(x) == n) break # if we picked n, stop
}
if (all(x >= a)) break # if all x>=a sample is valid
# otherwise reject
}
return(x)
}
- Algorithme Metropolis. Enfin, la troisième approche, la plus efficace, serait d'utiliser l'algorithme Metropolis . L'algorithme est initialisé en utilisant la simulation directe (mais peut être initialisé différemment) pour tirer le premier échantillon . Dans les étapes suivantes de manière itérative: la valeur de proposition y = q ( X i - 1 )
est acceptée comme X i avec la probabilité f ( y ) / f ( X i - 1 ) , sinon X i - 1X1y= q( Xi - 1)XjeF( y) / f( Xi - 1)Xi - 1la valeur est prise à sa place, où . Comme proposition, j'ai utilisé la fonction q qui prend la valeur X i - 1 et retourne au hasard de 0 au nombre de cas et la déplace vers une autre catégorie.F( x ) ∝ ∏jepXjeje/ xje!qXi - 1
step
# draw R values
# 'step' parameter defines magnitude of jumps
# for Meteropolis algorithm
# 'init' is a vector of values to start with
rtrmnomMetrop <- function(R, n, p, a, b,
step = 1,
init = rtrmnomDirect(n, p, a, b)) {
k <- length(p)
if (length(a)==1) a <- rep(a, k)
if (length(b)==1) b <- rep(b, k)
# approximate target log-density
lp <- log(p)
lf <- function(x) {
if(any(x < a) || any(x > b) || sum(x) != n)
return(-Inf)
sum(lp*x - lfactorial(x))
}
step <- max(2, step+1)
# proposal function
q <- function(x) {
idx <- sample.int(k, 2)
u <- sample.int(step, 1)-1
x[idx] <- x[idx] + c(-u, u)
x
}
tmp <- init
x <- matrix(nrow = R, ncol = k)
ar <- 0
for (i in 1:R) {
proposal <- q(tmp)
prob <- exp(lf(proposal) - lf(tmp))
if (runif(1) < prob) {
tmp <- proposal
ar <- ar + 1
}
x[i,] <- tmp
}
structure(x, acceptance.rate = ar/R, step = step-1)
}
X1step
n <- 500
a <- 50
b <- 125
p <- c(1,5,2,4,3)/15
k <- length(p)
x <- rtrmnomMetrop(1e4, n, p, a, b, step = 15)
cmb <- combn(1:k, 2)
par.def <- par(mfrow=c(4,5), mar = c(2,2,2,2))
for (i in 1:k)
hist(x[,i], main = paste0("X",i))
for (i in 1:k)
plot(x[,i], main = paste0("X",i), type = "l", col = "lightblue")
for (i in 1:ncol(cmb))
plot(jitter(x[,cmb[1,i]]), jitter(x[,cmb[2,i]]),
type = "l", main = paste(paste0("X", cmb[,i]), collapse = ":"),
col = "gray")
par(par.def)
Le problème de l'échantillonnage à partir de cette distribution est qu'il décrit une stratégie d'échantillonnage très inefficace en général. Imaginez que p1≠ ⋯ ≠ pkune1= ⋯ = akb1= … Bkunejebjep1≫ p2une1≪ a2b1≪ b2
n pjepje
Rukhin, AL (2007). Statistiques d'ordre normal et sommes de variables géométriques aléatoires dans les problèmes d'allocation de traitement. Statistiques et lettres de probabilité, 77 (12), 1312-1321.
Rukhin, AL (2008). Arrêt des règles dans les problèmes d'allocation équilibrée: distributions exactes et asymptotiques. Analyse séquentielle, 27 (3), 277-292.
x[i] >= a
. Imaginez que vous jetiez une pièce biaisée avec une probabilité de têtes = 0,9. Vous lancez la pièce jusqu'à ce que vous obteniez au moins 10 têtes et 10 queues. Au point d'arrêt, vous auriez en moyenne beaucoup plus de têtes que de queues. Commencer àx[1] = ... = x[k] = a
signifie que vous ignorez le fait que les points de départ de chacunx[i]
sont différents en raison de différentsp[i]
.Voici mes efforts pour essayer de traduire le code R de Tim en Python. Depuis que j'ai passé un peu de temps à comprendre ce problème et à coder les algorithmes en Python, j'ai pensé à les partager ici au cas où les gens seraient intéressés.
Pour une implémentation complète de ce code, veuillez consulter mon référentiel Github à l'adresse
https://github.com/mohsenkarimzadeh/sampling
la source