From 46f7294fc06ec687fe4e61055960ee309d0d1b50 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9a?= Date: Tue, 4 Aug 2026 09:52:25 +0200 Subject: [PATCH] =?UTF-8?q?[=C3=A9Cow]=20Ajout=20partie=20lign=C3=A9es?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- R/project/ecow_calculations.R | 307 +++++++--------------------------- R/project/postprocessing.R | 99 +++++++---- R/project/preprocessing.R | 91 +++++++++- 3 files changed, 215 insertions(+), 282 deletions(-) diff --git a/R/project/ecow_calculations.R b/R/project/ecow_calculations.R index c2db516..359b6b5 100755 --- a/R/project/ecow_calculations.R +++ b/R/project/ecow_calculations.R @@ -12,6 +12,7 @@ suppressPackageStartupMessages({ }) 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 @@ -74,11 +75,14 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { pps <- params_ponderation$pointage$sevrage # Ajout à la table vache des informations synthétisées de leur veaux - synth <- get_synth_prod_vaches(vaches, prod_vaches_corr, params_ponderation) - synth_vaches <- synth$synthese + 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$stats_chep + 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 ####### @@ -96,7 +100,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { 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 + 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), @@ -261,113 +265,20 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { # Petits produits issus des filles des taureaux pprod_filles_taureaux <- add_data_ecow(cheptel_ecow$petits_produits, czhbc) - # TODO quel effet chep ? Comment on l'applique ? - # PLUS besoin de calculer effet chep car pas de calcul de rang -> fonction de synth à modifier - - synth_ft <- get_synth_prod_vaches(filles_taureaux, pprod_filles_taureaux, params_ponderation) - synth_filles_taureaux <- synth_ft$synthese + # 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_peres <- produits_taureaux %>% - group_by(pereGenetique) %>% - summarise( - nb_prod_in_chep = n(), - .groups = "drop" - ) %>% - filter(nb_prod_in_chep >= 5) + stats_prod_directe <- get_stats_parent(produits_taureaux, pereGenetique) - stats_prod_directe <- produits_taureaux %>% - group_by(pereGenetique) %>% - summarise( - utilgen = round(mean(rangVelageMipg == 1, na.rm = TRUE) * 100, 1), - prol = round(n() / n_distinct(dateNaiss, numeroMipg) * 100, 1), - mort = round((sum(mortsev == "O" | mortnat == "O", na.rm = TRUE)) / n() * 100, 1), - - txrepros = round( - sum(repro == "O", na.rm = TRUE) / - sum(is.na(mortsev) & is.na(mortnat)) * 100, 1 - ), - - nbpp = sum(NBPRODIPG, na.rm = TRUE), - txvf = round(mean(conditionNaiss %in% c("1", "2"), na.rm = TRUE) * 100, 1), - - pnm = round(mean(poidsNaiss[sexe == "1"], na.rm = TRUE), 1), - pnf = round(mean(poidsNaiss[sexe == "2"], na.rm = TRUE), 1), - - p120m = round(mean(pat120[sexe == "1"], na.rm = TRUE), 1), - p120f = round(mean(pat120[sexe == "2"], na.rm = TRUE), 1), - - p210m = round(mean(pat210[sexe == "1"], na.rm = TRUE), 1), - p210f = round(mean(pat210[sexe == "2"], na.rm = TRUE), 1), - - dmsev = round(mean(dmSevrage, na.rm = TRUE), 1), - dssev = round(mean(dsSevrage, na.rm = TRUE), 1), - afsev = round(mean(afSevrage, na.rm = TRUE), 1), + stats_filles <- get_stats_filles(synth_filles_taureaux, "fillestot_", pereGenetique, actif = FALSE) - nb_femelles = sum(sexe == "2", na.rm = TRUE), - .groups = "drop" - ) - - stats_filles <- synth_filles_taureaux %>% - group_by(pereGenetique) %>% - summarise( - nbfilles_avecprod = sum(NBPRODIPG > 0, na.rm = TRUE), - pctfilles_avecprod = round(nbfilles_avecprod / n() * 100, 1), - isu_fillestot = ifelse(n() >= 3, sum(embryon == "O", na.rm = TRUE), NA), - age_sort_fillestot = ifelse(n() >= 3, round(mean(age_years, na.rm = TRUE), 1), NA), - agevel1_fillestot = ifelse(n() >= 3, round(mean(agevel1, na.rm = TRUE), 1), NA), - ivv1_fillestot = ifelse(n() >= 3, round(mean(ivv1, na.rm = TRUE), 1), NA), - ivv2p_fillestot = ifelse(n() >= 3, round(mean(ivv2Brut, na.rm = TRUE), 1), NA), - vieprod_fillestot = ifelse(n() >= 3, round(mean(tempsprod, na.rm = TRUE), 1), NA), - - dmad_fillestot = ifelse(n() >= 3, round(mean(dmcAdulte, na.rm = TRUE), 1), NA), - dsad_fillestot = ifelse(n() >= 3, round(mean(dsAdulte, na.rm = TRUE), 1), NA), - afad_fillestot = ifelse(n() >= 3, round(mean(afAdulte, na.rm = TRUE), 1), NA), - - prol_fillestot = ifelse(n() >= 3, round(mean(prol, na.rm = TRUE), 1), NA), - mort_fillestot = ifelse(n() >= 3, round(mean(mort, na.rm = TRUE), 1), NA), - txvf_fillestot = ifelse(n() >= 3, round(mean(txvf, na.rm = TRUE), 1), NA), - - nbprod_fillestot = ifelse(n() >= 3, sum(NBPRODIPG, na.rm = TRUE), NA), - txrepros_fillestot = ifelse(n() >= 3, round(mean(txrepros, na.rm = TRUE), 1), NA), - nbpp_fillestot = ifelse(n() >= 3, sum(nbpp, na.rm = TRUE), NA), - - .groups = "drop" - ) - - stats_filles_act <- synth_filles_taureaux %>% - filter(is.na(dateSortDetenteur)) %>% - group_by(pereGenetique) %>% - summarise( - nbfillesact_avecprod = sum(NBPRODIPG > 0, na.rm = TRUE), - #pctfillesact_avecprod = round(nbfillesact_avecprod / nbfilles_avecprod * 100, 1), - - isu_fillesact = 0, - age_sort_fillesact = ifelse(n() >= 3, round(mean(age_years, na.rm = TRUE), 1), NA), - agevel1_fillesact = ifelse(n() >= 3, round(mean(agevel1, na.rm = TRUE), 1), NA), - ivv1_fillesact = ifelse(n() >= 3, round(mean(ivv1, na.rm = TRUE), 1), NA), - ivv2p_fillesact = ifelse(n() >= 3, round(mean(ivv2Brut, na.rm = TRUE), 1), NA), - vieprod_fillesact = ifelse(n() >= 3, round(mean(tempsprod, na.rm = TRUE), 1), NA), - - dmad_fillesact = ifelse(n() >= 3, round(mean(dmcAdulte, na.rm = TRUE), 1), NA), - dsad_fillesact = ifelse(n() >= 3, round(mean(dsAdulte, na.rm = TRUE), 1), NA), - afad_fillesact = ifelse(n() >= 3, round(mean(afAdulte, na.rm = TRUE), 1), NA), - - prol_fillesact = ifelse(n() >= 3, round(mean(prol, na.rm = TRUE), 1), NA), - mort_fillesact = ifelse(n() >= 3, round(mean(mort, na.rm = TRUE), 1), NA), - txvf_fillesact = ifelse(n() >= 3, round(mean(txvf, na.rm = TRUE), 1), NA), - - nbprod_fillesact = ifelse(n() >= 3, sum(NBPRODIPG, na.rm = TRUE), NA), - txrepros_fillesact = ifelse(n() >= 3, round(mean(txrepros, na.rm = TRUE), 1), NA), - nbpp_fillesact = ifelse(n() >= 3, sum(nbpp, na.rm = TRUE), NA), - - .groups = "drop" - ) + stats_filles_act <- get_stats_filles(synth_filles_taureaux, "fillesact_", pereGenetique, actif = TRUE) grp_filles_et_act <- stats_filles %>% dplyr::left_join(stats_filles_act, by = "pereGenetique") %>% mutate( - pctfillesact_avecprod = round( nbfillesact_avecprod / nbfilles_avecprod * 100, 1 ) + pctfillesact_avecprod = round( fillesact_nbavecprod / fillestot_nbavecprod * 100, 1 ) ) stats_filles_renouv <- produits_cheptel %>% @@ -381,21 +292,18 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { .groups = "drop" ) - stats_taureaux <- stats_peres %>% - dplyr::left_join(stats_prod_directe, by = "pereGenetique") %>% + 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, by = "pereGenetique") - - # Récupère le nom - stats_taureaux <- stats_taureaux %>% - select(-nom, -dateNaiss, -nomCheptelNaiss) %>% - dplyr::left_join(taureaux %>% select(anim, nom, dateNaiss, nomCheptelNaiss), - by = c("pereGenetique" = "anim")) %>% - mutate(nom = replace(nom, is.na(nom), "")) %>% - mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100)) + 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) + ) - save_data_taureau(stats_taureaux, cheptel) + message("Enregistrement données taureaux") + save_data_taureau(stats_taureaux) if (step == 2) { t1 <- Sys.time() @@ -408,137 +316,48 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { ################################################################################################################### fondatrices <- cheptel_ecow$fondatrices - descendants <- cheptel_ecow$descendants + descendants <- add_data_ecow(cheptel_ecow$descendants, czhbc) - vaches_lignees <- descendants %>% - filter(anim %in% descendants$mereIpg) - produits_lignees <- add_data_ecow( - descendants %>% - filter(mereIpg %in% descendants$anim) + 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_________________ + + 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) + + stats_fem_act <- get_stats_filles(synth_vaches_lignees, "femact_", fondatrice, actif = TRUE) + + 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) + ) %>% + group_by(fondatrice) %>% + summarise( + nbfilles_renouv = n(), + .groups = "drop" ) - # - # # TODO quel effet chep ? Comment on l'applique ? - # - # synth_vaches_lignees <- get_synth_prod_vaches(vaches_lignees, produits_lignees, params_ponderation, stats_chep) - # - # # calcul des stats par fondatrice ______________________________________________ - # - # stats_prod <- produits_lignees %>%stats_prod <- produits_ligne% - # summarise( - # nb_desc_in_chep = n(), - # - # utilgen = round(mean(ravelamere == 1, na.rm = TRUE) * 100, 1), - # - # prol = round( - # n() / n_distinct(danais, mere) * 100, 1 - # ), - # - # mort = round(mean(mortsev == "O", na.rm = TRUE) * 100, 1), - # - # txrepros = round( - # sum(repro == "O", na.rm = TRUE) / - # sum(is.na(mortsev)) * 100, 1 - # ), - # - # nbpp = sum(nbdescendants, na.rm = TRUE), - # - # txvf = round(mean(conais %in% c("1", "2"), na.rm = TRUE) * 100, 1), - # - # pnm = round(mean(ponais[sexbov == "1"], na.rm = TRUE), 1), - # pnf = round(mean(ponais[sexbov == "2"], na.rm = TRUE), 1), - # - # p120m = round(mean(pat04m[sexbov == "1"], na.rm = TRUE), 1), - # p120f = round(mean(pat04m[sexbov == "2"], na.rm = TRUE), 1), - # - # p210m = round(mean(pat07m[sexbov == "1"], na.rm = TRUE), 1), - # p210f = round(mean(pat07m[sexbov == "2"], na.rm = TRUE), 1), - # - # dmsev = round(mean(devmus[sexbov == "1"], na.rm = TRUE), 1), # A CORRIGER CF TAUREAUX - # dssev = round(mean(devsqe[sexbov == "2"], na.rm = TRUE), 1), - # - # nb_fem_prod = sum(sexbov == "2", na.rm = TRUE) - # ) %>% - # filter(nb_desc_in_chep >= 5) - # - # stats_fem_tot <- synth_vaches_lignees %>% - # group_by(fondatrice) %>% - # summarise( - # nbfem_avecprod = n(), - # - # isu_femtot = ifelse(n() >= 3, round(mean(indisu, na.rm = TRUE), 1), NA), - # age_sort_femtot = ifelse(n() >= 3, round(mean(age_years, na.rm = TRUE), 1), NA), - # agevel1_femtot = ifelse(n() >= 3, round(mean(agevel1, na.rm = TRUE), 1), NA), - # vieprod_femtot = ifelse(n() >= 3, round(mean(tempsprod, na.rm = TRUE), 1), NA), - # ivv1_femtot = ifelse(n() >= 3, round(mean(ivv1, na.rm = TRUE), 1), NA), - # ivv2p_femtot = ifelse(n() >= 3, round(mean(as.numeric(ivv2p), na.rm = TRUE), 1), NA), - # - # dmad_femtot = ifelse(n() >= 3, round(mean(dmC, na.rm = TRUE), 1), NA), - # dsad_femtot = ifelse(n() >= 3, round(mean(ds, na.rm = TRUE), 1), NA), - # afad_femtot = ifelse(n() >= 3, round(mean(af, na.rm = TRUE), 1), NA), - # - # prol_femtot = ifelse(n() >= 3, round(mean(prol, na.rm = TRUE), 1), NA), - # mort_femtot = ifelse(n() >= 3, round(mean(mort, na.rm = TRUE), 1), NA), - # txvf_femtot = ifelse(n() >= 3, round(mean(txvf, na.rm = TRUE), 1), NA), - # - # nbprod_femtot = ifelse(n() >= 3, sum(nbdescendants, na.rm = TRUE), NA), - # txrepros_femtot = ifelse(n() >= 3, round(mean(txrepros, na.rm = TRUE), 1), NA), - # nbpp_femtot = ifelse(n() >= 3, sum(nbpp, na.rm = TRUE), NA) - # ) - # - # stats_fem_act <- synth_vaches_lignees %>% - # filter(is.na(dasort)) %>% - # group_by(fondatrice) %>% - # summarise( - # nbfemact_avecprod = n(), - # - # isu_femact = ifelse(n() >= 3, round(mean(indisu, na.rm = TRUE), 1), NA), - # age_sort_femact = ifelse(n() >= 3, round(mean(age_years, na.rm = TRUE), 1), NA), - # agevel1_femact = ifelse(n() >= 3, round(mean(agevel1, na.rm = TRUE), 1), NA), - # vieprod_femact = ifelse(n() >= 3, round(mean(tempsprod, na.rm = TRUE), 1), NA), - # ivv1_femact = ifelse(n() >= 3, round(mean(ivv1, na.rm = TRUE), 1), NA), - # ivv2p_femact = ifelse(n() >= 3, round(mean(as.numeric(ivv2p), na.rm = TRUE), 1), NA), - # - # dmad_femact = ifelse(n() >= 3, round(mean(dmC, na.rm = TRUE), 1), NA), - # dsad_femact = ifelse(n() >= 3, round(mean(ds, na.rm = TRUE), 1), NA), - # afad_femact = ifelse(n() >= 3, round(mean(af, na.rm = TRUE), 1), NA), - # - # prol_femact = ifelse(n() >= 3, round(mean(prol, na.rm = TRUE), 1), NA), - # mort_femact = ifelse(n() >= 3, round(mean(mort, na.rm = TRUE), 1), NA), - # txvf_femact = ifelse(n() >= 3, round(mean(txvf, na.rm = TRUE), 1), NA), - # - # nbprod_femact = ifelse(n() >= 3, sum(nbdescendants, na.rm = TRUE), NA), - # txrepros_femact = ifelse(n() >= 3, round(mean(txrepros, na.rm = TRUE), 1), NA), - # nbpp_femact = ifelse(n() >= 3, sum(nbpp, na.rm = TRUE), NA) - # ) - # - # stats_renouv <- inv_desc %>% - # filter( - # nbdescendants == 0, - # sexbov == "2", - # actif == "1" - # ) %>% - # group_by(fondatrice) %>% - # summarise(nbfem_renouv = n()) - # - # 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") %>% - # mutate( - # pctfem_avecprod = - # round(nbfem_avecprod / nb_fem_prod * 100, 1), - # pctfemact_avecprod = - # round(nbfemact_avecprod / nb_fem_prod * 100, 1) - # ) - # - # stats_lignees_final <- fondatrices %>% - # mutate(anim = trim_str(anim)) %>% - # dplyr::left_join( - # stats_lignees %>% mutate(fondatrice = trim_str(fondatrice)), - # by = c("anim" = "fondatrice") - # ) - # - # save_data_lignees(stats_lignees_final) + + 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 / nb_femelles * 100, 1), + cheptel = cheptel + ) + + message("Enregistrement données lignées") + save_data_lignees(stats_lignees) t1 <- Sys.time() message("Fin du traitement. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec") } diff --git a/R/project/postprocessing.R b/R/project/postprocessing.R index 9c52c93..a61ed9d 100755 --- a/R/project/postprocessing.R +++ b/R/project/postprocessing.R @@ -40,19 +40,13 @@ maj_ecow_for_all <- function() { maj_ecow_for_list_cheptels(list_chep) } -mafonctiondetest <- function(cheptel){ - source(here::here("R/common/ws_client.R")) - cheptel_ecow <- get_cheptel_ecow(cheptel) - vaches <- cheptel_ecow$vaches - return(length(vaches)) -} - #' Mise à jour de l'indicateur Ecow pour une liste de cheptels et gestion des erreurs #' @param list_cheptels list. Liste de numéros de cheptels avec le FR devant maj_ecow_for_list_cheptels <- function(list_cheptels){ total <- length(list_cheptels) start_time <- Sys.time() message(sprintf("🚀 Début traitement - %s cheptels à traiter", total)) + flush.console() res <- lapply(seq_along(list_cheptels), function(i) { num_chep <- list_cheptels[[i]] @@ -60,17 +54,21 @@ maj_ecow_for_list_cheptels <- function(list_cheptels){ tryCatch( { message(sprintf("[%s/%s] Traitement cheptel %s ...", i, total, num_chep)) - out <- calcul_ecow_by_chep(num_chep, 1) # Pour l'instant on s'arrête aux vaches + flush.console() + out <- calcul_ecow_by_chep(num_chep, 3) # Pour l'instant on s'arrête aux vaches message(sprintf("✓ OK cheptel %s", num_chep)) + flush.console() out }, error = function(e) { message(sprintf("✗ ERREUR cheptel %s : %s", num_chep, conditionMessage(e))) + flush.console() NULL } ), warning = function(w) { message(sprintf("! AVERTISSEMENT cheptel %s : %s", num_chep, conditionMessage(w))) + flush.console() invokeRestart("muffleWarning") } ) @@ -84,6 +82,25 @@ maj_ecow_for_list_cheptels <- function(list_cheptels){ return(res) } + +maj_ecow_from_csv <- function() { + + cheptels <- read.csv('cheptels_liste.csv', stringsAsFactors = FALSE) + + if (!"login" %in% names(cheptels)) { + stop("Colonne 'login' absente du CSV") + } + + if (nrow(cheptels) == 0) { + message("Aucun cheptel à traiter") + return(NULL) + } + + maj_ecow_for_list_cheptels(as.list(cheptels$login)) + +} + + format_duration <- function(seconds) { h <- as.integer(seconds %/% 3600) m <- as.integer((seconds %% 3600) %/% 60) @@ -95,22 +112,17 @@ format_duration <- function(seconds) { save_data_vaches <- function(vaches){ tabfinal <- vaches %>% select( - cheptelDetenteur, anim, nom, nom_pere, embryon, donneuse, porteuse, - tempsprod, age_years, ecowcarr, rg_carr, - ptgV, agevel1, ivv1, ivv2Brut, - prol, mort, txrepros, nbpp, - txvf, pn_m, pn_f, - p120_m, p120_f, p210_m, p210_f, - ptgP, - moyecowcamp, rg_camp + cheptelDetenteur, anim, nom, nom_pere, embryon, donneuse, porteuse, tempsprod, age_years, ecowcarr, rg_carr, ptgV, + agevel1, ivv1, ivv2Brut, prol, mort, txrepros, nbpp, txvf, + pn_m, pn_f, p120_m, p120_f, p210_m, p210_f, ptgP, moyecowcamp, rg_camp ) %>% arrange(rg_carr) # Renomme les colonnes pour correspondre aux noms des champs dans la table ecow_vaches colnames(tabfinal) <- c( - "cheptel", "num_vache", "nom_vache", "pere", "isu", "donneuse", "porteuse", "pourc_vie_productive", "age_annees", "note_ecow_carr", "rang_carr", "pointage_vache", "age_1_velage_m", "ivv1_j", - "ivv2plus_j", "prolificite_pourc", "mortalite_av_sevr_pourc", "pourc_produits_repros", "nb_petits_produits", "pourc_velages_tranquilles", "pn_males_kg", - "pn_femelles_kg", "p120_males_kg", "p120_femelles_kg", "p210_males_kg", "p210_femelles_kg", "pointage_produits", "moy_notes_ecow_campagne", "rang_campagne" + "cheptel", "num_vache", "nom_vache", "pere", "isu", "donneuse", "porteuse", "pourc_vie_productive", "age_annees", "note_ecow_carr", "rang_carr", "pointage_vache", + "age_1_velage_m", "ivv1_j", "ivv2plus_j", "prolificite_pourc", "mortalite_av_sevr_pourc", "pourc_produits_repros", "nb_petits_produits", "pourc_velages_tranquilles", + "pn_males_kg", "pn_femelles_kg", "p120_males_kg", "p120_femelles_kg", "p210_males_kg", "p210_femelles_kg", "pointage_produits", "moy_notes_ecow_campagne", "rang_campagne" ) tab_format <- tabfinal %>% @@ -162,28 +174,26 @@ save_data_campagne <- function(synth_camp){ dbDisconnect(con) } -save_data_taureau <- function(data_taureaux, cheptel){ +save_data_taureau <- function(data_taureaux){ # Stockage des données écow_taureaux filtered_taureaux <- data_taureaux %>% select( - cheptelDetenteur, pereGenetique, nom, dateNaiss, nomCheptelNaiss, nb_prod_in_chep, utilgen, prol, mort, txrepros, nbpp, txvf, pnm, pnf, p120m, p120f, p210m, p210f, - dmsev, dssev, afsev, nbfilles_avecprod, pctfilles_avecprod, 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_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 + 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, + fillestot_vieprod, fillestot_dmad, fillestot_dsad, fillestot_afad, fillestot_nbprod, fillestot_txrepros, fillestot_nbpp, fillestot_prol, fillestot_mort, + fillestot_txvf, fillesact_nbavecprod, fillesact_pctavecprod, 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 ) colnames(filtered_taureaux) <- c( "cheptel", "anim", "nom", "date_naissance", "nom_chep_naiss", "nb_prod_in_chep", "utilgen", "prol", "mort", "txrepros", "nbpp", "txvf", "pnm", "pnf", "p120m", "p120f", "p210m", "p210f", "dmsev", "dssev", "afsev", "nbfilles_avecprod", "pctfilles_avecprod", "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_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" + "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" ) - - filtered_taureaux$cheptel <- cheptel con <- get_db_connection() @@ -198,14 +208,35 @@ save_data_taureau <- function(data_taureaux, cheptel){ } save_data_lignees <- function(stats_lignees){ + filtered_lignees <- stats_lignees %>% + select( + cheptel, fondatrice, nom, dateNaiss, nomCheptelNaiss, nb_prod_in_chep, utilgen, prol, mort, txrepros, nbpp, txvf, pnm, pnf, p120m, + p120f, p210m, p210f, dmsev, dssev, afsev, femtot_nbavecprod, femtot_pctavecprod, femtot_isu, femtot_age_sort, femtot_agevel1, femtot_ivv1, + femtot_ivv2p, femtot_vieprod, femtot_dmad, femtot_dsad, femtot_afad, femtot_nbprod, femtot_txrepros, femtot_nbpp, femtot_prol, + femtot_mort, femtot_txvf, femact_nbavecprod, femact_pctavecprod, 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 + ) + + colnames(filtered_lignees) <- c( + "cheptel", "anim", "nom", "date_naissance", "nom_chep_naiss", "nb_desc_in_chep", "utilgen", "prol", "mort", "txrepros", "nbpp", "txvf", "pnm", "pnf", "p120m", + "p120f", "p210m", "p210f", "dmsev", "dssev", "afsev", "nbfem_avecprod", "pctfem_avecprod", "isu_femtot", "age_sort_femtot", "agevel1_femtot", "ivv1_femtot", + "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" + ) + + con <- get_db_connection() dbWriteTable( con, Id(schema = "hbc", table = "ecow_lignees"), - stats_lignees, + filtered_lignees, append = TRUE, row.names = FALSE ) dbDisconnect(con) -} \ No newline at end of file +} + diff --git a/R/project/preprocessing.R b/R/project/preprocessing.R index 31c7d01..a3ef05d 100755 --- a/R/project/preprocessing.R +++ b/R/project/preprocessing.R @@ -96,7 +96,7 @@ get_stats_tbl <- function(tab, nom_tab, cols, conditions = NULL, nom_cond = NA) }) } -get_synth_prod_vaches <- function(vaches, produits, params_ponderation){ +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 @@ -206,7 +206,9 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){ c(ptgP, pn_m, pn_f, pn_corr, p120_m, p120_f, p120_corr, p210_m, p210_f, p210_corr), ~ ifelse(is.nan(.), NA_real_, .) )) - +} + +get_note_carriere <- function(v_ref, params_ponderation){ # calcul des stats, valeurs extremes et references pour la normalisation stats_chep <- get_stats_tbl( tab = v_ref, @@ -216,7 +218,7 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){ ) # ========================= - # 3) Normalisations + # Normalisation # ========================= v_norm <- v_ref %>% mutate( @@ -278,7 +280,7 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){ ) # ========================= - # 4) Note carrière (pondérée) + # Note carrière (pondérée) # ======================== # Récupère les paramètres de pondérations, ATTENTION, il faut que leurs noms soient parfaitement identiques à ceux de v_norm weights <- purrr::map_dbl(params_ponderation$carriere, 1) @@ -315,3 +317,84 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){ list(synthese = v_final, stats_chep = stats_chep) } +get_stats_parent <- function(produits, regroupement){ + produits %>% + group_by({{regroupement}}) %>% + summarise( + nb_prod_in_chep = n(), + utilgen = round(mean(rangVelageMipg == 1, na.rm = TRUE) * 100, 1), + prol = round(n() / n_distinct(dateNaiss, numeroMipg) * 100, 1), + mort = round((sum(mortsev == "O" | mortnat == "O", na.rm = TRUE)) / n() * 100, 1), + + txrepros = round( + sum(repro == "O", na.rm = TRUE) / + sum(is.na(mortsev) & is.na(mortnat)) * 100, 1 + ), + + nbpp = sum(NBPRODIPG, na.rm = TRUE), + txvf = round(mean(conditionNaiss %in% c("1", "2"), na.rm = TRUE) * 100, 1), + + pnm = round(mean(poidsNaiss[sexe == "1"], na.rm = TRUE), 1), + pnf = round(mean(poidsNaiss[sexe == "2"], na.rm = TRUE), 1), + + p120m = round(mean(pat120[sexe == "1"], na.rm = TRUE), 1), + p120f = round(mean(pat120[sexe == "2"], na.rm = TRUE), 1), + + p210m = round(mean(pat210[sexe == "1"], na.rm = TRUE), 1), + p210f = round(mean(pat210[sexe == "2"], na.rm = TRUE), 1), + + dmsev = round(mean(dmSevrage, na.rm = TRUE), 1), + dssev = round(mean(dsSevrage, na.rm = TRUE), 1), + afsev = round(mean(afSevrage, na.rm = TRUE), 1), + + nb_femelles = sum(sexe == "2", na.rm = TRUE), + .groups = "drop" + ) %>% + filter(nb_prod_in_chep >= 5) +} + +#' Renvoie les statistiques des produits pour les éléments ayant plus de 3 produits +#' @param regroupement character. Champs sur lequel on veut faire le regroupement +#' @param actif booléen. Filtre sur les produits +#' selon le champs {} +#' @return Liste d'adhérents +get_stats_filles <- function(df, prefix, regroupement, actif = FALSE) { + nb <- df %>% + group_by({{regroupement}}) %>% + summarise( + "{prefix}count" := n(), + .groups = "drop" + ) + + if (actif) { + df <- df %>% filter(is.na(dateSortDetenteur)) + } + + res <- df %>% 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}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), + "{prefix}ivv1" := ifelse(n() >= 3, round(mean(ivv1, na.rm = TRUE), 1), NA), + "{prefix}ivv2p" := ifelse(n() >= 3, round(mean(ivv2Brut, na.rm = TRUE), 1), NA), + "{prefix}vieprod" := ifelse(n() >= 3, round(mean(tempsprod, na.rm = TRUE), 1), NA), + + "{prefix}dmad" := ifelse(n() >= 3, round(mean(dmcAdulte, na.rm = TRUE), 1), NA), + "{prefix}dsad" := ifelse(n() >= 3, round(mean(dsAdulte, na.rm = TRUE), 1), NA), + "{prefix}afad" := ifelse(n() >= 3, round(mean(afAdulte, na.rm = TRUE), 1), NA), + + "{prefix}prol" := ifelse(n() >= 3, round(mean(prol, na.rm = TRUE), 1), NA), + "{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}txrepros" := ifelse(n() >= 3, round(mean(txrepros, na.rm = TRUE), 1), NA), + "{prefix}nbpp" := ifelse(n() >= 3, sum(nbpp, na.rm = TRUE), NA), + + .groups = "drop" + ) + + res <- left_join(res, nb, by = rlang::as_name(rlang::ensym(regroupement))) +}