R: l'accélération de groupe "par" opérations de

Question

J'ai une simulation qui a une énorme agrégat et de combiner étape dans le milieu. J'ai fait un prototype de ce processus en utilisant plyr de ddply() fonction qui fonctionne très bien pour un pourcentage énorme de mes besoins. Mais j'ai besoin de cette agrégation étape pour être plus rapide car je dois courir 10K simulations. Je suis déjà mise à l'échelle des simulations en parallèle, mais si cette première étape ont été plus vite que je pouvais diminuer considérablement le nombre de nœuds dont j'ai besoin.

Voici une simplification raisonnable de ce que je suis en train de faire:

library(Hmisc)

# Set up some example data
year <-    sample(1970:2008, 1e6, rep=T)
state <-   sample(1:50, 1e6, rep=T)
group1 <-  sample(1:6, 1e6, rep=T)
group2 <-  sample(1:3, 1e6, rep=T)
myFact <-  rnorm(100, 15, 1e6)
weights <- rnorm(1e6)
myDF <- data.frame(year, state, group1, group2, myFact, weights)

# this is the step I want to make faster
system.time(aggregateDF <- ddply(myDF, c("year", "state", "group1", "group2"),
                     function(df) wtd.mean(df$myFact, weights=df$weights)
                                 )
           )

Tous les conseils ou suggestions sont appréciées!

Answer 1

Au lieu de la normale R bloc de données, vous pouvez utiliser un immuable bloc de données qui renvoie les pointeurs à l'original lorsque vous sous-ensemble et peut être beaucoup plus rapide:

idf <- idata.frame(myDF)
system.time(aggregateDF <- ddply(idf, c("year", "state", "group1", "group2"),
   function(df) wtd.mean(df$myFact, weights=df$weights)))

#    user  system elapsed 
# 18.032   0.416  19.250 

Si je devais écrire un plyr fonction personnalisée exactement à cette situation, j'aimerais faire quelque chose comme ceci:

system.time({
  ids <- id(myDF[c("year", "state", "group1", "group2")], drop = TRUE)
  data <- as.matrix(myDF[c("myFact", "weights")])
  indices <- plyr:::split_indices(seq_len(nrow(data)), ids, n = attr(ids, "n"))

  fun <- function(rows) {
    weighted.mean(data[rows, 1], data[rows, 2])
  }
  values <- vapply(indices, fun, numeric(1))

  labels <- myDF[match(seq_len(attr(ids, "n")), ids), 
    c("year", "state", "group1", "group2")]
  aggregateDF <- cbind(labels, values)
})

# user  system elapsed 
# 2.04    0.29    2.33 

Il est donc beaucoup plus rapide car elle évite de copier les données, seulement extraire le sous-ensemble nécessaire pour chaque calcul lorsqu'il est calculé. La commutation des données de forme de matrice donne un autre boost de vitesse parce que la matrice subsetting est beaucoup plus rapide que la trame de données subsetting.

Answer 2

Plus de 2x plus rapide et plus concis code:

library(data.table)
dtb <- data.table(myDF, key="year, state, group1, group2")
system.time( 
  res <- dtb[, weighted.mean(myFact, weights), by=list(year, state, group1, group2)] 
)
#   user  system elapsed 
#  0.950   0.050   1.007 

Mon premier post, donc s'il vous plaît être sympa ;)

---

D' data.table v1.9.2, setDT fonction est exportée qui va convertir data.frame de data.table par référence (en gardant data.table le langage - tous set* fonctions de modifier l'objet par référence). Cela signifie, pas de copie inutile, et est donc rapide. Vous pouvez de temps, mais ça va être négligent.

require(data.table)
system.time({
  setDT(myDF)
  res <- myDF[, weighted.mean(myFact, weights), 
             by=list(year, state, group1, group2)] 
})
#   user  system elapsed 
#  0.970   0.024   1.015 

