Variables d'échelle sur une fenêtre de date de déplacement dans R: le script fonctionne, mais d'une manière inacceptable. Façons d'optimiser?

Question

rstats

J'ai une trame de données, où chaque lignes représentent des données pour une catégorie spécifique à un jour spécifique:

set.seed(1) 
k <- 10 
df <- data.frame(
    name = c(rep('a',k), rep('b',k)), 
    date = rep(seq(as.Date('2017-01-01'),as.Date('2017-01-01')+k-1, 'days'),2), 
    x = runif(2*k,1,20), 
    y = runif(2*k,100,300) 
    ) 
View(df) 

Head:

head(df) 
    name  date   x  y 
1 a 2017-01-01 6.044665 286.9410 
2 a 2017-01-02 8.070354 142.4285 
3 a 2017-01-03 11.884214 230.3348 
4 a 2017-01-04 18.255948 125.1110 
5 a 2017-01-05 4.831957 153.4441 
6 a 2017-01-06 18.069404 177.2228 

Structure:

str(df) 
'data.frame': 20 obs. of 4 variables: 
$ name: Factor w/ 2 levels "a","b": 1 1 1 1 1 1 1 1 1 1 ... 
$ date: Date, format: "2017-01-01" "2017-01-02" "2017-01-03" "2017-01-04" ... 
$ x : num 6.04 8.07 11.88 18.26 4.83 ... 
$ y : num 287 142 230 125 153 ... 

J'ai besoin pour mettre à l'échelle les variables x et y de ces données sur une fenêtre de date spécifique. Le script que je suis venu avec est la suivante:

library(dplyr) 
library(lubridate) 
df2 <- df 
moving_window_days <- 4 

##Iterate over each row in df 
for(i in 1:nrow(df)){ 
    df2[i,] <- df %>% 
     ##Give me only rows for 'name' on the current row 
     ##which are within the date window of interest 
     filter(date <= date(df[i,"date"]) & 
       date >= date(df[i,"date"]) - moving_window_days & 
       name == df[i,"name"] 
       ) %>% 
     ##Now scale x and y on this date wondow 
     mutate(x = percent_rank(x), 
       y = percent_rank(y) 
     ) %>% 
     ##Get rid of the rest of the rows - leave only the row we are looking at 
     filter(date == date(df[i,"date"])) 
} 

Il fonctionne comme prévu (bien, je voulais d'abord pour obtenir le centile de chaque observation dans une fenêtre mobile, mais mis à l'échelle des valeurs fonctionnera très bien) Le problème est que l'ensemble de données réel est beaucoup plus grand:

• 'name' colonne a 30 bureaux locaux
• 'date' est au moins une valeur d'année de données pour chaque branche
• au lieu de 'x' et 'y' je 6 variables
• la fenêtre mobile est de 90 jours

Je courais ce script sur les données réelles, et de 30 000 lignes elle a pu passer seulement 5,000 en 4 heures ... C'est la première fois que je rencontre un problème comme celui-ci.

Je suis sûr que mon script est très inefficace (je suis sûr parce que je ne suis pas un pro dans R. Je suppose que il y a toujours une meilleure façon)

De toute façon ce script peut être optimisé/amélioré?

• Une manière de 'purrrify' (utiliser certaines des fonctions mappurrr)?
• Image imbriquée? nest()? Pensant que c'est une solution ... Je ne sais pas comment mettre en œuvre ...

Tout ce que je peux faire pour lutter contre le problème peut-être d'une manière différente?

Answer 1

Une chose que vous pouvez faire est le traitement parallèle. J'utilise le package future pour cela. Cela peut agacer certains, qui peuvent considérer cela comme un hack, parce que le futur paquet est destiné ... Eh bien ... Pour les futures (ou "promesses" si vous êtes un développeur frontal). Cette approche est fastidieuse, mais fonctionne très bien.

library(future) 

    # Create a function that iterates over each row in the df: 
    my_function <- function(df, x) { 
      x <- df 
     for(i in 1:nrow(df)){ 
      x[i, ] <- df %>% 
       ##Give me only rows for 'name' on the current row 
       ##which are within the date window of interest 
       filter(date <= date(df[i,"date"]) & 
        date >= date(df[i,"date"]) - moving_window_days & 
        name == df[i,"name"] 
        ) %>% 
       ##Now scale x and y on this date wondow 
       mutate(x = percent_rank(x), 
        y = percent_rank(y) 
      ) %>% 
       ##Get rid of the rest of the rows - leave only the row we are looking at 
       filter(date == date(df[i,"date"])) 
     } 
      return(x) 
    } 

    plan(multiprocess) # make sure to always include this in a run of the code. 

    # Divide df evenly into three separate dataframes: 
    df1 %<-% my_function(df[1:7, ], df1) 
    df2 %<-% my_function(df = df[(8 - moving_window_days):14, ], df2) # But from here on out, go back 4 days to include that data in the moving average calculation. 
    df3 %<-% my_function(df = df[(15 - moving_window_days):20, ], df3) 

# See if your computer is able to split df into 4 or 5 separate dataframes. 

    # Now bind the dataframes together, but get the indexing right: 
    rbind(df1, df2[(nrow(df2) - 6):nrow(df2), ], df3[(nrow(df3) - 5):nrow(df3), ]) 

Le traitement parallèle est l'une des nombreuses façons d'optimiser le code pour en améliorer l'efficacité.Cette technique exacte a sensiblement accéléré le code pour moi dans le passé. Il a réduit le temps d'exécution d'un programme d'un jour et demi, jusqu'à 3 ou 4 heures!

