J'ai un très grand ensemble de données avec des étiquettes catégorielles a et un vecteur b qui contient toutes les étiquettes possibles dans l'ensemble de données:
goal <- numeric() # container for results
for(i in 1:4){
d <- setdiff(b, a[i]) # find the categories except the one observed in the data
goal[i] <- sample(d,1) # sample one of the remaining categories randomly
}
goal
[1] 4 4 1 1
Maintenant, je veux trouver pour chaque observation dans a l'ensemble de toutes les catégories restantes (c'est-à-dire les éléments de b à l'exclusion de l'observation donnée dans a ). À partir de ces catégories restantes, je veux en échantillonner une au hasard.
Mon approche utilisant une boucle est
a <- c(1,1,3,2) # artificial data b <- c(1,2,3,4) # fixed categories
Cependant, cela doit être fait un grand nombre de fois et appliqué à de très grands ensembles de données. Quelqu'un a-t-il une version plus efficace qui mène au résultat souhaité?
EDIT:
La fonction par akrun est malheureusement plus lente que la boucle d'origine. Si quelqu'un a une idée créative avec un résultat compétitif, je suis heureux de l'entendre!
3 Réponses :
Nous pouvons utiliser vapply
set.seed(24) a <- sample(c(1:4), 10000, replace=TRUE) b <- 1:4 system.time(vapply(a, function(x) sample(setdiff(b, x), 1), numeric(1))) # user system elapsed # 0.208 0.007 0.215
vapply(a, function(x) sample(setdiff(b, x), 1), numeric(1))
J'essayais juste de comparer l'évolutivité. Fait intéressant, le code suivant génère une erreur (l'exemple d'origine fonctionne correctement!). Avez-vous une idée pourquoi? a <- sample (c (1: 4), 10000, replace = T) b <- c (1,2,3,4) vapply ( a, function (x) sample (setdiff (b, a), 1), numeric (1)) Erreur dans sample.int (length (x), size, replace, prob): invalide d'abord argument
@ Mr.Zen. dans le setdiff , j'ai eu une faute de frappe, désolé, c'est x
Merci pour la correction! Malheureusement, l'approche proposée est encore plus lente que la boucle d'origine (voir la modification du post supérieur).
@ Mr.Zen. Je pensais que vous souhaitiez utiliser spécifiquement la fonction setdiff .
Désolé de ne pas être clair! Utiliser setdiff n'était que ma première intuition, ce n'est pas du tout nécessaire.
Mise à jour: Voici une version rapide avec mapply . Cette méthode évite d'appeler sample () à chaque itération et est donc un peu plus rapide. -
set.seed(24)
a <- sample(c(1:4), 1000, replace=TRUE)
b <- 1:4
microbenchmark::microbenchmark(
akrun = vapply(a, function(x) sample(setdiff(b, x), 1), numeric(1)),
shree = vapply(a, function(x) sample(b[!b == x], 1), numeric(1)),
shree_mapply = mapply(function(x, y) b[!b == x][y], a, sample(length(b) - 1, length(a), replace = T))
)
Unit: milliseconds
expr min lq mean median uq max neval
akrun 28.7347 30.66955 38.319655 32.57875 37.45455 237.1690 100
shree 5.6271 6.05740 7.531964 6.47270 6.87375 45.9081 100
shree_mapply 1.8286 2.01215 2.628989 2.14900 2.54525 7.7700 100
Voici une version sans setdiff ( setdiff peut être un peu lent) même si je pense que plus d'optimisation est possible . -
vapply(a, function(x) sample(b[!b == x], 1), numeric(1))
Benchmarks -
mapply(function(x, y) b[!b == x][y], a, sample(length(b) - 1, length(a), replace = T))
J'ai essayé sample (b [-x], 1) mais il semble seulement être environ 10% plus rapide
@BenBolker, Désolé, il me manque peut-être quelque chose, mais b [-x] ne supprime pas la x -th valeur et non la valeur x ?
Il s'avère que le rééchantillonnage des libellés égaux aux libellés dans les données est une approche encore plus rapide, en utilisant
Unit: microseconds
expr min lq mean median uq max neval
loop 14337.492 14954.595 16172.2165 15227.010 15585.5960 24071.727 100
akrun 14899.000 15507.978 16271.2095 15736.985 16050.6690 24085.839 100
resample 87.242 102.423 113.4057 112.473 122.0955 174.056 100
shree(data = a, labels = b) 5195.128 5369.610 5472.4480 5454.499 5574.0285 5796.836 100
shree_mapply(data = a, labels = b) 1500.207 1622.516 1913.1614 1682.814 1754.0190 10449.271 100
Benchmarks mis à jour pour N = 10 000:
test = sample(b, length(a), replace=T)
resample = (a == test)
while(sum(resample>0)){
test[resample] = sample(b, sum(resample), replace=T)
resample = (a == test)
}
C'est bien!. "Presque" vectorisé donc ça va être difficile à battre. La seule marge d’amélioration semble être que cela pourrait nécessiter plusieurs itérations while pour rééchantillonner une valeur. J'ai essayé quelques idées pour surmonter cela mais je n'ai pas fonctionné en termes de performances. Quoi qu'il en soit, une belle réflexion originale. +1
C'est fait, merci de l'avoir signalé.