Dans R, j'ai un vecteur d'entiers. A partir de ce vecteur, je voudrais réduire la valeur de chaque élément entier de manière aléatoire, afin d'obtenir une somme du vecteur qui est un pourcentage de la somme initiale.

Dans cet exemple, je voudrais réduire le vecteur "x" à un vecteur "y", où chaque élément a été réduit aléatoirement pour obtenir une somme des éléments égale à 50% de la somme initiale.

Le vecteur résultant doit avoir des valeurs non négatives et inférieures à la valeur d'origine.

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)

Pouvez-vous penser à un moyen de le faire? Merci!

r
4
Federico Giorgi 20 nov. 2018 à 19:55

3 réponses

Meilleure réponse

En supposant que x est suffisamment long, nous pouvons nous fier à une loi appropriée des grands nombres (en supposant également que x est suffisamment régulière de certaines autres manières). Pour cela, nous allons générer des valeurs d'une autre variable aléatoire Z prenant des valeurs dans [0,1] et de moyenne 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

Ici, pour Z, j'ai choisi une certaine distribution bêta donnant la moyenne perc, mais vous pouvez aussi en choisir une autre. Plus la variance est faible, plus le résultat est précis. Par exemple, ce qui suit est bien meilleur car la distribution bêta précédemment choisie est en fait bimodale:

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!
5
Julius Vainora 20 nov. 2018 à 17:27

Une solution alternative est cette fonction, qui sous-échantillonne le vecteur d'origine d'une fraction aléatoire proportionnelle à la taille de l'élément du vecteur. Ensuite, il vérifie que les éléments ne tombent pas en dessous de zéro et approche de manière itérative une solution optimale.

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)

Et les résultats graphiques: Downsampling R vector

3
Federico Giorgi 21 nov. 2018 à 01:50

Voici une solution qui utilise des tirages de la distribution 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

Fondamentalement, il essaie de déterminer de combien réduire chaque élément tout en se rapprochant de la somme souhaitée. Vous pouvez contrôler le caractère "aléatoire" souhaité du nouveau vecteur en augmentant alpha.

1
mickey 20 nov. 2018 à 18:21