Maintenant, idéalement, nous aimerions travailler avec la famille d'application et les matrices. Cette réponse n'est que l'une des nombreuses façons d'accélérer le code. En outre, le paquet future nous permet de processus parallèle sans l'apprentissage d'une nouvelle structure de mise en boucle, comme dans le paquet parallel (qui, néanmoins, est encore un ensemble étonnant.)

Consultez également le package Rcpp. Ça va prendre du temps à apprendre, mais c'est incroyable pour débloquer la vitesse de C++.

Answer 2

@OP Vous devez être prudent avec les réponses fournies

--Mon originale réponse--

library(tidyverse) 

j'ai split la trame de données dans une liste de trames de données regroupées par

split.df <- split(df, df$name) 

En utilisant les données de fractionnement, nous e lapply et map_df pour parcourir les lignes de chaque df groupée, filter pour les dates entre la fenêtre de temps pertinente en utilisant between, puis mutate comme vous le faisiez auparavant, puis filter pour la ligne correspondante à nouveau (j'ai essayé de 'copier' votre code de près possible):

new <- lapply(split.df, function(z) map_df(1:nrow(z), ~z %>% 
               filter(between(date, z$date[.x]-moving_window_days, z$date[.x])) %>% 
               mutate(x=percent_rank(x),y=percent_rank(y)) %>% 
               filter(date==z$date[.x]))) 

Il en résulte un list. Pour reconvertir en une seule trame de données

final <- Reduce("rbind",new) 

sortie (head)

name  date   x y 
1  a 2017-01-01 0.0000000 0.00 
2  a 2017-01-02 1.0000000 0.00 
3  a 2017-01-03 1.0000000 0.50 
4  a 2017-01-04 1.0000000 0.00 

Assurons mon résultat correspond à celui de la vôtre.

identical(final$x, OP.output$x) 
[1] TRUE 

--END de mon réponse-- d'origine

--------------------------- -COMPARING SOLUTIONS ----------------------------

- @ réponse-- Brian @ réponse de Brian fait ne donnez pas le même résultat que vous attendez. Vous avez dit votre fonction works as intended, alors comparons le résultat de Brian avec le vôtre. Le premier montre le résultat de Brian. La seconde montre votre résultat.

 name  date   x  y  x2  y2 
1  a 2017-01-01 6.044665 286.9410 0.0000000 1.0000000 
2  a 2017-01-02 8.070354 142.4285 0.0000000 1.0000000 
3  a 2017-01-03 11.884214 230.3348 0.3333333 0.3333333 
4  a 2017-01-04 18.255948 125.1110 0.3333333 1.0000000 

    name  date   x y 
1  a 2017-01-01 0.0000000 0.00 
2  a 2017-01-02 1.0000000 0.00 
3  a 2017-01-03 1.0000000 0.50 
4  a 2017-01-04 1.0000000 0.00 

identical(Brian.output$x2, OP.output$x,) 
[1] FALSE 

--END @ Brian de réponse--

- @ Ulysse de réponse--

@ réponse d'Ulysse retourne le bon résultat car il utilise votre même fonction, mais vous devez diviser le cadre de données manuellement.Voir son code ci-dessous qui appelle my_function

df1 %<-% my_function(df[1:7, ], df1) 
df2 %<-% my_function(df = df[(8 - moving_window_days):14, ], df2) # But from here on out, go back 4 days to include that data in the moving average calculation. 
df3 %<-% my_function(df = df[(15 - moving_window_days):20, ], df3) 

--END @ Ulysse réponse-- de

Vous êtes susceptible d'obtenir le meilleur gain de performance de réponse @Odysseus, mais vous devrez comparez-le vous-même, car cela dépend du nombre de cœurs que vous avez. La parallélisation n'est pas toujours plus rapide qu'une opération vectorisée. Mais vous devrez étendre sa solution au reste de votre trame de données.

Answer 3

zoo::rollapply peut être assez rapide.

df2 <- df %>% 
    group_by(name) %>% 
    mutate(x2 = zoo::rollapply(x, width = 4, FUN = percent_rank, fill = "extend")[,1], 
     y2 = zoo::rollapply(y, width = 4, FUN = percent_rank, fill = "extend")[,1]) 

Chaque appel à rollapply génère une matrice avec n = width colonnes. La première colonne est la valeur de la fonction pour la fenêtre commençant par cette observation, tandis que la colonne nième est la valeur de la fonction pour la fenêtre se terminant par cette observation. Vous pouvez changer le [,1] à n'importe quelle colonne que vous voulez (le centile au milieu de la fenêtre? À la fin? Au début?).

L'argument fill = "extend" fait double emploi avec les observations au début ou à la fin des fenêtres, depuis les dernières n-k observations il y a k Disparitions de la fenêtre.

J'ai développé votre jeu de données à un nombre fictif de 28 496 lignes, couvrant 26 noms et 3 années de données, et j'ai exécuté cet extrait avec une largeur de 90 jours. Sur mon bureau 4 ans cela a pris moins d'une minute pour deux variables:

user system elapsed 
    37.66 0.01 37.77 

Vous pouvez certainement utiliser purrr::map2 pour itérer plus de 6 variables (au lieu d'appeler rollapply 6 fois dans mutate), mais je ne suis pas sûr cela l'accélérerait considérablement.