optimisation code R

[Fabrice Yaméogo]

Bonjour,

J'ai deux opérations différentes à effectuer sous R à partir d'un même dataframe (df). Mon message risque d'être un peu long.

Je dispose d'un df R intitulé "tableau1" qui est de la forme suivante:

Code : Tout sélectionner

tableau1<-structure(list(id = structure(c(1L, 1L, 1L, 1L, 1L, 1L,
                                     1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
                                     1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L,
                                     2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L,
                                     2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L,
                                     3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
                                     3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L),
                                   .Label = c("44001", "44002", "44003"), class = "factor"),
                   
                    modalites = structure(c(1L,1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L,
                                            1L, 2L, 2L, 2L, 2L, 2L, 2L,
                                            2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
                                            1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L,
                                            2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
                                            3L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L,
                                            2L, 2L, 2L, 2L, 2L, 2L, 2L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L,
                                            3L, 3L), .Label = c("a", "b", "c"), class = "factor"),
                    prix = c(0,8370.625, 9290, 10200, 10800, 11500, 12400, 12800,
                             13100, 13400, 13800, 0, 8370.625, 9290, 10200, 10800, 11500,
                             12400, 12800, 13100, 13400, 13800, 0, 8370.625, 9290, 10200,
                             10800, 11500, 12400, 12800, 13100, 13400, 13800, 0, 8370.625,
                             9290, 10200, 10800, 11500, 12400, 12800, 13100, 13400, 13800,
                             0, 8370.625, 9290, 10200, 10800, 11500, 12400, 12800, 13100,
                             13400, 13800, 0, 8370.625, 9290, 10200, 10800, 11500, 12400,
                             12800, 13100, 13400, 13800, 0, 8370.625, 9290, 10200, 10800,
                             11500, 12400, 12800, 13100, 13400, 13800, 0, 8370.625, 9290,
                             10200, 10800, 11500, 12400, 12800, 13100, 13400, 13800, 0, 8370.625,
                             9290, 10200, 10800, 11500, 12400, 12800, 13100, 13400, 13800),
                   
                    prob = c(0,0.4208624, 0.4756262, 0.6355124, 0.6710136, 0.7868615,
                             0.9094785, 0.9156953, 0.9653215, 0.9952528, 1, 0, 0.561523032,
                             0.612943156, 0.6355124, 0.6710136, 0.7868615, 0.9194785, 0.8856953,
                             0.92478477, 1.0230934, 1, 0, 0.466265114, 0.594579924, 0.6355124, 0.6710136,
                             0.544579924, 0.6612152, 0.6600523, 1.1248219, 1.0553215, 1, 0,
                             0.4208624, 0.4756262, 0.6355124, 0.6710136, 0.7868615, 1.0254553,
                             0.9156953, 0.9653215, 0.9952528, 1, 0, 0.5612115, 0.530807106,
                             0.549215737, 0.6710136, 0.7868615, 0.9094785, 1.0145458, 0.9653215,
                             0.9952528, 1, 0, 0.4208624, 0.4756262, 0.6355124, 0.7910136,
                             0.6568615, 0.6694785, 0.8056953, 1, 1.0230934, 1, 0, 0.4208624,
                             0.4756262, 0.6955124, 0.6710136, 0.7868615, 0.959692132, 0.9156953,
                             0.9653215, 1.0452528, 1, 0, 0.4208624, 0.4756262, 0.6355124,
                             0.6710136, 0.7868615, 0.9094785, 0.9156953, 1, 0.988040189, 1,
                             0, 0.4208624, 0.5356262, 0.4755124, 0.6710136, 0.6468615, 0.6394785,
                             0.6256953, 1.0230934, 1.0430934, 1),
                    prob1 = c(0, 0.4208624,0.4756262, 0.6355124, 0.6710136, 0.7868615,
                              0.9094785, 0.9156953, 0.9653215, 0.9952528, 1, 0, 0.561523032,
                              0.612943156, 0.6355124, 0.6710136, 0.7868615, 0.9194785,
                              0.8856953, 0.92478477, 0, 0, 0, 0.466265114, 0.594579924, 0.6355124,
                              0.6710136, 0.544579924, 0.6612152, 0.6600523, 0, 0, 0, 0, 0.4208624, 0.4756262, 0.6355124,
                              0.6710136, 0.7868615, 0, 0, 0, 0, 0, 0, 0.5612115, 0.530807106,
                              0.549215737, 0.6710136, 0.7868615, 0.9094785, 0, 0, 0, 0, 0,
                              0.4208624, 0.4756262, 0.6355124, 0.7910136, 0.6568615, 0.6694785,
                              0.8056953, 1, 0, 0, 0, 0.4208624, 0.4756262, 0.6955124, 0.6710136,
                              0.7868615, 0.959692132, 0.9156953, 0.9653215, 0, 0, 0, 0.4208624,
                              0.4756262, 0.6355124, 0.6710136, 0.7868615, 0.9094785, 0.9156953,
                              1, 0.988040189, 1, 0, 0.4208624, 0.5356262, 0.4755124, 0.6710136,
                              0.6468615, 0.6394785, 0.6256953, 0, 0, 0)), class = "data.frame", row.names = c(NA,-99L))


