Se ti capisco correttamente, vuoi campionare i valori dalla distribuzione multinomiale con probabilità tali che , tuttavia vuoi che la distribuzione venga troncata così per tutti x_i .p 1 , … , p k ∑ i x i = n aX1, ... , xKp1, ... , pKΣioXio= nx iun'io≤ xio≤ bioXio
Vedo tre soluzioni (né eleganti come nel caso non troncato):
- Accept-rifiuto. Campione da multinomio non troncato, accettare il campione se si adatta ai limiti del troncamento, altrimenti rifiutare e ripetere il processo. È veloce, ma può essere molto inefficiente.
rtrmnomReject <- function(R, n, p, a, b) {
x <- t(rmultinom(R, n, p))
x[apply(a <= x & x <= b, 1, all) & rowSums(x) == n, ]
}
- Simulazione diretta. Fai un esempio di moda che assomigli al processo di generazione dei dati, ovvero campiona un singolo marmo da un'urna casuale e ripeti questo processo fino a quando non hai campionato marmi in totale, ma mentre distribuisci il numero totale di marmi da una determinata urna ( è già uguale a ) quindi smettere di disegnare da tale urna. L'ho implementato in uno script di seguito.x i b inXioBio
# 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)
}
- Algoritmo Metropolis. Infine, il terzo e più efficace approccio sarebbe quello di utilizzare l' algoritmo Metropolis . L'algoritmo viene inizializzato utilizzando la simulazione diretta (ma può essere inizializzato in modo diverso) per disegnare il primo campione . Nei passaggi seguenti in modo iterativo: il valore della proposta
viene accettato come con probabilità , altrimenti viene preso il valore è il luogo, dove. Come proposta ho usato la funzione che accetta il valore e capovolge casualmente da 0 al numero di casi e lo sposta in un'altra categoria.X1y= q( Xi - 1)Xiof( y) / f( Xi - 1)Xi - 1f( x ) ∝ ∏iopXioio/ xio!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)
}
L'algoritmo inizia da e quindi si aggira tra le diverse regioni di distribuzione. È ovviamente più veloce di quelli precedenti, ma è necessario ricordare che se lo si usasse per campionare un numero limitato di casi, si potrebbe finire con disegni vicini l'uno all'altro. Un altro problema è che devi decidere in merito alle dimensioni, ovvero a quali grandi salti dovrebbe fare l'algoritmo: troppo piccolo può portare a muoversi lentamente, troppo grande può portare a fare troppe proposte non valide e respingerle. Di seguito puoi vedere un esempio del suo utilizzo. Sui grafici è possibile visualizzare: densità marginali nella prima riga, grafici di traccia nella seconda riga e grafici che mostrano i salti successivi per coppie di variabili.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)
Il problema con il campionamento da questa distribuzione è che descrive una strategia di campionamento molto inefficiente in generale. Immagina che e , e 's siano vicini a 's, in tal caso desideri campionare categorie con diverse probabilità, ma ti aspetti simili frequenze alla fine. In casi estremi, immagina una distribuzione a due categorie dove e ,a 1 = ⋯ = a k b 1 = … b k a i b i p 1 ≫ pp1≠ ⋯ ≠ pKun'1= ⋯ = aKB1= ... bKun'ioBiop1≫ p2un'1≪ a2B1≪ b2, in tal caso ti aspetti che accada qualcosa di molto raro (un esempio di tale distribuzione nella vita reale sarebbe il ricercatore che ripete il campionamento fino a quando non trova il campione coerente con la sua ipotesi, quindi ha più a che fare con il tradimento che con il campionamento casuale) .
La distribuzione è molto meno problematica se la si definisce come Rukhin (2007, 2008) in cui si campionano casi in ciascuna categoria, vale a dire campionati proporzionalmente a quelli di .p in piopio
Rukhin, AL (2007). Statistiche dell'ordine normale e somme di variabili casuali geometriche nei problemi di allocazione del trattamento. Lettere statistiche e probabilità, 77 (12), 1312-1321.
Rukhin, AL (2008). Arresto delle regole nei problemi di allocazione bilanciata: distribuzioni esatte e asintotiche. Analisi sequenziale, 27 (3), 277-292.