减少 R 中向量元素的总和答案

【问题标题】：Reduce total sum of vector elements in R减少 R 中向量元素的总和
【发布时间】：2018-11-20 16:55:43
【问题描述】：

在 R 中，我有一个整数向量。从这个向量中，我想随机减少每个整数元素的值，以获得向量的总和，即初始总和的百分比。

在这个例子中，我想将向量“x”归约为向量“y”，其中每个元素都被随机归约以获得等于初始总和 50% 的元素总和。

生成的向量应具有非负值且低于原始值。

set.seed(1)
perc<-50            
x<-sample(1:5,10,replace=TRUE)
xsum<-sum(x) # sum is 33
toremove<-floor(xsum*perc*0.01)
x # 2 2 3 5 2 5 5 4 4 1

y<-magicfunction(x,perc)
y # 0 2 1 4 0 3 2 1 2 1
sum(y) # sum is 16 (rounded half of 33)

你能想出办法吗？谢谢！

【问题讨论】：

也许我很困惑，但我不太明白为什么根据你的描述你不能只做0.5 * x？还有其他一些您没有提到的标准吗？
我们可以假设向量很长吗？至少有 200 个元素？
@JuliusVainora 是的，向量可以任意长
@joran 对不起，我澄清了：向量缩减不应该与每个元素成正比，而是随机的
我是否正确地假设您希望避免计算效率低下的解决方案，例如，对随机整数进行采样，直到它们的总和为 sum(x)/2，然后反复从 x 中随机减去它们，直到得到一个没有负值的向量？

标签： r

【解决方案1】：

假设x 足够长，我们可以依赖一些适当的大数定律（也假设x 在某些其他方面足够规则）。为此，我们将生成另一个随机变量 Z 的值，取值在 [0,1] 中，平均值为 perc。

set.seed(1)
perc <- 50 / 100
x <- sample(1:10000, 1000)
sum(x)
# [1] 5014161
x <- round(x * rbeta(length(x), perc / 3 / (1 - perc), 1 / 3))
sum(x)
# [1] 2550901
sum(x) * 2
# [1] 5101802
sum(x) * 2 / 5014161 
# [1] 1.017479 # One percent deviation

对于 Z，我选择了一个特定的 beta 分布，给出了平均值 perc，但你也可以选择其他的。方差越小，结果越精确。例如，以下情况要好得多，因为之前选择的 beta 分布实际上是双峰分布：

set.seed(1)
perc <- 50 / 100
x <- sample(1:1000, 100)
sum(x)
# [1] 49921
x <- round(x * rbeta(length(x), 100 * perc / (1 - perc), 100))
sum(x)
# [1] 24851
sum(x) * 2
# [1] 49702
sum(x) * 2 / 49921
# [1] 0.9956131 # Less than 0.5% deviation!

【讨论】：

这个解决方案给我留下了深刻的印象！
@FedericoGiorgi，这个 Z 的选择非常重要，正如我在答案中所展示的那样。如果您关心错误，您可以选择一些非常集中在perc 周围的分布，可能只在某个区间 [perc - epsilon, perc + epsilon] 中取值。也就是说，根据您的问题的细节，可以改进解决方案。
当你降低 beta 分布的方差时，你实际上是在做x <- round(perc * x)。
是的，在限制范围内。问题是实际问题需要多少这种随机性（方差）。但是，在保持所需均值的同时，您将无法使用 beta 实现超低方差。所以，那时需要一些其他的分布。
@FedericoGiorgi，在其他属性中，对称性、较低的方差和更窄的可能值区间有助于精度，而更高的方差和更宽的区间会增加“随机性”。因此，您可以尝试使用这些参数。目前，您的问题描述没有提供任何关于这些应该是什么的信息，而且这不再是一个真正的编程问题。

【解决方案2】：

另一种解决方案是此函数，它通过与向量元素大小成比例的随机分数对原始向量进行下采样。然后它检查元素不低于零，并迭代地逼近最优解。

removereads<-function(x,perc=NULL){
xsum<-sum(x)
toremove<-floor(xsum*perc)
toremove2<-toremove
irem<-1
while(toremove2>(toremove*0.01)){
    message("Downsampling iteration ",irem)
    tmp<-sample(1:length(x),toremove2,prob=x,replace=TRUE)
    tmp2<-table(tmp)
    y<-x
    common<-as.numeric(names(tmp2))
    y[common]<-x[common]-tmp2
    y[y<0]<-0
    toremove2<-toremove-(xsum-sum(y))
    irem<-irem+1
}
return(y)
}
set.seed(1)
x<-sample(1:1000,10000,replace=TRUE)
perc<-0.9
y<-removereads(x,perc)
plot(x,y,xlab="Before reduction",ylab="After reduction")
abline(0,1)

以及图形结果：

【讨论】：

【解决方案3】：

这是一个使用 Dirichlet 分布图的解决方案：

set.seed(1)
x = sample(10000, 1000, replace = TRUE)

magic = function(x, perc, alpha = 1){
    # sample from the Dirichlet distribution
    # sum(p) == 1
    # lower values should reduce by less than larger values
    # larger alpha means the result will have more "randomness"
    p = rgamma(length(x), x / alpha, 1)
    p = p / sum(p)

    # scale p up an amount so we can subtract it from x
    # and get close to the desired sum
    reduce = round(p * (sum(x) - sum(round(x * perc))))
    y = x - reduce

    # No negatives
    y = c(ifelse(y < 0, 0, y))

    return (y)
    }

alpha = 500
perc = 0.7
target = sum(round(perc * x))
y = magic(x, perc, alpha)

# Hopefully close to 1
sum(y) / target
> 1.000048

# Measure of the "randomness"
sd(y / x)
> 0.1376637

基本上，它会尝试计算每个元素减少多少，同时仍然接近您想要的总和。你可以通过增加alpha来控制你想要新向量的“随机”程度。

【讨论】：