r - R在向量上分配权重

Question

假设我在R中有一个 vector

 0    1    0    0    1    0    0    0    0     1     0

vector 中的任何地方都不能超过6个“1”。所有其他元素均为0。

我试图在 的1个位置上分配“1”的所有可能值，每个值必须小于等于0.5。

因此，例如:

0    .2    0    0    .3    0    0    0    0     .5     0 . <- OK

0    .35    0    0    .4    0    0    0    0     .25     0 <- OK

然而

0    .2   0    0    .2    0    0    0    0     .6     0  <- not ok

增量可以增加0.05。

因此，在具有3个“1”的 vector 中，最多存在20 ^ 3个组合，其中许多组合将是不好的，因为它们的总和大于1或值> 0.5。有没有比暴力破解更快的方法？

编辑:
我意识到我可以使用以下方法快速得出所有可能的权重:

temp <- expand.grid(replicate(sum(x),seq(0.05,.5,0.05), simplify=FALSE))

其中x是我的 vector 。

因此，现在对于每个临时人员，我想将其放在1

 0    1    0    0    1    0    0    0    0     1     0

Answer 1

编辑:正如@www在注释中指出的那样，如果您依靠浮点算法，将会错过一些组合/排列。为了解决这个问题，我们需要以整数精度工作(即需要seq(0, 0.5, 0.05)而不是seq(0L, 50L, 5L))并将结果除以100。

我编写了RcppAlgos软件包，该软件包正是针对此类问题的:

library(RcppAlgos)
myCombs <- comboGeneral(seq(0L,50L,5L), 6, TRUE, 
                        constraintFun = "sum", 
                        comparisonFun = "==", 
                        limitConstraints = 100L) / 100
head(myCombs, n = 10)
      [,1] [,2] [,3] [,4] [,5] [,6]
 [1,]    0    0    0 0.00 0.50 0.50
 [2,]    0    0    0 0.05 0.45 0.50
 [3,]    0    0    0 0.10 0.40 0.50
 [4,]    0    0    0 0.10 0.45 0.45
 [5,]    0    0    0 0.15 0.35 0.50
 [6,]    0    0    0 0.15 0.40 0.45
 [7,]    0    0    0 0.20 0.30 0.50
 [8,]    0    0    0 0.20 0.35 0.45
 [9,]    0    0    0 0.20 0.40 0.40
[10,]    0    0    0 0.25 0.25 0.50

tail(myCombs, n = 10)
       [,1] [,2] [,3] [,4] [,5] [,6]
[190,] 0.10 0.10 0.15 0.15 0.15 0.35
[191,] 0.10 0.10 0.15 0.15 0.20 0.30
[192,] 0.10 0.10 0.15 0.15 0.25 0.25
[193,] 0.10 0.10 0.15 0.20 0.20 0.25
[194,] 0.10 0.10 0.20 0.20 0.20 0.20
[195,] 0.10 0.15 0.15 0.15 0.15 0.30
[196,] 0.10 0.15 0.15 0.15 0.20 0.25
[197,] 0.10 0.15 0.15 0.20 0.20 0.20
[198,] 0.15 0.15 0.15 0.15 0.15 0.25
[199,] 0.15 0.15 0.15 0.15 0.20 0.20

如果您对排列感兴趣，那么没问题:

myPerms <- permuteGeneral(seq(0L,50L,5L), 6, TRUE, 
                          constraintFun = "sum", 
                          comparisonFun = "==", 
                          limitConstraints = 100L) / 100

head(myPerms, n = 10)
      [,1] [,2] [,3] [,4] [,5] [,6]
 [1,]    0  0.0  0.0  0.0  0.5  0.5
 [2,]    0  0.0  0.0  0.5  0.0  0.5
 [3,]    0  0.0  0.0  0.5  0.5  0.0
 [4,]    0  0.0  0.5  0.0  0.0  0.5
 [5,]    0  0.0  0.5  0.0  0.5  0.0
 [6,]    0  0.0  0.5  0.5  0.0  0.0
 [7,]    0  0.5  0.0  0.0  0.0  0.5
 [8,]    0  0.5  0.0  0.0  0.5  0.0
 [9,]    0  0.5  0.0  0.5  0.0  0.0
[10,]    0  0.5  0.5  0.0  0.0  0.0

