我试图计算由产品总和产生的数组中的单元概率。这是我将在R中的JAGS中运行的模型的一部分。在此示例中，对象可能处于3种状态之一。在每个时间间隔，它可以保持在相同的状态或传递到其他状态之一。使用下面的示例代码，起始状态是1，最终状态是2.数组X是状态*状态转换矩阵（例如，X [1,2]是状态1中的对象在时间t处于状态的概率2在时间t + 1）。请注意，这些只是组成数字来测试test1和test2（见下文）给出相同的结果，因为我确定手工计算（test1）是正确的。
X <- array((0),dim=c(3,3))
X[1,1] <- 0.1
X[1,2] <- 0.2
X[1,3] <- 0.3
X[2,1] <- 0.4
X[2,2] <- 0.5
X[2,3] <- 0.6
X[3,1] <- 0.7
X[3,2] <- 0.8
X[3,3] <- 0.9
简化了这个例子。我将最终为每个时间间隔都有一个单独的状态*状态转换矩阵，因为转换是时间相关的。为简单起见，我还从示例中删除了观察概率。随着观察概率的包含（因为它最终需要），每个单元描述了第一次观察该单元的状态和时间中对象的概率。 X的每个元素由生存参数（对于时间t的状态i）和转变参数（对于时间t的t-1到状态j的状态i）组成。我将在模型中单独推导出这些组件，我不认为这部分会太困难。
回到下面给出的例子。我已经手动计算（test1）样本时刻4的状态2的概率，当释放状态（样本场合1之前的时间间隔）为1.该计算包括所有可能的到达状态2的方式的乘积之和从时间间隔的状态1。
test1 <-
(X[1,1]*X[1,1]*X[1,1]*X[1,2])+
(X[1,1]*X[1,1]*X[1,2]*X[2,2])+
(X[1,1]*X[1,1]*X[1,3]*X[3,2])+
(X[1,1]*X[1,2]*X[2,1]*X[1,2])+
(X[1,1]*X[1,2]*X[2,2]*X[2,2])+
(X[1,1]*X[1,2]*X[2,3]*X[3,2])+
(X[1,1]*X[1,3]*X[3,1]*X[1,2])+
(X[1,1]*X[1,3]*X[3,2]*X[2,2])+
(X[1,1]*X[1,3]*X[3,3]*X[3,2])+
(X[1,2]*X[2,1]*X[1,1]*X[1,2])+
(X[1,2]*X[2,1]*X[1,2]*X[2,2])+
(X[1,2]*X[2,1]*X[1,3]*X[3,2])+
(X[1,2]*X[2,2]*X[2,1]*X[1,2])+
(X[1,2]*X[2,2]*X[2,2]*X[2,2])+
(X[1,2]*X[2,2]*X[2,3]*X[3,2])+
(X[1,2]*X[2,3]*X[3,1]*X[1,2])+
(X[1,2]*X[2,3]*X[3,2]*X[2,2])+
(X[1,2]*X[2,3]*X[3,3]*X[3,2])+
(X[1,3]*X[3,1]*X[1,1]*X[1,2])+
(X[1,3]*X[3,1]*X[1,2]*X[2,2])+
(X[1,3]*X[3,1]*X[1,3]*X[3,2])+
(X[1,3]*X[3,2]*X[2,1]*X[1,2])+
(X[1,3]*X[3,2]*X[2,2]*X[2,2])+
(X[1,3]*X[3,2]*X[2,3]*X[3,2])+
(X[1,3]*X[3,3]*X[3,1]*X[1,2])+
(X[1,3]*X[3,3]*X[3,2]*X[2,2])+
(X[1,3]*X[3,3]*X[3,3]*X[3,2])
test1 # = 0.9288
我编写了一个for循环，简化了每个发布状态的计算（test2）并重新捕获状态。问题是，在更多的时间间隔内，我的方法将最终计算出具有很多维度的阵列上的产品总和，并且我担心它在JAGS中的计算成本非常高。
test2 <- array((0),dim=c(3,3,3,3,3))
for (m in 1:3){
for (i in 1:3){
for (j in 1:3){
for (k in 1:3){
for (s in 1:3){
test2[m,i,j,k,s] <- X[m,i]*X[i,j]*X[j,k]*X[k,s]
}
}
}
}
}
sumtest2 <- sum(test2[1,,,,2]) # probability of state 2 at observation
# time 4 after release in state 1 at
# release time 1.
test2
sumtest2 # = 0.9288 (the same as test1 and therefore the correct result)
我的问题是什么可能是一种更有效的方法来实现同样的事情？
谢谢。
感谢Dex提供了非常有用的答案。关于时间依赖的转换矩阵，我有一个跟进问题。上面的代码效果很好，但是我无法将它用于不同的迭代次数，其中转换矩阵在每次迭代时都不同。
对于每个发布时间 t ，都有T- t 重新捕获的场合（其中T是研究年份的总数）。我想矩阵乘以匹配第一次可能重新捕获的时间到最后重新捕获时间的矩阵。
这是我想要实现的长版本的一部分：
# This long version does work, with lines for release occasion 1
# and recapture occasions 1:4 only:
pr2 <- array((0), dim=c(3,3,4,4))
pr2[,,1,1] <- diag(1, 3, 3) %*% (X[,,1])
pr2[,,1,2] <- diag(1, 3, 3) %*% (X[,,1] %*% X[,,2])
pr2[,,1,3] <- diag(1, 3, 3) %*% (X[,,1] %*% X[,,2] %*% X[,,3])
pr2[,,1,4] <- diag(1, 3, 3) %*% (X[,,1] %*% X[,,2] %*% X[,,3] %*% X[,,4])
我尝试使用额外的索引时间，然后使用带循环乘法的for循环：
# With time dependence:
X <- array((0),dim=c(3,3,4))
X[1,1,1] <- 0.1
X[1,2,1] <- 0.2
X[1,3,1] <- 0.7
X[2,1,1] <- 0.25
X[2,2,1] <- 0.35
X[2,3,1] <- 0.4
X[3,1,1] <- 0.15
X[3,2,1] <- 0.25
X[3,3,1] <- 0.6
X[,,2] <- X[,,1]+0.05
X[,,3] <- X[,,1]-0.05
X[,,4] <- X[,,1]+0.1
# not working:
library(expm)
for (t in 1:4){
for (j in t:4){
pr1[,,t,j] <- diag(1, 3, 3) %*% (X[,,j]%^%j)
}
}
# This also doesn't work:
library(expm)
for (t in 1:4){
for (j in t:4){
pr1[,,t,j] <- diag(1, 3, 3) %*% (X[,,j]%^%1:j)
}
}
我也尝试过列表方法：
# List approach
# With time dependence:
X1 <- array((0),dim=c(3,3))
X1[1,1] <- 0.1
X1[1,2] <- 0.2
X1[1,3] <- 0.7
X1[2,1] <- 0.25
X1[2,2] <- 0.35
X1[2,3] <- 0.4
X1[3,1] <- 0.15
X1[3,2] <- 0.25
X1[3,3] <- 0.6
X2 <- X1+0.05
X3 <- X1-0.05
X4 <- X1+0.1
XT <- list(X1,X2,X3,X4)
pr1 <- array((0), dim=c(3,3,4,4))
# This also doesn't work:
library(expm)
for (t in 1:4){
for (j in t:4){
pr1[,,t,j] <- diag(1, 3, 3) %*% (XT[[1:j]]%^%j)
}
}
以下代码显示了计算时间相关数组中概率的很长方法。它给出了正确的值。完整地写出这个（有23个发布时间和23个重新捕获时间，3个释放/重新捕获状态），虽然可能效率低，特别是如果分析需要稍后调整。这仅显示了在第一次发布时首次发布的个人的前四次重新捕获时间。每个单元格给出了第一次首次重新捕获个体的概率。重新捕获概率由p给出，因此非重新捕获的概率由1-p给出。在我的分析中，T和p是要估计的参数。这里定义了它们的值，以确保机制按预期工作。
# Make a 3D transition matrix T where z-dimension is time
T_states <- 3
T_terms <- 4
Tz <- 4
T <- array(runif(T_states * T_states * Tz)/1.5, dim = c(T_states, T_states, Tz))
# Normalise by rows - this step ensures rows sum to 1
for (z in seq(Tz)) {
T[, , z] <- T[, , z] / apply(T[, , z], 1, sum)
}
# state and time dependent recapture probability array [,recapture state,occasion]
# the first dimension is needed to repeat p across release states
p <- array((0),dim=c(3,3,4))
p[,1,1] <- 0.5
p[,1,2] <- 0.55
p[,1,3] <- 0.6
p[,1,4] <- 0.65
p[,2,1] <- 0.6
p[,2,2] <- 0.65
p[,2,3] <- 0.7
p[,2,4] <- 0.75
p[,3,1] <- 0.7
p[,3,2] <- 0.75
p[,3,3] <- 0.8
p[,3,4] <- 0.85
# Put them together (with 1-p for earlier recapture occasions):
pr2 <- array((0), dim=c(3,3,4,4))
pr2[,,1,1] <- diag(1, 3, 3) %*% (T[,,1]*p[,,1])
pr2[,,1,2] <- diag(1, 3, 3) %*% ((T[,,1]*(1-p[,,1])) %*% (T[,,2]*p[,,2]))
pr2[,,1,3] <- diag(1, 3, 3) %*% ((T[,,1]*(1-p[,,1])) %*% (T[,,2]*(1-p[,,2])) %*% (T[,,3]*p[,,1]))
pr2[,,1,4] <- diag(1, 3, 3) %*% ((T[,,1]*(1-p[,,1])) %*% (T[,,2]*(1-p[,,2])) %*% (T[,,3]*(1-p[,,3])) %*% (T[,,4]*p[,,4]))
pr2[,,1,]
我还没有找到一种方法来为此编写更有效的代码，它提供相同的值（有很多方法可以提供不正确的值）。
答案 0 :(得分：3)
你可以用矩阵乘法来解决这个问题。可以将转移矩阵矩阵相乘，以在多次迭代中给出转换矩阵。对于四次迭代，我们这样做了四次：
(X %*% X %*% X %*% X)
您还可以使用%^%包中的expm运算符进行矩阵求幂，并且不必将其写出来。
为了找出在四次迭代后状态1中状态1开始的对象开始的可能性，我们可以将其表示为1x3矩阵并将其乘以转换矩阵四次。
matrix(c(1, 0, 0), nrow = 1, ncol = 3) %*% (X %*% X %*% X %*% X)
这给出了它处于三种状态的概率：
[,1] [,2] [,3]
[1,] 0.756 0.9288 1.1016
<强>时序
我根据您的代码创建了另一个示例，其中包含具有合理概率的转换矩阵。矩阵乘法比for循环快约100倍，并给出相同的答案。
library("microbenchmark")
X <- array((0),dim=c(3,3))
X[1,1] <- 0.1
X[1,2] <- 0.2
X[1,3] <- 0.7
X[2,1] <- 0.25
X[2,2] <- 0.35
X[2,3] <- 0.4
X[3,1] <- 0.15
X[3,2] <- 0.25
X[3,3] <- 0.6
microbenchmark(
{test2 <- array((0),dim=c(3,3,3,3,3))
for (m in 1:3){
for (i in 1:3){
for (j in 1:3){
for (k in 1:3){
for (s in 1:3){
test2[m,i,j,k,s] <- X[m,i]*X[i,j]*X[j,k]*X[k,s]
}
}
}
}
}
sumtest2 <- sum(test2[1,,,,2])},
matrix(c(1, 0, 0), nrow = 1, ncol = 3) %*% X %*% X %*% X %*% X
)