optimisation code pour éviter double boucle

Postez ici vos questions, réponses, commentaires ou suggestions - Les sujets seront ultérieurement répartis dans les archives par les modérateurs

Modérateur : Groupe des modérateurs

Astrid Reilhac
Messages : 4
Enregistré le : 28 Aoû 2020, 09:19

optimisation code pour éviter double boucle

Messagepar Astrid Reilhac » 28 Aoû 2020, 15:04

Bonjour,

Novice dans l’utilisation de R, je cherche à optimiser ce bout de code en évitant si possible la double boucle for...

for (i in 2:(length(periode_interet2)+1)){
+ for (j in 1: length(IPP_list)){
+ tableau1[j,i] <- sum(actes4$compteur[actes4$IPP ==IPP_list[j] & (actes4$DATE>=periode_interet[i-1] &actes4$DATE<=periode_interet[i+20-1])])
+ }
+ }

En effet,
- ma base actes4 contient 240000 lignes,
- ma periode_interet2 est un vecteur de 345 valeurs
- et IPP_list est un vecteur de quelques milliers de valeurs
Faire tourner cette boucle pour compléter mon tableau1 met environ 8h… Il y a surement un moyen de l’optimiser mais je ne sais pas comment.. avec un sapply ?

Merci pour votre aide qui me sera fort utile !

Facundo Muñoz
Messages : 156
Enregistré le : 04 Juil 2019, 09:58
Contact :

Re: optimisation code pour éviter double boucle

Messagepar Facundo Muñoz » 28 Aoû 2020, 15:13

Bonjour,

Veuillez apporter un code reproductible, avec quelques données bidon qui ressemblent en structure (mais pas en taille!) à vos données réels.
viewtopic.php?f=1&t=7638

Cordialement,
ƒacu.-

Facundo Muñoz
Messages : 156
Enregistré le : 04 Juil 2019, 09:58
Contact :

Re: optimisation code pour éviter double boucle

Messagepar Facundo Muñoz » 28 Aoû 2020, 15:23

Au passage, je constate que pour la dernière valeur de i ( = length(periode_interet2)+1 = 346 ), le terme periode_interet[i + 20 - 1] va chercher valeurs au delà de la taille du vecteur...
ƒacu.-

Astrid Reilhac
Messages : 4
Enregistré le : 28 Aoû 2020, 09:19

Re: optimisation code pour éviter double boucle

Messagepar Astrid Reilhac » 31 Aoû 2020, 13:41

Bonjour,

Merci beaucoup pour votre retour. Je vous propose ci-dessous un script et une mini-base fictive permettant de comprendre ce que je souhaite faire et de pouvoir si possible m'aider à remplacer ma double boucle finale (très chronophage sur ma base réelle) par un code optimisé.

Mon objectif est de compléter le tableau1 avec, pour chaque jour, le nombre d'actes entre J et J+2.


Script :
-------------------------------------------------------------------------------------------------------------------------------------------------------------
periode_interet<-seq(as.Date ("01/01/2020", "%d/%m/%Y"),as.Date ("09/01/2020", "%d/%m/%Y") ,1)
periode_interet2<-seq(as.Date ("01/01/2020", "%d/%m/%Y"),as.Date ("07/01/2020", "%d/%m/%Y") ,1)#s'arrête 2 jours avant avant
periode_interet3<-data.frame("jour"=periode_interet2)
periode_interet3$compteur<-1
periode_interet3<-spread(periode_interet3,jour,compteur)
IPP_list <- c("2001", "2012", "2220", "3352", "5628","4785")

tableau1<-data.frame(matrix(NA,ncol=length(periode_interet2),nrow=length(IPP_list)))
colnames(tableau1) <- periode_interet2
tableau1$IPP <- IPP_list
tableau1 <- tableau1[, c(8, 1:7)]

data<- data.frame(IPP=c(rep("2001",9), rep("2012",9), "2200", rep("3352",4), "5628","4785"),
DATE=c("01/01/2020", "01/01/2020", "02/01/2020","03/01/2020", "04/01/2020",
"04/01/2020","04/01/2020", "05/01/2020","05/01/2020","01/01/2020",
"04/01/2020", "04/01/2020", "04/01/2020","04/01/2020","04/01/2020",
"07/01/2020","08/01/2020","09/01/2020","03/01/2020", "02/01/2020" ,
"04/01/2020", "05/01/2020","06/01/2020", "02/01/2020", "05/01/2020"),
compteur=c(rep(1,25)))
data$DATE <- as.Date(data$DATE,"%d/%m/%Y" )

