Se eu entendi corretamente, você deseja provar valores da distribuição multinomial com probabilidades tal forma que , mas você deseja que a distribuição seja truncada para para todos .x1,…,xkp1,…,pk∑ixi=nai≤xi≤bixi
Vejo três soluções (nem tão elegantes quanto no caso não truncado):
- Aceitar rejeitar. Amostra de multinomial não truncado, aceite a amostra se ela se encaixar nos limites do truncamento; caso contrário, rejeite e repita o processo. É rápido, mas pode ser muito ineficiente.
rtrmnomReject <- function(R, n, p, a, b) {
x <- t(rmultinom(R, n, p))
x[apply(a <= x & x <= b, 1, all) & rowSums(x) == n, ]
}
- Simulação direta. Amostra de maneira semelhante ao processo de geração de dados, ou seja, amostra de mármore único de uma urna aleatória e repita esse processo até que você tenha amostrado bolinhas no total, mas conforme você implanta o número total de bolinhas de urna determinada ( já é igual a ) pare de desenhar a partir dessa urna. Eu implementei isso em um script abaixo.nxibi
# 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 de metrópole. Finalmente, a terceira e mais eficiente abordagem seria usar o algoritmo Metropolis . O algoritmo é inicializado usando simulação direta (mas pode ser inicializada de maneira diferente) para desenhar a primeira amostra . Nas etapas a seguir iterativamente: o valor da proposta
é aceito como com probabilidade , caso contrário, o valor é considerado é o lugar, onde. Como proposta, usei a função que pega o valor e alterna aleatoriamente de 0 para o número de casos e a move para outra categoria.X1y=q(Xi−1)Xif(y)/f(Xi−1)Xi−1f(x)∝∏ipxii/xi!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)
}
O algoritmo começa em e depois vagueia pelas diferentes regiões de distribuição. É obviamente mais rápido que os anteriores, mas você deve se lembrar que se você o usar para amostrar um pequeno número de casos, poderá acabar com desenhos próximos um do outro. Outro problema é que você precisa decidir sobre o tamanho, ou seja, quão grandes os saltos o algoritmo deve fazer - pequenos demais podem levar a movimentos lentos, grandes demais podem levar a muitas propostas inválidas e a rejeitá-las. Você pode ver exemplos de seu uso abaixo. Nas plotagens, é possível ver: densidades marginais na primeira linha, plotagens de traços na segunda linha e plotagens mostrando saltos subsequentes para pares de variáveis.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)
O problema com a amostragem dessa distribuição é que descreve uma estratégia de amostragem muito ineficiente em geral. Imagine que e , e estão próximos de '; nesse caso, você deseja provar amostras de categorias com probabilidades diferentes, mas espera resultados semelhantes. frequências no final. Em casos extremos, imagine a distribuição de duas categorias em que e ,p1≠⋯≠pka1=⋯=akb1=…bkaibip1≫p2a1≪a2b1≪b2, nesse caso, você espera que algo muito raro aconteça (exemplo da vida real dessa distribuição seria o pesquisador que repete a amostragem até encontrar a amostra que seja consistente com sua hipótese, por isso tem mais a ver com trapaça do que com amostra aleatória) .
A distribuição é muito menos problemática se você a definir como Rukhin (2007, 2008), onde você casos para cada categoria, ou seja, amostra proporcionalmente a 's.npipi
Rukhin, AL (2007). Estatísticas de ordem normal e somas de variáveis geométricas aleatórias em problemas de alocação de tratamento. Estatísticas e letras de probabilidade, 77 (12), 1312-1321.
Rukhin, AL (2008). Parando regras em problemas de alocação equilibrada: distribuições exatas e assintóticas. Análise Sequencial, 27 (3), 277-292.