Уменьшить общую сумму векторных элементов в R

Question

в 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)

Можете ли вы придумать способ сделать это?Спасибо!

Answer 1

Вот решение, в котором используются графики из дистрибутива Дирихле:

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.

Answer 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)

И графические результаты:

Answer 3

Предполагая, что 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

Здесь для ZI выбрано определенное бета-распределение, дающее среднее значение perc,но вы могли бы выбрать и другое.Чем ниже дисперсия, тем точнее результат.Например, следующее намного лучше, поскольку ранее выбранный бета-дистрибутив, по сути, является бимодальным:

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!