Voici un aperçu de quelques lignes de mon df

Code : Tout sélectionner

tableau1[1:45,]

Les variables initiales du tableau sont "id", "modalites", "prix" et "prob"

1re opération

Je souhaiterais créer la variable "prob1" (qui figure dans mon df tableau) selon les conditions suivantes:

1) Pour chaque id et selon la modalité, on considère le prix le plus faible pour lequel la variable "prob" est supérieure à 1 et ensuite,
la variable "prob_1" prendra la valeur de zéro et pour toutes les lignes qui suivent cette ligne(lorsque la commune et la modalité ne change pas), la variable prob1 prend également la valeur de 0.

2) dans le cas contraire, la variable "prob1" prend la valeur la variable "prob"

Par exemple, si on considère les lignes 34 à 44 de mon df, ("id"=44002 et "com"=a), le prix le plus faible pour lequel prob>1 est 12400 (ligne 40). Pour tous les prix >= à 12400, la variable "prob1"=0 et pour les prix inférieurs à 12400, prob1=prob.

2e opération

Elle consiste à créer à partir de la variable prob1 une nouvelle variable prob2 qui fait la différence entre deux valeurs successives de prob1 (valeur n moins valeur et n-1 à chaque fois ) lorsque les variables id et modalites sont identiques

J'ai essayé de créer cette variable au moyen d'une transformation de mon df en list et en utilisant une boucle.

Code : Tout sélectionner

tableau1$prob2<-0

names(tableau1)

library(dplyr)#charger la librairie dplyr

tableau1_l<-tableau1%>%
  group_split(id,modalites)

for (i in 1:length(tableau1_l)){
  for(j in 2:nrow(tableau1_l[[i]])){
    tableau1_l[[i]][j,6]<-(tableau1_l[[i]][j,5])-(tableau1_l[[i]][j-1,5])
  }
}

tableau2<-Reduce(rbind,tableau1_l)

tableau2<-as.data.frame(tableau2)


Aperçu de mon nouveau df (tableau 2) qui contient la variable prob2 que j'ai essayé de créer

Code : Tout sélectionner

tableau2[1:45,]

J'obtiens des valeurs négatives pour ma variable prob2. L'objectif est de supprimer les lignes qui entraînent des résultats négatifs et de recalculer la variable prob2 à chaque fois afin qu'il n'y ait plus de valeurs négatives.

Par exemple: la différence entre les lignes 28 et 27: 0.5445799−0,6710136= −0,1264337. Il faut ainsi supprimer la ligne 28, et recommencer les calculs.
En éliminant cette ligne et en recalculant la variable prob2, ce sera maintenant la différence entre la ligne 29 et la ligne 27
(0.6612152-0.6710136= −0,0097984) qui causera problème. Il faut encore supprimer la ligne 29 et recommencer la procédure.
afin de ne plus avoir de valeurs négatives pour prob2

Pourriez-vous m'indiquer comment faire mes deux opérations de façon optimale? Je sais que l'utilisation de boucles sous R n'est pas conseillée.

D'avance merci.

Fabrice

[Pierre-Yves Berrard]

Bonjour,

Une proposition pour l'opération 1 :

Code : Tout sélectionner

library(dplyr)

res <-
  tableau1 %>%
  group_by(id, modalites) %>%
  mutate(
    prob1 = ifelse(prix >= min(prix[prob > 1]), 0, prob)
  ) 

Dans votre jeu de données, certains couples (id, modalités) n'ont aucun prob>1. Vous n'avez pas précisé que faire dans ce cas.

[Fabrice Yaméogo]

Bonjour,

Merci de votre réponse. Lorsque j'exécute votre script, je reçois le message d'alerte suivant:

Code : Tout sélectionner

Warning messages:
1: Problem with `mutate()` input `prob1`.
ℹ aucun argument trouvé pour min ; Inf est renvoyé
ℹ Input `prob1` is `ifelse(prix >= min(prix[prob > 1]), 0, prob)`.
ℹ The error occurred in group 1: id = "44001", modalites = "a".
2: In min(prix[prob > 1]) :
  aucun argument trouvé pour min ; Inf est renvoyé
