# 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) }