From 9291831ee50d1bb070f32e3db95b277d82c7da0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9a?= Date: Wed, 2 Sep 2026 11:23:16 +0200 Subject: [PATCH] =?UTF-8?q?[=C3=A9Cow]=20Correctifs=20et=20nettoyage?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- R/common/ws_client.R | 43 +++++--- R/project/ecow_calculations.R | 179 +++++----------------------------- R/project/postprocessing.R | 11 +-- R/project/preprocessing.R | 169 +++++++++++++++++++++++++++++--- 4 files changed, 218 insertions(+), 184 deletions(-) diff --git a/R/common/ws_client.R b/R/common/ws_client.R index 29785f8..4f90d8f 100755 --- a/R/common/ws_client.R +++ b/R/common/ws_client.R @@ -37,10 +37,13 @@ get_cheptel_ecow <- function(num_cheptel){ active_by_chep <- http_get(url = paste0(url_active_by_chep, num_cheptel)) if(nrow(active_by_chep$vaches) == 0 ) return(active_by_chep) donneuses <- active_by_chep$donneuses + nomsparents <- active_by_chep$nomsparents active_by_chep$donneuses <- NULL + active_by_chep$nomsparents <- NULL # Nettoyage des données pour les listes reçues active_by_chep <- lapply(active_by_chep, clean_data_anims) active_by_chep$donneuses <- donneuses + active_by_chep$nomsparents <- nomsparents return(active_by_chep) } @@ -85,8 +88,6 @@ get_cztotaux <- function(){ c(czAV$animal, czS$animal, czE$animalo) } -########################################################################################### - # Retourne les informations de connection à la base get_db_connection <- function() { do.call(DBI::dbConnect, infos_con) @@ -102,7 +103,6 @@ cheptel_has_ponderation <- function(con, num_cheptel) { } #' Met en forme les données issues de la BDD pour qu'elles soient directement interrogeable -#' format_ponderation <- function(df) { df %>% mutate(sous_categorie = ifelse(is.na(sous_categorie), "NA", sous_categorie)) %>% @@ -143,17 +143,38 @@ get_params_ponderation <- function(num_cheptel){ return(format_ponderation(data)) } -######################################################################################################## -######################################################################################################## - -#' TODO Pour l'instant on récupère la dernière extraction, à terme il faudra récupérer l'intégration SPIE -#' ATTENTION problème import fichier à cause des \ User !!!!!!!!!!!!!!!!!!!!!!!!!!! +#' Récupère le nombre de veaux total par parents à partir d'une extraction excel complétée par les données SPIE +#' Le nombre renvoyé est le nombre total tous cheptels confondus, sans détail sur les veaux get_parents_ipg <- function(){ + # Extraction du fichier excel contenant les données de la table bovide du SIG jusqu'au 06/01/2026 meresIPG <- read_csv(paste(rep_imp, "nb_prod_IPG_byMERE_20260106.csv", sep=''), show_col_types = FALSE) - colnames(meresIPG) <- c('ANIM','NBPRODIPG') + colnames(meresIPG) <- c('ANIM','NBPRODSIG') + # Extraction SPIE pour compléter à partir du 03/01/2026 (choix date pour essayer de limiter les doublons et manquement) + url_meres_spie <- paste0(server_path, "webresources/spie/nbprodbymeresince2026/") + meres_spie_brut <- http_get(url = paste0(url_meres_spie, num_cheptel)) + meres_spie <- as.data.frame(meres_spie_brut, stringsAsFactors = FALSE) + colnames(meres_spie) <- c('ANIM','NBPRODSPIE') + meres_spie$NBPRODSPIE <- as.numeric(meres_spie$NBPRODSPIE) + + groupe_meres <- full_join(meres_spie, meresIPG, by = "ANIM") %>% + mutate(NBPRODIPG = coalesce(NBPRODSPIE, 0) + coalesce(NBPRODSIG, 0)) %>% + select(ANIM, NBPRODIPG) + + # Extraction excel pères peresIPG <- read_csv(paste(rep_imp, "nb_prod_IPG_byPERE_20260106.csv", sep=''), show_col_types = FALSE) - colnames(peresIPG) <- c('ANIM','NBPRODIPG') + colnames(peresIPG) <- c('ANIM','NBPRODSIG') - parentsIPG <- rbind(meresIPG, peresIPG) + # Extraction SPIE pères + url_peres_spie <- paste0(server_path, "webresources/spie/nbprodbyperesince2026/") + peres_spie_brut <- http_get(url = paste0(url_peres_spie, num_cheptel)) + peres_spie <- as.data.frame(peres_spie_brut, stringsAsFactors = FALSE) + colnames(peres_spie) <- c('ANIM','NBPRODSPIE') + peres_spie$NBPRODSPIE <- as.numeric(peres_spie$NBPRODSPIE) + + groupe_peres <- full_join(peres_spie, peresIPG, by = "ANIM") %>% + mutate(NBPRODIPG = coalesce(NBPRODSPIE, 0) + coalesce(NBPRODSIG, 0)) %>% + select(ANIM, NBPRODIPG) + + parentsIPG <- rbind(groupe_meres, groupe_peres) } diff --git a/R/project/ecow_calculations.R b/R/project/ecow_calculations.R index 26f5a69..abe987a 100755 --- a/R/project/ecow_calculations.R +++ b/R/project/ecow_calculations.R @@ -42,14 +42,14 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { # 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 + # 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, czhbc) + produits_cheptel <- add_data_ecow(cheptel_ecow$produits, cheptel_ecow$nomsparents, czhbc) ################################################################################################################### @@ -78,153 +78,23 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { 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 - + 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 ####### - # ============================== - # 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" - ) + # 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 - # 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 %>% + # 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") - # 3) Fusion + transformations + # 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( @@ -240,9 +110,9 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { save_data_vaches(v_camp, cheptel) # Enregistrement des données de campagne en base - synth_prod_vache_n <- synth_prod_vache_n %>% + synth_campagne <- synth_campagne %>% mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100)) - save_data_campagne(synth_prod_vache_n, cheptel) + save_data_campagne(synth_campagne, cheptel) if (step == 1) { t1 <- Sys.time() @@ -258,19 +128,20 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { produits_taureaux <- produits_cheptel %>% filter(pereGenetique %in% taureaux$anim & embryon != 'O') - # Récupères les filles des taureaux + # 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 - pprod_filles_taureaux <- add_data_ecow(cheptel_ecow$petits_produits, czhbc) + # 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) @@ -278,12 +149,13 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { 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),# TODO valider avec Lauréna que c'est bien ce champ là qu'on veut + 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) ) %>% @@ -317,17 +189,16 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { ################################################################################################################### message("Début partie Lignées") fondatrices <- cheptel_ecow$fondatrices - descendants <- add_data_ecow(cheptel_ecow$descendants, czhbc) + 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_________________ - - # 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 ???? + # 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) @@ -335,7 +206,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { stats_renouv <- descendants %>% filter( - is.na(NBPRODIPG),# TODO valider avec Lauréna que c'est bien ce champ là qu'on veut + 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 diff --git a/R/project/postprocessing.R b/R/project/postprocessing.R index 90aa765..7d7428d 100755 --- a/R/project/postprocessing.R +++ b/R/project/postprocessing.R @@ -100,7 +100,6 @@ maj_ecow_from_csv <- function() { } - format_duration <- function(seconds) { h <- as.integer(seconds %/% 3600) m <- as.integer((seconds %% 3600) %/% 60) @@ -185,11 +184,11 @@ save_data_taureau <- function(taureaux, cheptel){ filtered_taureaux <- taureaux %>% select( cheptel, pereGenetique, nom, dateNaiss, nomCheptelNaiss, nb_prod_in_chep, utilgen, prol, mort, txrepros, nbpp, txvf, pnm, pnf, p120m, p120f, p210m, p210f, - dmsev, dssev, afsev, fillestot_nbavecprod, fillestot_pctavecprod, fillestot_isu, fillestot_age_sort, fillestot_agevel1, fillestot_ivv1, fillestot_ivv2p, + dmsev, dssev, afsev, fillestot_nbavecprod, pctfilles_avecprod, fillestot_isu, fillestot_age_sort, fillestot_agevel1, fillestot_ivv1, fillestot_ivv2p, fillestot_vieprod, fillestot_dmad, fillestot_dsad, fillestot_afad, fillestot_nbprod, fillestot_txrepros, fillestot_nbpp, fillestot_prol, fillestot_mort, fillestot_txvf, fillesact_nbavecprod, pctfillesact_avecprod, fillesact_isu, fillesact_age_sort, fillesact_agevel1, fillesact_ivv1, fillesact_ivv2p, fillesact_vieprod, fillesact_dmad, fillesact_dsad, fillesact_afad, fillesact_nbprod, fillesact_txrepros, fillesact_nbpp, fillesact_prol, fillesact_mort, - fillesact_txvf, nbfilles_renouv + fillesact_txvf, nbfilles_renouv, fillestot_produits ) colnames(filtered_taureaux) <- c( @@ -198,7 +197,7 @@ save_data_taureau <- function(taureaux, cheptel){ "vieprod_fillestot", "dmad_fillestot", "dsad_fillestot", "afad_fillestot", "nbprod_fillestot", "txrepros_fillestot", "nbpp_fillestot", "prol_fillestot", "mort_fillestot", "txvf_fillestot", "nbfillesact_avecprod", "pctfillesact_avecprod", "isu_fillesact", "age_sort_fillesact", "agevel1_fillesact", "ivv1_fillesact", "ivv2p_fillesact", "vieprod_fillesact", "dmad_fillesact", "dsad_fillesact", "afad_fillesact", "nbprod_fillesact", "txrepros_fillesact", "nbpp_fillesact", "prol_fillesact", "mort_fillesact", - "txvf_fillesact", "nbfilles_renouv" + "txvf_fillesact", "nbfilles_renouv", "produits" ) nb_lignes_supp <- delete_data_today(cheptel, "TAUREAUX") @@ -224,7 +223,7 @@ save_data_lignees <- function(lignees, cheptel){ femtot_ivv2p, femtot_vieprod, femtot_dmad, femtot_dsad, femtot_afad, femtot_nbprod, femtot_txrepros, femtot_nbpp, femtot_prol, femtot_mort, femtot_txvf, femact_nbavecprod, pctfemact_avecprod, femact_isu, femact_age_sort, femact_agevel1, femact_ivv1, femact_ivv2p, femact_vieprod, femact_dmad, femact_dsad, femact_afad, femact_nbprod, femact_txrepros, femact_nbpp, femact_prol, - femact_mort, femact_txvf, nbfilles_renouv + femact_mort, femact_txvf, nbfilles_renouv, femtot_produits ) colnames(filtered_lignees) <- c( @@ -233,7 +232,7 @@ save_data_lignees <- function(lignees, cheptel){ "ivv2p_femtot", "vieprod_femtot", "dmad_femtot", "dsad_femtot", "afad_femtot", "nbprod_femtot", "txrepros_femtot", "nbpp_femtot", "prol_femtot", "mort_femtot", "txvf_femtot", "nbfemact_avecprod", "pctfemact_avecprod", "isu_femact", "age_sort_femact", "agevel1_femact", "ivv1_femact", "ivv2p_femact", "vieprod_femact", "dmad_femact", "dsad_femact", "afad_femact", "nbprod_femact", "txrepros_femact", "nbpp_femact", "prol_femact", - "mort_femact", "txvf_femact", "nbfem_renouv" + "mort_femact", "txvf_femact", "nbfem_renouv", "produits" ) nb_lignes_supp <- delete_data_today(cheptel, "LIGNEES") diff --git a/R/project/preprocessing.R b/R/project/preprocessing.R index cc618b5..f3e7f5d 100755 --- a/R/project/preprocessing.R +++ b/R/project/preprocessing.R @@ -9,12 +9,14 @@ source(here::here('R/common/utils.R')) #' Met en forme le tableau des produits des vaches #' Ajoutes les colonnes nécessaires au calcul du rang ecow des vaches #' @param produits_vaches dataframe. Tab des produits des vaches du cheptel -add_data_ecow <- function(liste_produits, czhbc){ +add_data_ecow <- function(liste_produits, noms_parents, czhbc){ - #Ajout d'une colonne avec le nombre de produits IPG ------------------ TODO PEUT ETRE PLUS UTILE, à comparer avec nb_fin_gestation - # Croisement avec les données SPIE + #Ajout d'une colonne avec le nombre de produits IPG (croisement base SIG et SPIE) parents_ipg <- get_parents_ipg() liste_produits <- base::merge(liste_produits, get_parents_ipg(), by.x='anim', by.y='ANIM', all.x=T, all.y=F) + noms_parents <- as.data.frame(noms_parents) + liste_produits$nommere <- noms_parents$V2[match(liste_produits$numeroMipg, noms_parents$V1)] + liste_produits$nompere <- noms_parents$V2[match(liste_produits$pereGenetique, noms_parents$V1)] # Calcul REPRO liste_produits <- liste_produits %>% @@ -22,7 +24,6 @@ add_data_ecow <- function(liste_produits, czhbc){ repro = case_when( anim %in% czhbc$ANIM ~ "O", !is.na(NBPRODIPG) & NBPRODIPG > 0 ~ "O", - nbFinGestation > 0 ~ "O", # TODO pas sure que ce soit la bonne variable TRUE ~ NA_character_ ) ) %>% @@ -96,6 +97,7 @@ get_stats_tbl <- function(tab, nom_tab, cols, conditions = NULL, nom_cond = NA) }) } +#' Renvoie la synthèse pour chaque vache des performances de ses produits get_synth_prod_parent <- function(vaches, produits, params_ponderation){ # On récupère les coefficients de pondération pour les pointages adultes ppa <- params_ponderation$pointage$adulte @@ -313,8 +315,128 @@ get_note_carriere <- function(v_ref, params_ponderation){ mutate( rg_carr = as.integer(rank(1 / ecowcarr, na.last="keep")) ) +} + +get_note_campagne <- function(prod_vaches_corr, params_ponderation){ + + # Groupement et synthèse des données des produits par vache / date de naissance / rang de vélage de la mère + # Ca permet de grouper les jumeaux + 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, + mort = round(mean(mortsev == "O" | mortnat == "O") * 100, 1), + pere = first(pereGenetique), + nom_pere = first(nompere), + + # infos des veaux pour simplifier l'affichage + produits = list( + pmap( + list( + nom = nom, + anim = anim, + sexe = sexe, + mortnat = mortnat, + mortsev = mortsev, + # Nombre de produits tous cheptels confondus + NBPRODIPG = NBPRODIPG, + embryon = embryon + ), + list + ) + ), + .groups = "drop" + ) + + # Calcul des stats campagne pour chaque variable + 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') + ) - list(synthese = v_final, stats_chep = stats_chep) + pond_camp_fin <- unlist(params_ponderation$campagne$final) + pond_camp_ahp <- unlist(params_ponderation$campagne$AHPtech) + + # Normalisation des valeurs par rapport aux statistiques de campagnes + 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_camp$max[stats_camp$var=="synth_prod_vache$txvf"] - txvf) / + abs(diff(range(stats_camp[stats_camp$var=="synth_prod_vache$txvf",c("min","max")]))), 3), + + txm_n = round(1 - abs(stats_camp$max[stats_camp$var=="synth_prod_vache$txm"] - txm) / + abs(diff(range(stats_camp[stats_camp$var=="synth_prod_vache$txm",c("min","max")]))), 3), + + ptgp_n = round(1 - abs(stats_camp$max[stats_camp$var=="synth_prod_vache$ptgp"] - ptgp) / + abs(diff(range(stats_camp[stats_camp$var=="synth_prod_vache$ptgp",c("min","max")]))), 3), + + p120_n = round(1 - abs(stats_camp$max[stats_camp$var=="synth_prod_vache$p120_c"] - p120_c) / + abs(diff(range(stats_camp[stats_camp$var=="synth_prod_vache$p120_c",c("min","max")]))), 3), + + p210_n = round(1 - abs(stats_camp$max[stats_camp$var=="synth_prod_vache$p210_c"] - p210_c) / + abs(diff(range(stats_camp[stats_camp$var=="synth_prod_vache$p210_c",c("min","max")]))), 3), + # prol + prol_n = case_when( + is.na(prol) ~ NA_real_, + prol == 100 ~ 0.8, + TRUE ~ 1 + ), + # mortalité + mort_n = round(exp(-0.031 * mort), 3), + # IVV + 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) + ) + ) %>% + + # Calcul du 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() } get_stats_parent <- function(produits, regroupement){ @@ -353,10 +475,9 @@ get_stats_parent <- function(produits, regroupement){ filter(nb_prod_in_chep >= 5) } -#' Renvoie les statistiques des produits pour les éléments ayant plus de 3 produits +#' Renvoie les statistiques des produits pour les éléments ayant plus de 3 produits dans le cheptel #' @param regroupement character. Champs sur lequel on veut faire le regroupement -#' @param actif booléen. Filtre sur les produits -#' selon le champs {} +#' @param actif booléen. Filtre sur les produits actifs #' @return Liste d'adhérents get_stats_filles <- function(df, prefix, regroupement, actif = FALSE, cheptel) { nb <- df %>% @@ -364,7 +485,7 @@ get_stats_filles <- function(df, prefix, regroupement, actif = FALSE, cheptel) { summarise( "{prefix}count" := n(), .groups = "drop" - ) + ) if (actif) { df <- df %>% @@ -374,10 +495,14 @@ get_stats_filles <- function(df, prefix, regroupement, actif = FALSE, cheptel) { ) } - res <- df %>% group_by({{regroupement}}) %>% + res <- df %>% + filter( + !is.na(n_veaux) # Garde seulement les filles ayant produit dans le cheptel + ) %>% + group_by({{regroupement}}) %>% summarise( - "{prefix}nbavecprod" := sum(NBPRODIPG > 0, na.rm = TRUE), - "{prefix}pctavecprod" := round(sum(NBPRODIPG > 0, na.rm = TRUE) / n() * 100, 1), + "{prefix}nbavecprod" := sum( n_veaux > 0, na.rm = TRUE), + "{prefix}pctavecprod" := round(sum(n_veaux > 0, na.rm = TRUE) / n() * 100, 1), "{prefix}isu" := ifelse(n() >= 3, sum(embryon == "O", na.rm = TRUE), NA), "{prefix}age_sort" := ifelse(n() >= 3, round(mean(age_years, na.rm = TRUE), 1), NA), "{prefix}agevel1" := ifelse(n() >= 3, round(mean(agevel1, na.rm = TRUE), 1), NA), @@ -393,10 +518,28 @@ get_stats_filles <- function(df, prefix, regroupement, actif = FALSE, cheptel) { "{prefix}mort" := ifelse(n() >= 3, round(mean(mort, na.rm = TRUE), 1), NA), "{prefix}txvf" := ifelse(n() >= 3, round(mean(txvf, na.rm = TRUE), 1), NA), - "{prefix}nbprod" := ifelse(n() >= 3, sum(NBPRODIPG, na.rm = TRUE), NA), + "{prefix}nbprod" := ifelse(n() >= 3, sum(n_veaux, na.rm = TRUE), NA), # On veut uniquement les produits dans le cheptel "{prefix}txrepros" := ifelse(n() >= 3, round(mean(txrepros, na.rm = TRUE), 1), NA), "{prefix}nbpp" := ifelse(n() >= 3, sum(nbpp, na.rm = TRUE), NA), + # infos des produits pour l'affichage + produits = list( + pmap( + list( + nom = nom, + anim = anim, + dateNaiss = dateNaiss, + rangVelageMipg = rangVelageMipg, + numeroMipg = numeroMipg, + nommere = nommere, + pereGenetique = pereGenetique, + nompere = nompere, + active = is.na(dateSortDetenteur) & cheptelDetenteur == cheptel + ), + list + ) + ), + "{prefix}produits" := toJSON(produits, auto_unbox = TRUE), .groups = "drop" )