3: Problem with `mutate()` input `prob1`.
ℹ aucun argument trouvé pour min ; Inf est renvoyé
ℹ Input `prob1` is `ifelse(prix >= min(prix[prob > 1]), 0, prob)`.
ℹ The error occurred in group 8: id = "44003", modalites = "b".
4: In min(prix[prob > 1]) :
  aucun argument trouvé pour min ; Inf est renvoyé

Pour les couples (id, modalités) qui n'ont aucun prob>1, la variable prob1 prend les mêmes valeurs que celles de prob.

En regardant le dataframe "res", j'obtiens le résultat souhaité pour l'opération 1.

Cordialement

Fabrice

[Pierre-Yves Berrard]

Les messages d'alerte sont justement provoqués par les groupes qui n'ont aucun prob>1.
On peut les faire disparaître ainsi :

Code : Tout sélectionner

res <-
  tableau1 %>%
  group_by(id, modalites) %>%
  mutate(
    prix_min_sup1 = if (any(prob > 1)) min(prix[prob > 1]) else Inf,
    prob1 = ifelse(prix >= prix_min_sup1, 0, prob)
  )

[Fabrice Yaméogo]

Merci pour le code.

Problème 1 résolu

Cordialement

Fabrice

[Pierre-Yves Berrard]

Ajout de l'opération 2 (basée sur une boucle repeat, il y a sûrement moyen d'optimiser encore) :

Code : Tout sélectionner

library(dplyr)

# operation 1
res <-
  tableau1 %>%
  group_by(id, modalites) %>%
  mutate(
    prix_min_sup1 = if (any(prob > 1)) min(prix[prob > 1]) else Inf,
    prob1 = ifelse(prix >= prix_min_sup1, 0, prob)
  ) %>%
  select(-prix_min_sup1)

# operation 2
repeat {
  res <- res %>% group_by(id, modalites) %>% mutate(prob2 = prob1 - lag(prob1))
  if (all(res$prob2 >= 0, na.rm = TRUE)) break
  res <- filter(res, is.na(prob2) | prob2 >= 0)
}

[Fabrice Yaméogo]

Merci pour la deuxième opération.

Cela fonctionne très bien. C'est vraiment judicieux d'avoir utilisé la fonction lag.

Je vais me documenter sur le fonctionnement de la boucle repeat.

Cordialement

Fabrice

[Mickael Canouil]

Bonjour,

attention, le code manque le ungroup pour retirer les métadonnées lié au "découpage" des données.
Ceci peut aboutir à des résultats inattendus.
Un group_by() doit toujours être utilisé conjointement avec ungroup() (ou summarise(..., .group = XXX)).

Ou exploiter les métadonnées :

Code : Tout sélectionner

library(dplyr)

# operation 1
res <-
  tableau1 %>%
  group_by(id, modalites) %>%
  mutate(
    prix_min_sup1 = if (any(prob > 1)) min(prix[prob > 1]) else Inf,
    prob1 = ifelse(prix >= prix_min_sup1, 0, prob),
    prix_min_sup1 = NULL
  )

# operation 2
repeat {
  res <- mutate(res, prob2 = prob1 - lag(prob1))
  if (all(res$prob2 >= 0, na.rm = TRUE)) break
  res <- filter(res, is.na(prob2) | prob2 >= 0)
}
res <- ungroup(res)

Cordialement,

[Pierre-Yves Berrard]

Pour ungroup, j'ai testé avec et sans et cela ne change pas le résultat (les groupes sont écrasés à chaque itération).

En revanche, pour avoir une valeur finale propre (ungrouped) et ne pas avoir de problème par la suite, il faudrait effectivement modifier le break ainsi :

Code : Tout sélectionner

if (all(res$prob2 >= 0, na.rm = TRUE)) {
  res <- ungroup(res)
  break
} 

[Mickael Canouil]

Et parce-que je n'aime pas les break^^

Code : Tout sélectionner

library(dplyr)

res <- tableau1 %>%
  group_by(id, modalites) %>%
  mutate(
    prix_min_sup1 = if (any(prob > 1)) min(prix[prob > 1]) else Inf,
    prob1 = ifelse(prix >= prix_min_sup1, 0, prob),
    prix_min_sup1 = NULL,
    prob2 = prob1 - lag(prob1)
  )

while (!all(res$prob2 >= 0, na.rm = TRUE)) {
  res <- res %>% 
    filter(is.na(prob2) | prob2 >= 0) %>% 
    mutate(prob2 = prob1 - lag(prob1))
}

res <- ungroup(res) 

[Fabrice Yaméogo]

Bonjour,

Merci pour la modification avec l'ajout de ungroup.

Merci également pour la deuxième version avec la boucle while.

Cordialement

Fabrice