この問題の一般化を考えてみましょう。 あるの塗料の缶M = 4つの異なる色及びN (0 ) = 100ボール。することができます私は、最大保持することができます(0 )m = 4m = 4ん(0 )= 100私ボール。あなたは、少なくとも持っ缶でボールの構成を生成したいbはI=(0、50、0、25をa(0 )私= (100 、100 、50 、75 )各 iの缶 i内のボール、各構成は等しい確率で。b私= (0 、50 、0 、25 )私私
このような構成は、缶iからボールを取り除いた後に得られる構成と1対1で対応し、n = n (0 ) − ∑ i b i = 100 − (0 + 50 + 0 + 25 )= 25を制限しますせいぜい残りボールiは = (0 )、I - 、B iは = (100 、50 、b私私n = n(0 )− ∑私b私= 100 − ( 0 + 50 + 0 + 25 )= 25缶当り。したがって、これらを生成し、後で調整できるようにします( b iボールをすべての iの can iに戻すことによって)。a私= a(0 )私− b私= (100 、50 、50 、50 )b私私私
私jskkk私js私+ sjn − (s私+ sj)私j1 + 分(a私+ aj− s私− sj、s私+ sj)私j
m − 2{ 私、j }状態、制限分布に達するまでチェーンを実行し、この手順でアクセスされた状態を追跡します。通常のように、シリアル相関を回避するには、この状態シーケンスをスキップして(またはランダムに再検討して)「間引き」する必要があります。缶の数の約半分の係数で薄くすることは、平均して多くのステップの後、それぞれの缶が影響を受け、真に新しい構成を生み出すため、うまく機能する傾向があります。
O (m )O (m )
= (4 、3 、2 、1 )n = 30201
s1+ s2= 3
30**, 21**, 12**, 03**
**
00
s1+ s2= 2
20**, 11**, 02**
**
10
01
3 × 2 = 6s1+ s2= 1
10**, 01**
**
20
11
02
2×2=4s1+s2=0214+6+4+1=15
3000, 2100, 1200, 0300; 2010, 2001, 1110, 1101, 0210, 0201; 1020, 1011, 0120, 0111; 0021.
10,009333715
State: 3000 2100 1200 0300 2010 1110 0210 1020 0120 2001 1101 0201 1011 0111 0021
Count: 202 227 232 218 216 208 238 227 237 209 239 222 243 211 208
χ2χ211.2p=0.6714
このR
コードは、問題の状況を処理するように設定されています。変更しa
、n
他の状況で動作します。間引き後にN
必要な実現の数を生成するのに十分な大きさに設定します。
このコードは、すべてを体系的に循環させることにより、少しチートします (i,j)i
j
ij
#
# Gibbs-like sampler.
#
# `a` is an array of maximum numbers of balls of each type. Its values should
# all be integers greater than zero.
# `n` is the total number of balls.
#------------------------------------------------------------------------------#
g <- function(j, state, a) {
#
# `state` contains the occupancy numbers.
# `a` is the array of maximum occupancy numbers.
# `j` is a pair of indexes into `a` to "rotate".
#
k <- sum(state[j]) # Total occupancy.
x <- floor(runif(1, max(0, k - a[j[2]]), min(k, a[j[1]]) + 1))
state[j] <- c(x, k-x)
return(state)
}
#
# Set up the problem.
#
a <- c(100, 50, 50, 50)
n <- 25
# a <- 4:1
# n <- 3
#
# Initialize the state.
#
state <- round(n * a / sum(a))
i <- 1
while (sum(state) < n) {
if (state[i] < a[i]) state[i] <- state[i] + 1
i <- i+1
}
while (sum(state) > n) {
i <- i-1
if (state[i] > 0) state[i] <- state[i] - 1
}
#
# Conduct a sequence of random changes.
#
set.seed(17)
N <- 1e5
sim <- matrix(state, ncol=1)
u <- ceiling(N / choose(length(state), 2) / 2)
i <- rep(rep(1:length(state), each=length(state)-1), u)
j <- rep(rep(length(state):1, length(state)-1), u)
ij <- rbind(i, j)
#
# Alternatively, generate `ij` randomly:
# i <- sample.int(length(state), N, replace=TRUE)
# j <- sample.int(length(state)-1, N, replace=TRUE)
# ij <- rbind(i, ((i+j-1) %% length(state))+1)
#
sim <- cbind(sim, apply(ij, 2, function(j) {state <<- g(j, state, a); state}))
rownames(sim) <- paste("Can", 1:nrow(sim))
#
# Thin them for use. Each column is a state.
#
thin <- function(x, stride=1, start=1) {
i <- round(seq(start, ncol(x), by=stride))
x[, i]
}
#
# Make a scatterplot of the results, to illustrate.
#
par(mfrow=c(1,1))
s <- thin(sim, stride=max(1, N/1e4))
pairs(t(s) + runif(length(s), -1/2, 1/2), cex=1/2, col="#00000005", pch=16)