for (i in 2:(length(periode_interet2)+1)){
for (j in 1: length(IPP_list)){
tableau1[j,i] <- sum(data$compteur[data$IPP ==IPP_list[j] & (data$DATE>=periode_interet[i-1] &data$DATE<=periode_interet[i+2-1])])
}
}
--------------------------------------------------------------------------------------------------------------------------------------------------------------------

Merci beaucoup pour votre aide !
Bien cordialement,
A.Reilhac

Facundo Muñoz
Messages : 156
Enregistré le : 04 Juil 2019, 09:58
Contact :

Re: optimisation code pour éviter double boucle

Messagepar Facundo Muñoz » 31 Aoû 2020, 14:26

Bonjour,

Si je comprends bien, pour une date i, vous voulez additionner le nombre d'observations pour les dates i, i+1, i+2. Et ceci, pour chaque valeur d'IPP.
Dans l'autre sens, chaque observation compte trois fois: une pour la date correspondante et une autre fois pour les deux dates antérieures.
Donc, je commence par multiplier les observations avant regrouper :

Code : Tout sélectionner


## J'ai exécuté votre code précedamment, donc j'ai toutes les variables en mémoire. Notamment, tableau1,
## qui est le résultat attendu.

library(tidyr)
suppressPackageStartupMessages(library(dplyr))

(table_totales <-
  bind_rows(
    data,
    data %>% mutate(DATE = DATE - 1),
    data %>% mutate(DATE = DATE - 2)
  ) %>%
  group_by(IPP, DATE) %>%
  summarise(total = sum(compteur), .groups = "drop") %>%
  filter(DATE >=min(data$DATE), DATE <=max(data$DATE) - 2) %>%
  pivot_wider(id_cols = IPP, names_from = DATE, values_from = total, values_fill = 0)
)
#> # A tibble: 6 x 8
#>   IPP   `2020-01-01` `2020-01-02` `2020-01-03` `2020-01-04` `2020-01-05`
#>   <chr>        <dbl>        <dbl>        <dbl>        <dbl>        <dbl>
#> 1 2001             4            5            6            5            2
#> 2 2012             1            5            5            5            1
#> 3 2200             1            1            1            0            0
#> 4 3352             1            2            2            3            2
#> 5 4785             0            0            1            1            1
#> 6 5628             1            1            0            0            0
#> # … with 2 more variables: `2020-01-06` <dbl>, `2020-01-07` <dbl>

# Ce tableau n'est pas identique au votre solution pour deux raisons :
# 1. Votre IPP_list n'est pas ordonnée,
# 2. vous avez mis 2220 dans IPP_list tandis que dans les données il y a 2200.
# Est-ce un erreur, ou bien vous voulez garder la possibilité des codes absentes
# ?
#
# Dans ce dernier cas, il vous faut ajouter encore :
table_totales <-
  data.frame(
    IPP = IPP_list
  ) %>%
  left_join(
    table_totales,
    by = "IPP"
  ) %>%
  mutate_all(replace_na, 0) %>%
  arrange(IPP)

## Vérification : là on retrouve exactement votre solution (sauf pour l'arrangement)

identical(
  tableau1 %>% arrange(IPP),
  table_totales
)
#> [1] TRUE
ƒacu.-

Astrid Reilhac
Messages : 4
Enregistré le : 28 Aoû 2020, 09:19

Re: optimisation code pour éviter double boucle

Messagepar Astrid Reilhac » 06 Sep 2020, 13:02

Merci beaucoup pour votre aide.
J'avais un message d'erreur avec la fonction pivot_wider à cause d'un problème de version mais en désinstallant/réinstallant tout (R Tools, R, R studio) cela marche maintenant !
Bonne journée !
A. Reilhac

Facundo Muñoz
Messages : 156
Enregistré le : 04 Juil 2019, 09:58
Contact :

Re: optimisation code pour éviter double boucle

Messagepar Facundo Muñoz » 07 Sep 2020, 07:40

Super.
Juste par curiosité, vous disiez que cela prenait 8 h avec votre code original. Cet approche a t'il amélioré la performance ?