C'est par opposition à 1.264 secondes avec l'OP de la solution ci-dessus, où l' data.table(.) est utilisé pour créer dtb.

Answer 3

Je voudrais profil de la base de R

g <- with(myDF, paste(year, state, group1, group2))
x <- with(myDF, c(tapply(weights * myFact, g, sum) / tapply(weights, g, sum)))
aggregateDF <- myDF[match(names(x), g), c("year", "state", "group1", "group2")]
aggregateDF$V1 <- x

Sur ma machine, il prend 5sec comparer à 67sec avec le code d'origine.

MODIFIER Juste trouvé une autre vitesse avec rowsum fonction de:

g <- with(myDF, paste(year, state, group1, group2))
X <- with(myDF, rowsum(data.frame(a=weights*myFact, b=weights), g))
x <- X$a/X$b
aggregateDF2 <- myDF[match(rownames(X), g), c("year", "state", "group1", "group2")]
aggregateDF2$V1 <- x

Il prend 3sec!

Answer 4

Êtes-vous à l'aide de la dernière version de plyr (note: ce n'est pas fait à tous les CRAN miroirs encore)? Si oui, vous pouvez simplement exécuter en parallèle.

Voici la llply exemple, mais le même principe devrait s'appliquer à ddply:

  x <- seq_len(20)
  wait <- function(i) Sys.sleep(0.1)
  system.time(llply(x, wait))
  #  user  system elapsed 
  # 0.007   0.005   2.005 

  library(doMC)
  registerDoMC(2) 
  system.time(llply(x, wait, .parallel = TRUE))
  #  user  system elapsed 
  # 0.020   0.011   1.038 

Edit:

Bien, d'autres en boucle approches sont le pire, si c'est probablement ce qui nécessite soit (un) code C/C++ ou (b) une remise à plat plus fondamentale de la façon dont vous le faites. Je n'ai même pas essayer d'utiliser by() parce que c'est très lent dans mon expérience.

groups <- unique(myDF[,c("year", "state", "group1", "group2")])
system.time(
aggregateDF <- do.call("rbind", lapply(1:nrow(groups), function(i) {
   df.tmp <- myDF[myDF$year==groups[i,"year"] & myDF$state==groups[i,"state"] & myDF$group1==groups[i,"group1"] & myDF$group2==groups[i,"group2"],]
   cbind(groups[i,], wtd.mean(df.tmp$myFact, weights=df.tmp$weights))
}))
)

aggregateDF <- data.frame()
system.time(
for(i in 1:nrow(groups)) {
   df.tmp <- myDF[myDF$year==groups[i,"year"] & myDF$state==groups[i,"state"] & myDF$group1==groups[i,"group1"] & myDF$group2==groups[i,"group2"],]
   aggregateDF <- rbind(aggregateDF, data.frame(cbind(groups[i,], wtd.mean(df.tmp$myFact, weights=df.tmp$weights))))
}
)

Answer 5

J'ai l'habitude d'utiliser un indice de vecteur avec tapply lorsque la fonction de la mise en œuvre de multiples vecteur args:

system.time(tapply(1:nrow(myDF), myDF[c('year', 'state', 'group1', 'group2')], function(s) weighted.mean(myDF$myFact[s], myDF$weights[s])))
# user  system elapsed 
# 1.36    0.08    1.44 

J'utilise un simple wrapper qui est équivalent, mais cache le désordre:

tmapply(list(myDF$myFact, myDF$weights), myDF[c('year', 'state', 'group1', 'group2')], weighted.mean)

---

Modifié pour inclure tmapply de commentaire ci-dessous:

tmapply = function(XS, INDEX, FUN, ..., simplify=T) {
  FUN = match.fun(FUN)
  if (!is.list(XS))
    XS = list(XS)
  tapply(1:length(XS[[1L]]), INDEX, function(s, ...)
    do.call(FUN, c(lapply(XS, `[`, s), list(...))), ..., simplify=simplify)
}