假设我可以沿着5个长度的向量分配100％的重量。但是，我不能将权重放入两个相邻的值中，并且任何值都不能超过50％。
例如
[0, .5, 0, 0, .5] is good
[.5, .5, 0, 0,0] is not good
[.2, 0, .2, 0, .6] is good
[.2, 0, .2, .2, .2] is not good
我想生成10,000个这样的向量，以便从中进行蒙特卡洛模拟。
我想我可以用expand.grid来做到这一点，但我不确定如何做到。
我可以生成一个随机的，然后：
nonzero_weights = which(starting_weights>0)
grid_positions = expand.grid(startingPos = nonzero_weights, endingPos = nonzero_weights)
然后进行一些过滤和删除，但这看起来很混乱。如果不需要它们，为什么还要生成它们。有没有更清洁的方法可以做到这一点？
答案 0 :(得分：1)
首先，您可以通过从上一个样本中删除样本索引来生成二进制样本。然后生成要分配给这些二进制样本的权重：
idx <- 1:11
system.time(
binsampl <- t(replicate(10000L, {
x <- rep(0L, length(idx))
while(length(idx) > 0L) {
chosen <- if (length(idx) > 1L) sample(idx, 1L) else idx
idx <- setdiff(idx, chosen + -1L:1L)
x[chosen] <- 1L
}
x
}))
)
system.time(
weights <- t(apply(binsampl, 1, function(s) {
y <- runif(sum(s))
s[s==1L] <- y/sum(y)
s
}))
)
head(weights)
输出：
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9]
[1,] 0.114636912 0.00000000 0.1136963 0.0000000 0.00000000 0.1938791 0.00000000 0.3495739 0.00000000
[2,] 0.267907091 0.00000000 0.1487623 0.0000000 0.21628596 0.0000000 0.08326985 0.0000000 0.03803797
[3,] 0.000000000 0.06195168 0.0000000 0.0000000 0.07972502 0.0000000 0.00000000 0.3749550 0.00000000
[4,] 0.083384611 0.00000000 0.0000000 0.3867607 0.00000000 0.0000000 0.16300188 0.0000000 0.00000000
[5,] 0.005233208 0.00000000 0.4106275 0.0000000 0.15796746 0.0000000 0.10168549 0.0000000 0.00000000
[6,] 0.188153707 0.00000000 0.1867017 0.0000000 0.29426748 0.0000000 0.00000000 0.2962538 0.00000000
[,10] [,11]
[1,] 0.2282138 0.0000000
[2,] 0.0000000 0.2457368
[3,] 0.0000000 0.4833683
[4,] 0.3668528 0.0000000
[5,] 0.3244863 0.0000000
[6,] 0.0000000 0.0346233
使用R-3.5.1 Windows x64 8GB RAM 2.8GHz处理器，在我的计算机上生成1万个样本所需的时间不到1秒。
答案 1 :(得分：1)
如果我们没有邻接限制，那么使用R当前可用的工具就不会那么困难（请参阅this answer更多信息）。由于存在邻接限制，我们需要做更多的工作才能获得所需的结果。
我们首先要注意，由于向量的行中不能包含2个连续的数字，这些向量具有 n 列（OP在注释中阐明，它们需要 n = 11 因此我们将其用作测试用例），即具有值的最大列数等于11 - floor(11 / 2) = 6。当列1 3 5 7 9 11中存在值时，就会发生这种情况。我们还应注意，由于最大值限制为0.5，并且我们需要将行的总和设为1，因此自ceiling(1 / 0.5) = 2起，具有该值的最小列数等于2。有了这些信息，我们就可以开始攻击。
我们首先生成11选择2到6的每个组合。然后筛选出违反邻接限制的组合。可以通过取每一行的diff并检查任何结果差是否等于1来轻松实现后一部分。请注意（注意，我们使用RcppAlgos（我是作者）进行所有计算）：
library(RcppAlgos)
vecLen <- 11L
lowComb <- as.integer(ceiling(1 / 0.5))
highComb <- 6L
numCombs <- length(lowComb:highComb)
allCombs <- lapply(lowComb:highComb, function(x) {
comboGeneral(vecLen, x)
})
validCombs <- lapply(allCombs, function(x) {
which(apply(x, 1, function(y) {
!any(diff(y) == 1L)
}))
})
combLen <- lengths(validCombs)
combLen
[1] 45 84 70 21 1
## subset each matrix of combinations using the
## vector of validCombs obtained above
myCombs <- lapply(seq_along(allCombs), function(x) {
allCombs[[x]][validCombs[[x]], ]
})
我们现在需要找到所有上面计算出的每个可能长度的seq(0.05, 0.5, 0.05)的所有组合，总和为1。使用comboGeneral的约束功能，这很容易：
combSumOne <- lapply(lowComb:highComb, function(x) {
comboGeneral(seq(5L,50L,5L), x, TRUE,
constraintFun = "sum",
comparisonFun = "==",
limitConstraints = 100L) / 100
})
groupLen <- sapply(combSumOne, nrow)
groupLen
1 13 41 66 78
现在，我们使用上面的myCombs创建一个具有所需列数的矩阵并将其填充为所有可能的组合，以确保满足邻接要求。
myCombMat <- matrix(0L, nrow = sum(groupLen * combLen), ncol = vecLen)
s <- g <- 1L
e <- combRow <- nrow(combSumOne[[1L]])
for (a in myCombs[-numCombs]) {
for (i in 1:nrow(a)) {
myCombMat[s:e, a[i, ]] <- combSumOne[[g]]
s <- e + 1L
e <- e + combRow
}
e <- e - combRow
g <- g + 1L
combRow <- nrow(combSumOne[[g]])
e <- e + combRow
}
## the last element in myCombs is simply a
## vector, thus nrow would return NULL
myCombMat[s:e, myCombs[[numCombs]]] <- combSumOne[[g]]
以下是输出内容：
head(myCombMat)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]
[1,] 0.5 0 0.5 0.0 0.0 0.0 0.0 0.0 0 0 0
[2,] 0.5 0 0.0 0.5 0.0 0.0 0.0 0.0 0 0 0
[3,] 0.5 0 0.0 0.0 0.5 0.0 0.0 0.0 0 0 0
[4,] 0.5 0 0.0 0.0 0.0 0.5 0.0 0.0 0 0 0
[5,] 0.5 0 0.0 0.0 0.0 0.0 0.5 0.0 0 0 0
[6,] 0.5 0 0.0 0.0 0.0 0.0 0.0 0.5 0 0 0
tail(myCombMat)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]
[5466,] 0.10 0 0.10 0 0.20 0 0.20 0 0.20 0 0.20
[5467,] 0.10 0 0.15 0 0.15 0 0.15 0 0.15 0 0.30
[5468,] 0.10 0 0.15 0 0.15 0 0.15 0 0.20 0 0.25
[5469,] 0.10 0 0.15 0 0.15 0 0.20 0 0.20 0 0.20
[5470,] 0.15 0 0.15 0 0.15 0 0.15 0 0.15 0 0.25
[5471,] 0.15 0 0.15 0 0.15 0 0.15 0 0.20 0 0.20
set.seed(42)
mySamp <- sample(nrow(myCombMat), 10)
sampMat <- myCombMat[mySamp, ]
rownames(sampMat) <- mySamp
sampMat
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]
5005 0.00 0.05 0.00 0.05 0.00 0.15 0.00 0.35 0.00 0.4 0.00
5126 0.00 0.15 0.00 0.15 0.00 0.20 0.00 0.20 0.00 0.0 0.30
1565 0.10 0.00 0.15 0.00 0.00 0.00 0.25 0.00 0.00 0.5 0.00
4541 0.05 0.00 0.05 0.00 0.00 0.15 0.00 0.00 0.25 0.0 0.50
3509 0.00 0.00 0.15 0.00 0.25 0.00 0.25 0.00 0.00 0.0 0.35
2838 0.00 0.10 0.00 0.15 0.00 0.00 0.35 0.00 0.00 0.0 0.40
4026 0.05 0.00 0.10 0.00 0.15 0.00 0.20 0.00 0.50 0.0 0.00
736 0.00 0.00 0.10 0.00 0.40 0.00 0.00 0.00 0.00 0.0 0.50
3590 0.00 0.00 0.15 0.00 0.20 0.00 0.00 0.30 0.00 0.0 0.35
3852 0.00 0.00 0.00 0.05 0.00 0.20 0.00 0.30 0.00 0.0 0.45
all(rowSums(myCombMat) == 1)
[1] TRUE
如您所见，每一行总计为1，并且没有相邻的值。
如果您真的想要置换，我们可以生成seq(0.05, 0.5, 0.05)的所有置换，每个置换的总和为1（就像我们对组合所做的一样）：
permSumOne <- lapply(lowComb:highComb, function(x) {
permuteGeneral(seq(5L,50L,5L), x, TRUE,
constraintFun = "sum",
comparisonFun = "==",
limitConstraints = 100L) / 100
})
groupLenPerm <- sapply(permSumOne, nrow)
groupLenPerm
[1] 1 63 633 3246 10872
并使用它们来创建所有可能的总和为1并满足邻接要求的矩阵：
myPermMat <- matrix(0L, nrow = sum(groupLenPerm * combLen), ncol = vecLen)
s <- g <- 1L
e <- permRow <- nrow(permSumOne[[1L]])
for (a in myCombs[-numCombs]) {
for (i in 1:nrow(a)) {
myPermMat[s:e, a[i, ]] <- permSumOne[[g]]
s <- e + 1L
e <- e + permRow
}
e <- e - permRow
g <- g + 1L
permRow <- nrow(permSumOne[[g]])
e <- e + permRow
}
## the last element in myCombs is simply a
## vector, thus nrow would return NULL
myPermMat[s:e, myCombs[[numCombs]]] <- permSumOne[[g]]
再次，这是输出的一瞥：
head(myPermMat)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]
[1,] 0.5 0 0.5 0.0 0.0 0.0 0.0 0.0 0 0 0
[2,] 0.5 0 0.0 0.5 0.0 0.0 0.0 0.0 0 0 0
[3,] 0.5 0 0.0 0.0 0.5 0.0 0.0 0.0 0 0 0
[4,] 0.5 0 0.0 0.0 0.0 0.5 0.0 0.0 0 0 0
[5,] 0.5 0 0.0 0.0 0.0 0.0 0.5 0.0 0 0 0
[6,] 0.5 0 0.0 0.0 0.0 0.0 0.0 0.5 0 0 0
tail(myPermMat)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]
[128680,] 0.15 0 0.20 0 0.20 0 0.15 0 0.15 0 0.15
[128681,] 0.20 0 0.15 0 0.15 0 0.15 0 0.15 0 0.20
[128682,] 0.20 0 0.15 0 0.15 0 0.15 0 0.20 0 0.15
[128683,] 0.20 0 0.15 0 0.15 0 0.20 0 0.15 0 0.15
[128684,] 0.20 0 0.15 0 0.20 0 0.15 0 0.15 0 0.15
[128685,] 0.20 0 0.20 0 0.15 0 0.15 0 0.15 0 0.15
all(rowSums(myPermMat) == 1)
[1] TRUE
并且，如OP所述，如果我们要随机选择10000个，我们可以使用sample来实现：
set.seed(101)
mySamp10000 <- sample(nrow(myPermMat), 10000)
myMat10000 <- myPermMat[mySamp10000, ]
rownames(myMat10000) <- mySamp10000
head(myMat10000)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11]
47897 0.00 0.0 0.00 0.50 0.0 0.25 0.0 0.00 0.05 0.0 0.20
5640 0.25 0.0 0.15 0.00 0.1 0.00 0.5 0.00 0.00 0.0 0.00
91325 0.10 0.0 0.00 0.15 0.0 0.40 0.0 0.00 0.20 0.0 0.15
84633 0.15 0.0 0.00 0.35 0.0 0.30 0.0 0.10 0.00 0.1 0.00
32152 0.00 0.4 0.00 0.05 0.0 0.00 0.0 0.25 0.00 0.3 0.00
38612 0.00 0.4 0.00 0.00 0.0 0.35 0.0 0.10 0.00 0.0 0.15
由于RcppAlgos的效率很高，因此上述所有步骤都会立即返回。在我的2008 Windows计算机i5 2.5 GHz上，整个过程（包括排列）花费的时间不到0.04秒。