102 lines
5.0 KiB
R
Executable File
102 lines
5.0 KiB
R
Executable File
# 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)
|
|
}
|