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 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, 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_norm <- get_note_carriere(synth_brute_vaches, params_ponderation) synth_vaches <- synth_norm$synthese # calcul des stats, valeurs extremes et references pour la normalisation stats_chep <- synth_norm$stats_chep #################################### Calcul des notes campagnes ######################################## ####### En réalité on travaille sur les rangs de velages, ce qui correspond dans 99% des cas aux campagnes ####### # ============================== # 1. Aggrégation campagnes # ============================== synth_prod_vache <- prod_vaches_corr %>% group_by(numeroMipg, dateNaiss, rangVelageMipg) %>% summarise( ivv = first(ivv1), # ------------------------------------------------------------------------- TODO vraiment pas sure, à valider pn_c = round(mean(pn_corr, na.rm = TRUE), 1), txvf = round(mean(conditionNaiss %in% c('1','2')) * 100, 1), txm = round(mean(sexe == '1') * 100, 1), ptgp = round(mean(pps$devmus * dmSevrage + pps$devsqe * dsSevrage + pps$af * afSevrage, na.rm = TRUE), 1), p120_c = round(mean(pat120Corrige, na.rm = TRUE), 1), p210_c = round(mean(pat210Corrige, na.rm = TRUE), 1), prol = n() * 100, # ------------------------------- TODO a tester parce que je pense qu'il faudrait tous les produits d'une vache mort = round(mean(mortsev == "O" | mortnat == "O") * 100, 1), pere = first(pereGenetique), cheptel = first(cheptelNaiss), # noms des veaux pour simplifier affichage produits = list( pmap( list(nom = nom, anim = anim, sexe = sexe, mortnat = mortnat, mortsev = mortsev, NBPRODIPG = NBPRODIPG, embryon = embryon), \(nom, anim, sexe, mortnat, mortsev, NBPRODIPG, embryon) list(nom = nom, anim = anim, sexe = sexe, mortnat = mortnat, mortsev = mortsev, NBPRODIPG = NBPRODIPG, embryon = embryon) ) ), .groups = "drop" ) # Récupère le nom du père synth_prod_vache <- synth_prod_vache %>% dplyr::left_join( taureaux %>% select(anim, nom_pere = nom), by = c("pere" = "anim") ) stats_camp <- get_stats_tbl( tab = synth_prod_vache, nom_tab = "synth_prod_vache", cols = c( 'ivv', 'prol', 'mort', 'txvf', 'txm', 'ptgp', 'pn_c', 'p120_c', 'p210_c') ) stats_chep <- rbind(stats_chep, stats_camp) pond_camp_fin <- unlist(params_ponderation$campagne$final) pond_camp_ahp <- unlist(params_ponderation$campagne$AHPtech) # ============================== # 2. Normalisation complète # ============================== synth_prod_vache_n <- synth_prod_vache %>% mutate( # pn normalisé pn_n = case_when( is.na(pn_c) ~ NA_real_, pn_c >= 40 & pn_c <= 50 ~ 1, pn_c <= 22 | pn_c >= 68 ~ 0, pn_c > 22 & pn_c < 40 ~ round(0.056 * (pn_c - 22), 3), TRUE ~ round(1 - 0.056 * (pn_c - 50), 3) ), # 5 normalisations linéaires txvf_n = round(1 - abs(stats_chep$max[stats_chep$var=="synth_prod_vache$txvf"] - txvf) / abs(diff(range(stats_chep[stats_chep$var=="synth_prod_vache$txvf",c("min","max")]))), 3), txm_n = round(1 - abs(stats_chep$max[stats_chep$var=="synth_prod_vache$txm"] - txm) / abs(diff(range(stats_chep[stats_chep$var=="synth_prod_vache$txm",c("min","max")]))), 3), ptgp_n = round(1 - abs(stats_chep$max[stats_chep$var=="synth_prod_vache$ptgp"] - ptgp) / abs(diff(range(stats_chep[stats_chep$var=="synth_prod_vache$ptgp",c("min","max")]))), 3), p120_n = round(1 - abs(stats_chep$max[stats_chep$var=="synth_prod_vache$p120_c"] - p120_c) / abs(diff(range(stats_chep[stats_chep$var=="synth_prod_vache$p120_c",c("min","max")]))), 3), p210_n = round(1 - abs(stats_chep$max[stats_chep$var=="synth_prod_vache$p210_c"] - p210_c) / abs(diff(range(stats_chep[stats_chep$var=="synth_prod_vache$p210_c",c("min","max")]))), 3), # prol normalisé prol_n = case_when( is.na(prol) ~ NA_real_, prol == 100 ~ 0.8, TRUE ~ 1 ), # mortalité mort_n = round(exp(-0.031 * mort), 3), # TODO sciender en mortsev et mortnat # IVV normalisé ivv_n = case_when( is.na(rangVelageMipg) | rangVelageMipg == 1 | is.na(ivv) ~ NA_real_, # ravelamere == 2 rangVelageMipg == 2 & ivv > 460 ~ 0, rangVelageMipg == 2 & ivv < 390 ~ 1, rangVelageMipg == 2 ~ round(1 - abs(390 - ivv)/abs(390 - 460), 3), # autres ravelamere ivv > 435 ~ 0, ivv < 365 ~ 1, TRUE ~ round(1 - abs(365 - ivv)/abs(365 - 435), 3) ) ) %>% # ============================== # 3. Score final ecowcamp # ============================== rowwise() %>% mutate( perf = list(c_across(c( ivv_n, mort_n, p120_n, p210_n, pn_n, prol_n, ptgp_n, txm_n, txvf_n ))), pond = sum( pond_camp_fin[!(is.na(perf) | is.nan(perf))] ), somme = sum( perf[!(is.na(perf) | is.nan(perf))] * pond_camp_ahp[!(is.na(perf) | is.nan(perf))] ), SOMME_tot = somme / pond * 10, ecowcamp = ifelse( is.na(ptgp_n) & is.na(p120_n) & is.na(p210_n), # Si pas de pointage, on réduit la note NA, round(SOMME_tot * 10, 0) ), produits = toJSON(produits, auto_unbox = TRUE) ) %>% ungroup() # remplissage de la table vaches avec les notes campagnes # 1) Moyenne ecowcamp par mère moy_camp <- synth_prod_vache_n %>% filter(ecowcamp > 10) %>% group_by(numeroMipg) %>% summarise(moyecowcamp = round(mean(ecowcamp, na.rm = TRUE), 1), .groups = "drop") # 3) Fusion + transformations 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_prod_vache_n <- synth_prod_vache_n %>% mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100)) save_data_campagne(synth_prod_vache_n, 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 filles_taureaux <- produits_taureaux %>% filter(sexe == 2) # Petits produits issus des filles des taureaux pprod_filles_taureaux <- add_data_ecow(cheptel_ecow$petits_produits, 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) 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( pctfillesact_avecprod = round( fillesact_nbavecprod / fillestot_nbavecprod * 100, 1 ) ) stats_filles_renouv <- produits_cheptel %>% filter( is.na(NBPRODIPG),# TODO valider avec Lauréna que c'est bien ce champ là qu'on veut 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, 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_________________ # Si je ne mets pas descendants, je perds les stats directe des vaches achetées car elles n'ont pas encore de petits_produits stats_prod <- get_stats_parent(descendants, fondatrice) # produits lignées ou descendants ???? 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),# TODO valider avec Lauréna que c'est bien ce champ là qu'on veut 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") }