tail(myPerms, n = 10)
         [,1] [,2] [,3] [,4] [,5] [,6]
[41109,] 0.15 0.15 0.20 0.20 0.15 0.15
[41110,] 0.15 0.20 0.15 0.15 0.15 0.20
[41111,] 0.15 0.20 0.15 0.15 0.20 0.15
[41112,] 0.15 0.20 0.15 0.20 0.15 0.15
[41113,] 0.15 0.20 0.20 0.15 0.15 0.15
[41114,] 0.20 0.15 0.15 0.15 0.15 0.20
[41115,] 0.20 0.15 0.15 0.15 0.20 0.15
[41116,] 0.20 0.15 0.15 0.20 0.15 0.15
[41117,] 0.20 0.15 0.20 0.15 0.15 0.15
[41118,] 0.20 0.20 0.15 0.15 0.15 0.15

结果是立即的:

system.time(permuteGeneral(seq(0L,50L,5L), 6, TRUE, 
                           constraintFun = "sum", 
                           comparisonFun = "==", 
                           limitConstraints = 100L) / 100)
 user  system elapsed 
0.005   0.001   0.006

快速思考

人们可能会试图将这一问题作为加法整数分区问题来解决。从 seq(0, 0.5, 0.05)到 0:11都有映射，还有从 seq(0, 1, 0.05)到 0:20的映射。后者对于它为何有用的作用可能并不明显，但确实如此。有一个名为 partitions的非常不错的程序包，它带有一个用于生成受限分区(即，给定长度的分区)的函数。

library(partitions)
myParts <- t(as.matrix(restrictedparts(20, 6))) / 20

head(myParts)
     [,1] [,2] [,3] [,4] [,5] [,6]
[1,] 1.00 0.00    0    0    0    0
[2,] 0.95 0.05    0    0    0    0
[3,] 0.90 0.10    0    0    0    0
[4,] 0.85 0.15    0    0    0    0
[5,] 0.80 0.20    0    0    0    0
[6,] 0.75 0.25    0    0    0    0

如您所见，我们已经违反了数字大于0.5的要求。因此，我们需要做一些额外的工作才能获得最终结果:

myMax <- apply(myParts, 1, max)
myFinalParts <- myParts[-which(myMax > 0.5), ]

head(myFinalParts)
     [,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0.50 0.50 0.00    0    0    0
[2,] 0.50 0.45 0.05    0    0    0
[3,] 0.50 0.40 0.10    0    0    0
[4,] 0.45 0.45 0.10    0    0    0
[5,] 0.50 0.35 0.15    0    0    0
[6,] 0.45 0.40 0.15    0    0    0

tail(myFinalParts, n = 10)
       [,1] [,2] [,3] [,4] [,5] [,6]
[190,] 0.35 0.15 0.15 0.15 0.10 0.10
[191,] 0.30 0.20 0.15 0.15 0.10 0.10
[192,] 0.25 0.25 0.15 0.15 0.10 0.10
[193,] 0.25 0.20 0.20 0.15 0.10 0.10
[194,] 0.20 0.20 0.20 0.20 0.10 0.10
[195,] 0.30 0.15 0.15 0.15 0.15 0.10
[196,] 0.25 0.20 0.15 0.15 0.15 0.10
[197,] 0.20 0.20 0.20 0.15 0.15 0.10
[198,] 0.25 0.15 0.15 0.15 0.15 0.15
[199,] 0.20 0.20 0.15 0.15 0.15 0.15

如您所见，只有列的顺序不同，我们上面的解决方案完全相同(请参阅 myCombs)。

all.equal(myCombs, myFinalParts[,6:1])
[1] TRUE

对于置换部分，这些实际上称为受限整数 compositions。我们可以调用 partitions::compositions并按照与上述类似的方式进行操作，在此我们需要清除那些违反规则的行(即，丢弃包含最大值大于0.5的行)。利用分区有可能获得期望的结果，仅涉及一些额外的步骤。

myComps <- t(as.matrix(compositions(20, 6))) / 20
myMax <- apply(myComps, 1, max)
temp <- myComps[-which(myMax > 0.5), ]
myFinalComps <- temp[do.call(order, as.data.frame(temp)), ]
all.equal(myPerms[do.call(order, as.data.frame(myPerms)), ], myFinalComps)
[1] TRUE