ƒacu.-
ƒacu.-

Mickael Canouil
Messages : 1315
Enregistré le : 04 Avr 2011, 08:53
Contact :

Re: optimisation code pour éviter double boucle

Messagepar Mickael Canouil » 07 Sep 2020, 11:45

Bonjour,

une approche avec data.table pour vraiment une question de performance :

Code : Tout sélectionner

data <- data.frame(
  IPP = c(rep("2001", 9), rep("2012", 9), "2200", rep("3352", 4), "5628", "4785"),
  DATE = c(
    "01/01/2020", "01/01/2020", "02/01/2020", "03/01/2020", "04/01/2020",
    "04/01/2020", "04/01/2020", "05/01/2020", "05/01/2020", "01/01/2020",
    "04/01/2020", "04/01/2020", "04/01/2020", "04/01/2020", "04/01/2020",
    "07/01/2020", "08/01/2020", "09/01/2020", "03/01/2020", "02/01/2020",
    "04/01/2020", "05/01/2020", "06/01/2020", "02/01/2020", "05/01/2020"
  ),
  compteur = c(rep(1, 25))
)
data$DATE <- as.Date(data$DATE, "%d/%m/%Y")


Code : Tout sélectionner

library("data.table", warn.conflicts = FALSE)
dta <- as.data.table(data)
results <- dcast(
  data = dta[
    CJ(IPP = IPP, DATE = seq(min(DATE), max(DATE), "1 day"), unique = TRUE),
    on = .(IPP, DATE)
  ][
    .(IPP = IPP, start = DATE, end = DATE + 2),
    on = .(IPP, DATE >= start, DATE <= end), 
    somme_compteur 
:= sum(compteur, na.rm = TRUE),
    by = .EACHI
  
][
    , 
    unique
(.SD), 
    
.SDcols = c("IPP", "DATE", "somme_compteur")
  ], 
  formula 
= IPP ~ DATE, 
  value
.var = "somme_compteur", 
  fill 
= 0

Code : Tout sélectionner

results
#>     IPP 2020-01-01 2020-01-02 2020-01-03 2020-01-04 2020-01-05 2020-01-06 2020-01-07 2020-01-08 2020-01-09
#> 1: 2001          4          5          6          5          2          0          0          0          0
#> 2: 2012          1          5          5          5          1          2          3          2          1
#> 3: 2200          1          1          1          0          0          0          0          0          0
#> 4: 3352          1          2          2          3          2          1          0          0          0
#> 5: 4785          0          0          1          1          1          0          0          0          0
#> 6: 5628          1          1          0          0          0          0          0          0          0      


Ici, même si l'intervalle est plus petit, le calcul est quand même opéré (les deux dernières dates).

Un benchmark :

Code : Tout sélectionner

library("data.table", warn.conflicts = FALSE)
library("tidyr", warn.conflicts = FALSE)
library("dplyr", warn.conflicts = FALSE)

periode_interet <- seq(as.Date("01/01/2020", "%d/%m/%Y"), as.Date("09/01/2020", "%d/%m/%Y"), 1)
periode_interet2 <- seq(as.Date("01/01/2020", "%d/%m/%Y"), as.Date("07/01/2020", "%d/%m/%Y"), 1) # s'arrête 2 jours avant avant
periode_interet3 <- data.frame("jour" = periode_interet2)
periode_interet3$compteur <- 1
periode_interet3 
<- spread(periode_interet3, jour, compteur)
IPP_list <- c("2001", "2012", "2220", "3352", "5628", "4785")

data <- data.frame(
  IPP = c(rep("2001", 9), rep("2012", 9), "2200", rep("3352", 4), "5628", "4785"),
  DATE = c(
    "01/01/2020", "01/01/2020", "02/01/2020", "03/01/2020", "04/01/2020",
    "04/01/2020", "04/01/2020", "05/01/2020", "05/01/2020", "01/01/2020",
    "04/01/2020", "04/01/2020", "04/01/2020", "04/01/2020", "04/01/2020",
    "07/01/2020", "08/01/2020", "09/01/2020", "03/01/2020", "02/01/2020",
    "04/01/2020", "05/01/2020", "06/01/2020", "02/01/2020", "05/01/2020"
  ),
  compteur = c(rep(1, 25))
)
data$DATE <- as.Date(data$DATE, "%d/%m/%Y")

bm <- bench::mark(check = FALSE,
  base = {
    tableau1 <- data.frame(matrix(NA, ncol = length(periode_interet2), nrow = length(IPP_list)))
    colnames(tableau1) <- periode_interet2
    tableau1$IPP 
<- IPP_list
    tableau1 
<- tableau1[, c(8, 1:7)]
    for (i in 2:(length(periode_interet2) + 1)) {
      for (j in 1:length(IPP_list)) {
        tableau1[j, i] <- sum(
          data$compteur[
            data$IPP == IPP_list[j] & (
              data$DATE >= periode_interet[- 1] & data$DATE <= periode_interet[+ 2 - 1]
            )
          ]
        )
      }
    }
  },
  tidy = {
    bind_rows(
      data,
      data %>% mutate(DATE = DATE - 1),
      data %>% mutate(DATE = DATE - 2)
    ) %>%
    group_by(IPP, DATE) %>%
    summarise(total = sum(compteur), .groups = "drop") %>%
    filter(DATE >=min(data$DATE), DATE <=max(data$DATE) - 2) %>%
    pivot_wider(id_cols = IPP, names_from = DATE, values_from = total, values_fill = 0)
  },
  dt = {
    dta <- as.data.table(data)
    dcast(
      data = dta[
        CJ(IPP = IPP, DATE = seq(min(DATE), max(DATE), "1 day"), unique = TRUE),
        on = .(IPP, DATE)
      ][
        .(IPP = IPP, start = DATE, end = DATE + 2),
        on = .(IPP, DATE >= start, DATE <= end), 
        somme_compteur 
:= sum(compteur, na.rm = TRUE),
        by = .EACHI
      
][
        , 
        unique
(.SD), 
        
.SDcols = c("IPP", "DATE", "somme_compteur")
      ], 
      formula 
= IPP ~ DATE, 
      value
.var = "somme_compteur", 
      fill 
= 0
    
)
  }
)
plot(bm)


Image

Code : Tout sélectionner

bm
#> # A tibble: 3 x 6
#>   expression      min   median `itr/sec` mem_alloc `gc/sec`
#>   <bch:expr> <bch:tm> <bch:tm>     <dbl> <bch:byt>    <dbl>
#> 1 base         13.2ms   14.1ms      68.7    3.73MB    19.2 
#> 2 tidy         21.3ms   21.9ms      45.6    3.46MB    12.7 
#> 3 dt           10.5ms     11ms      90.0    3.67MB     6.59 


Facundo Muñoz a écrit :Juste par curiosité, vous disiez que cela prenait 8 h avec votre code original. Cet approche a t'il amélioré la performance ?

A priori, c'est pire avec le tidyverse (comme souvent).
Amélioration des performances du pipe %>% à venir dans magrittr 2.0


Cordialement,
Mickaël
mickael.canouil.fr | rlille.fr

Facundo Muñoz
Messages : 156
Enregistré le : 04 Juil 2019, 09:58
Contact :

Re: optimisation code pour éviter double boucle

Messagepar Facundo Muñoz » 07 Sep 2020, 12:13

Mickael Canouil a écrit :Bonjour,
une approche avec data.table pour vraiment une question de performance : ...


Excellent.

Enfin, si la performance n'est pas encore assez bonne, reste essayer de faire les calculs dans une base de données [e.g. https://cran.r-project.org/web/packages ... bplyr.html], ou bien en re-écrivant les for loops en C [e.g. http://adv-r.had.co.nz/Rcpp.html].

ƒacu.-
ƒacu.-

Astrid Reilhac
Messages : 4
Enregistré le : 28 Aoû 2020, 09:19

Re: optimisation code pour éviter double boucle

Messagepar Astrid Reilhac » 16 Déc 2020, 10:12

Facundo Muñoz a écrit :Super.
Juste par curiosité, vous disiez que cela prenait 8 h avec votre code original. Cet approche a t'il amélioré la performance ?

ƒacu.-



Bonjour, désolée du délai de réponse... j'avais du mettre ce travail de côté pendant quelques temps.
Ce code marche très bien et est quasiment instantané (moins de 2 minutes), contrairement au 8heures que prenait ma double boucle..
Merci encore !


Retourner vers « Questions en cours »

Qui est en ligne

Utilisateurs parcourant ce forum : Google [Bot] et 1 invité