238 lines
10 KiB
R
Executable File
238 lines
10 KiB
R
Executable File
suppressPackageStartupMessages({
|
|
library(roxygen2)
|
|
library(dplyr)
|
|
library(lubridate)
|
|
library(purrr)
|
|
library(stringr)
|
|
library(DBI)
|
|
library(RPostgres)
|
|
library(here)
|
|
library(httr)
|
|
library(jsonlite)
|
|
})
|
|
source(here::here("R/common/ws_client.R"))
|
|
source(here::here("R/project/preprocessing.R"))
|
|
source(here::here("R/project/postprocessing.R"))
|
|
|
|
#' Fonction globale de mise à jour des indicateurs eCow pour vaches, taureaux et lignées
|
|
#' Stockage des données directement en base
|
|
#' step : 1 si calcul des vaches uniquement, 2 si vaches et taureaux, 3 global
|
|
#' @param cheptel character. Numéro du cheptel avec le FR devant
|
|
calcul_ecow_by_chep <- function(cheptel, step = 3) {
|
|
t0 <- Sys.time()
|
|
|
|
###################################### Préparation des données ##########################################
|
|
|
|
# Récupère les paramètres de pondération
|
|
params_ponderation <- get_params_ponderation(cheptel)
|
|
# Récupère la liste des certificats zoo issue de Doli
|
|
czhbc <- data.frame(ANIM = get_cztotaux())
|
|
|
|
message("Début import des données")
|
|
cheptel_ecow <- get_cheptel_ecow(cheptel)
|
|
|
|
# Vaches actives ayant déjà eu une fin de gestation
|
|
vaches <- cheptel_ecow$vaches
|
|
|
|
if (length(vaches) == 0) {
|
|
t1 <- Sys.time()
|
|
message("Arrêt du traitement, aucunes vaches à traiter. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec")
|
|
return(invisible(NULL))
|
|
}
|
|
|
|
# Récupère les taureaux : tous les pères des vaches actives ou de tous les veaux des vaches actives
|
|
taureaux <- cheptel_ecow$taureaux
|
|
# Ajout du nom du père pour affichage classement carrière
|
|
vaches <- vaches %>%
|
|
dplyr::left_join(
|
|
taureaux %>% select(anim, nom_pere = nom),
|
|
by = c("pereGenetique" = "anim")
|
|
)
|
|
# Récupère les produits ajout des données manquantes
|
|
produits_cheptel <- add_data_ecow(cheptel_ecow$produits, cheptel_ecow$nomsparents, czhbc)
|
|
|
|
|
|
###################################################################################################################
|
|
#################################### Calcul ecow pour les vaches ########################################
|
|
###################################################################################################################
|
|
message("Début partie vaches : ", nrow(vaches), " vaches à traiter.")
|
|
|
|
# Ajout info donneuses
|
|
donneuses <- cheptel_ecow$donneuses
|
|
vaches$donneuse <- vaches$anim %in% donneuses
|
|
|
|
# Récupère les produits des vaches actives du cheptel et les embryons portés dans le cheptel
|
|
produits_vaches <- produits_cheptel %>%
|
|
filter(numeroMipg %in% vaches$anim)
|
|
|
|
# Récupère les effets cheptel # TODO A REVOIR AVEC LAURENA
|
|
effets <- get_effets_cheptel(produits_vaches)
|
|
rapport_MF <- effets$rapport_MF
|
|
|
|
prod_vaches_corr <- apply_effet_chep(produits_vaches, effets$effets_chep, effets$rapport_MF)
|
|
|
|
# On récupère les coefficients de pondération pour les pointages au sevrage
|
|
pps <- params_ponderation$pointage$sevrage
|
|
|
|
# Ajout à la table vache des informations synthétisées de leur veaux
|
|
synth_brute_vaches <- get_synth_prod_parent(vaches, prod_vaches_corr, params_ponderation)
|
|
|
|
# Normalisation et calcul des notes carrières
|
|
synth_vaches <- get_note_carriere(synth_brute_vaches, params_ponderation)
|
|
|
|
#################################### Calcul des notes campagnes ########################################
|
|
####### En réalité on travaille sur les rangs de velages, ce qui correspond dans 99% des cas aux campagnes #######
|
|
|
|
# Calcul des notes ecowcamp par vache / date de naissance / Rang de vélage
|
|
synth_campagne <- get_note_campagne(prod_vaches_corr, params_ponderation)
|
|
# Attribution du numéro de cheptel pour l'enregistrement en base
|
|
synth_campagne$cheptel <- cheptel
|
|
|
|
# Moyenne de la note ecowcamp par mère pour celle ayant une note > 10
|
|
moy_camp <- synth_campagne %>%
|
|
filter(ecowcamp > 10) %>%
|
|
group_by(numeroMipg) %>%
|
|
summarise(moyecowcamp = round(mean(ecowcamp, na.rm = TRUE), 1), .groups = "drop")
|
|
|
|
# Ajout de la note moyenne de campagne au tableau récapitulatif des vaches
|
|
v_camp <-synth_vaches %>%
|
|
dplyr::left_join(moy_camp, by = c("anim" = "numeroMipg")) %>%
|
|
mutate(
|
|
rg_camp = as.integer(rank(1 / moyecowcamp, na.last='keep'))
|
|
)
|
|
|
|
message("Enregistrement données vaches")
|
|
|
|
# Enregistrement des données des vaches en base
|
|
v_camp <- v_camp %>%
|
|
mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100))
|
|
|
|
save_data_vaches(v_camp, cheptel)
|
|
|
|
# Enregistrement des données de campagne en base
|
|
synth_campagne <- synth_campagne %>%
|
|
mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100))
|
|
save_data_campagne(synth_campagne, cheptel)
|
|
|
|
if (step == 1) {
|
|
t1 <- Sys.time()
|
|
message("Fin du traitement. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec")
|
|
return(invisible(NULL))
|
|
}
|
|
|
|
###################################################################################################################
|
|
#################################### Calcul ecow pour les taureaux ########################################
|
|
###################################################################################################################
|
|
message("Début partie taureaux")
|
|
# Recupère les produits des taureaux
|
|
produits_taureaux <- produits_cheptel %>%
|
|
filter(pereGenetique %in% taureaux$anim & embryon != 'O')
|
|
|
|
# Récupères les filles des taureaux nées dans le cheptel
|
|
filles_taureaux <- produits_taureaux %>%
|
|
filter(sexe == 2)
|
|
|
|
# Petits produits issus des filles des taureaux nés dans le cheptel
|
|
pprod_filles_taureaux <- add_data_ecow(cheptel_ecow$petits_produits, cheptel_ecow$nomsparents, czhbc)
|
|
|
|
# Calcul de la synthèse par fille de leur produits
|
|
synth_filles_taureaux <- get_synth_prod_parent(filles_taureaux, pprod_filles_taureaux, params_ponderation)
|
|
|
|
# Calcul des stats par pere
|
|
stats_prod_directe <- get_stats_parent(produits_taureaux, pereGenetique)
|
|
|
|
# Calcul des performances des filles pour les taureaux en ayant au moins 3
|
|
stats_filles <- get_stats_filles(synth_filles_taureaux, "fillestot_", pereGenetique, actif = FALSE, cheptel)
|
|
|
|
stats_filles_act <- get_stats_filles(synth_filles_taureaux, "fillesact_", pereGenetique, actif = TRUE, cheptel)
|
|
|
|
grp_filles_et_act <- stats_filles %>%
|
|
dplyr::left_join(stats_filles_act, by = "pereGenetique") %>%
|
|
mutate(
|
|
pctfilles_avecprod = round(fillestot_nbavecprod / fillestot_count* 100, 1),
|
|
pctfillesact_avecprod = round( fillesact_nbavecprod / fillestot_nbavecprod * 100, 1 )
|
|
)
|
|
|
|
stats_filles_renouv <- produits_cheptel %>%
|
|
filter(
|
|
is.na(NBPRODIPG), # Pas idéal car pas propre au cheptel, mais en même temps si ce sont des femelles de renouvellement elles ne devraient avoir aucun produit
|
|
sexe == "2",
|
|
is.na(dateSortDetenteur)
|
|
) %>%
|
|
group_by(pereGenetique) %>%
|
|
summarise(
|
|
nbfilles_renouv = n(),
|
|
.groups = "drop"
|
|
)
|
|
|
|
stats_taureaux <- stats_prod_directe %>%
|
|
dplyr::left_join(grp_filles_et_act, by = "pereGenetique") %>%
|
|
dplyr::left_join(stats_filles_renouv, by = "pereGenetique") %>%
|
|
dplyr::left_join(taureaux %>% select(anim, nom, dateNaiss, nomCheptelNaiss), by = c("pereGenetique" = "anim")) %>%
|
|
mutate(
|
|
nom = replace(nom, is.na(nom), ""),
|
|
cheptel = cheptel,
|
|
across(where(is.numeric), ~ trunc(.x * 100) / 100)
|
|
)
|
|
|
|
message("Enregistrement données taureaux")
|
|
save_data_taureau(stats_taureaux, cheptel)
|
|
|
|
if (step == 2) {
|
|
t1 <- Sys.time()
|
|
message("Fin du traitement. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec")
|
|
return(invisible(NULL))
|
|
}
|
|
|
|
###################################################################################################################
|
|
#################################### Remontee des lignees femelles ########################################
|
|
###################################################################################################################
|
|
message("Début partie Lignées")
|
|
fondatrices <- cheptel_ecow$fondatrices
|
|
descendants <- add_data_ecow(cheptel_ecow$descendants, cheptel_ecow$nomsparents, czhbc)
|
|
|
|
vaches_lignees <- descendants %>% filter(anim %in% descendants$mereGenetique)
|
|
produits_lignees <- descendants %>% filter(mereGenetique %in% vaches_lignees$anim)
|
|
|
|
synth_vaches_lignees <- get_synth_prod_parent(vaches_lignees, produits_lignees, params_ponderation)
|
|
|
|
# Calcul des stats par fondatrice, ne gardant que celles ayant plus de 5 descendants dans le cheptel
|
|
# On utilise les descendants globaux afin de ne pas perdre les stats directes des vaches achetées qui n'auraient pas encore de petits_produits
|
|
stats_prod <- get_stats_parent(descendants, fondatrice)
|
|
|
|
stats_fem_tot <- get_stats_filles(synth_vaches_lignees, "femtot_", fondatrice, actif = FALSE, cheptel)
|
|
|
|
stats_fem_act <- get_stats_filles(synth_vaches_lignees, "femact_", fondatrice, actif = TRUE, cheptel)
|
|
|
|
stats_renouv <- descendants %>%
|
|
filter(
|
|
is.na(NBPRODIPG), # Pas idéal car pas propre au cheptel, mais en même temps si ce sont des femelles de renouvellement elles ne devraient avoir aucun produit
|
|
sexe == "2",
|
|
is.na(dateSortDetenteur),
|
|
cheptelDetenteur == cheptel
|
|
) %>%
|
|
group_by(fondatrice) %>%
|
|
summarise(
|
|
nbfilles_renouv = n(),
|
|
.groups = "drop"
|
|
)
|
|
|
|
stats_lignees <- stats_prod %>%
|
|
dplyr::left_join(stats_fem_tot, by = "fondatrice") %>%
|
|
dplyr::left_join(stats_fem_act, by = "fondatrice") %>%
|
|
dplyr::left_join(stats_renouv, by = "fondatrice") %>%
|
|
dplyr::left_join(fondatrices %>% select(anim, nom, dateNaiss, nomCheptelNaiss), by = c("fondatrice" = "anim")) %>%
|
|
mutate(
|
|
pctfem_avecprod =
|
|
round(femtot_nbavecprod / nb_femelles* 100, 1),
|
|
pctfemact_avecprod =
|
|
round(femact_nbavecprod / femtot_nbavecprod * 100, 1),
|
|
cheptel = cheptel
|
|
)
|
|
|
|
message("Enregistrement données lignées")
|
|
save_data_lignees(stats_lignees, cheptel)
|
|
t1 <- Sys.time()
|
|
message("Fin du traitement. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec")
|
|
}
|