Mise en place projet R

2026-06-08 16:16:27 +02:00
commit 265e5f1db6
27 changed files with 12697 additions and 0 deletions
@@ -0,0 +1,101 @@
+# Fichier contenant toutes les fonctions communes de nettoyage et mise en forme des données
+suppressPackageStartupMessages({
+  library(dplyr)
+  library(tidyr)
+})
+
+#' #' Nettoie une liste d'animaux hbcanim -------------------------------ANCIENNE VERSION
+#' #' @param tab_anims dataframe. Liste d'animaux brute
+#' #' @return Liste d'animaux nettoyée
+#' clean_data_anims<- function(tab_anims, num_cheptel){
+#'   result_data <- tab_anims %>%
+#'     select(numero, chantiersPointage) %>%
+#'     unnest(chantiersPointage, names_sep = "_", keep_empty = TRUE) %>%
+#'     
+#'     # garder le dernier chantier adulte avant d'unnest les codes
+#'     filter(chantiersPointage_typePointage == "Adulte") %>%
+#'     group_by(numero) %>%
+#'     arrange(desc(chantiersPointage_datePointage)) %>%
+#'     slice(1) %>%
+#'     ungroup() %>%
+#'     
+#'     # maintenant seulement on unnest les codes du chantier sélectionné
+#'     unnest(chantiersPointage_pointages, names_sep = "_", keep_empty = TRUE) %>%
+#'     
+#'     pivot_wider(
+#'       names_from = chantiersPointage_pointages_codePointage,
+#'       values_from = chantiersPointage_pointages_notePointage,
+#'       names_glue = "{.name}_adulte"
+#'     ) %>%
+#'     mutate(across(any_of(c("DM_adulte", "DS_adulte", "AF_adulte")), as.numeric))
+#'   
+#'   result <- tab_anims %>%
+#'     left_join(result_data, by = "numero")
+#' }
+
+
+#' Nettoie une liste d'animaux hbcanim
+#' @param tab_anims dataframe. Liste d'animaux brute
+#' @return Liste d'animaux nettoyée
+clean_data_anims<- function(tab_anims){
+  result_data <- tab_anims %>%
+    mutate(
+      # across(c("dmAdulte", "dsAdulte", "afAdulte", "pat12M", "pat18M", "pat24M",  "rangVelageMipg", "fiabIiv1", "fiabIvv2Corr", "agevel1", "pat120", "pat210",
+      #               "pat120Corrige", "pat210Corrige", "dmSevrage", "dsSevrage", "afSevrage", "nbVelageVeauxDeclares", "nbFinGestation"), as.numeric),
+      dateNaiss = as.Date(as.POSIXct(dateNaiss / 1000, origin = "1970-01-01", tz = "UTC")),
+      dateSortDetenteur = as.Date(as.POSIXct(dateSortDetenteur / 1000, origin = "1970-01-01", tz = "UTC"))
+    ) 
+}
+
+#' Nettoie une liste d'animaux hbcanim  -----------------------------NORMALEMENT PLUS UTILISE CAR clean_data_anims
+#' TODO A TESTER MAJ 19/03 Encore utile ?
+#' @param produits dataframe. Liste d'animaux brute
+#' @return Liste d'animaux reformatée
+clean_produits <- function(produits){
+  produits <- produits %>%
+    mutate(
+      # Dates
+      across(c(dateNaissance, dateSortie), ~ as.Date(.x, format = "%Y-%m-%d")),
+      # Nettoyage chaînes : trim + squish (supprime espaces multiples)
+      numero = str_squish(numero), #TODO appliquer un squish sur l'appel au numéro des parents
+      # Numériques (tolérant aux NA / strings)
+      across(
+        c(ravelamere, campagneNaissance, poidsNaissance, pat120, pat210), #TODO on avait un ivv aussi mais comme maintenant c'est un objet je l'ai enlevé (19/03), enlevé aptfon aussi car à priori pas utilisé
+        ~ suppressWarnings(as.numeric(.x))
+      )
+    ) %>%
+    unnest(chantiersPointage, names_sep = "_", keep_empty = TRUE) %>%
+    unnest(chantiersPointage_pointages, names_sep = "_", keep_empty = TRUE) %>%
+    filter(chantiersPointage_typePointage == "Sevrage") %>%
+    pivot_wider(
+      names_from = chantiersPointage_pointages_codePointage,
+      values_from = chantiersPointage_pointages_notePointage,
+      names_glue = "{.name}_sevrage"
+    ) %>%
+    mutate(across(any_of(c("DM_sevrage", "DS_sevrage", "AF_sevrage")), as.numeric))
+}
+
+#' Calcule les effets du cheptel 
+#' @param num_cheptel character. Numéro du cheptel avec le FR
+get_effets_cheptel <- function(produits_chep){
+  # Calcul des effets du cheptel : rang de velage et sexe du veau -> voir si on peut utiliser poids naissance corrigé de l'infocentre
+  effets <- produits_chep %>% 
+    summarise(m_PN = round(mean(poidsNaiss, na.rm=T), 1),
+              m_p120 = round(mean(pat120, na.rm=T), 1),
+              m_p210 = round(mean(pat210, na.rm=T), 1),
+              .by = c(typeMipg, sexe))
+  effets$diff_pn <- effets$m_PN - subset(effets, effets$sexe == '1' & effets$typeMipg == 'V')$m_PN[1]
+  effets$diff_p120 <- effets$m_p120 - subset(effets, effets$sexe == '1' & effets$typeMipg == 'V')$m_p120[1] # idem infocentre pour val corrigée
+  effets$diff_p210 <- effets$m_p210 - subset(effets, effets$sexe == '1' & effets$typeMipg == 'V')$m_p210[1] # idem infocentre pour val corrigée
+  
+  # calcul des effets du cheptel : sexe sur la repro -> à faire !!!!! Calcule la diff moyen nb prod vache et nb prod taureau 
+  # voir pour corriger ces effets en prenant tous les veaux en compte pour vache actives, taureaux et lignées femelles 
+  effetsexe <- produits_chep %>% filter(NBPRODIPG > 0) %>% group_by(sexe) %>% 
+    summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1),
+              nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) )
+  rapport_MF <- round(subset(effetsexe, 
+                             effetsexe$sexe == '1')$nbpp_med[1] 
+                      / subset(effetsexe,
+                               effetsexe$sexe == '2')$nbpp_med[1], 0)
+  list(rapport_MF = rapport_MF, effets_chep = effets)
+}