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")) #' 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 : ", length(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 <- get_synth_prod_vaches(vaches, prod_vaches_corr, params_ponderation) synth_vaches <- synth$synthese # calcul des stats, valeurs extremes et references pour la normalisation stats_chep <- synth$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) # 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) 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) # 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 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 <- 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(mean(mortsev == "O" | mortnat == "O") * 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" ) 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 / n() * 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" ) inventaire <- bind_rows(cheptel_ecow$vaches, cheptel_ecow$produits) inventaire <- add_data_ecow(inventaire, czhbc) stats_filles_renouv <- inventaire %>% filter( sexe == "2", NBPRODIPG == 0 ) %>% group_by(pereGenetique) %>% summarise( nbfilles_renouv = n(), .groups = "drop" ) stats_taureaux <- stats_peres %>% dplyr::left_join(stats_prod_directe, by = "pereGenetique") %>% dplyr::left_join(stats_filles, by = "pereGenetique") %>% dplyr::left_join(stats_filles_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)) 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 ######################################## ################################################################################################################### fondatrices <- cheptel_ecow$fondatrices descendants <- cheptel_ecow$descendants vaches_lignees <- descendants %>% filter(anim %in% descendants$mereIpg) produits_lignees <- add_data_ecow( descendants %>% filter(mereIpg %in% descendants$anim) ) # # # 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) t1 <- Sys.time() message("Fin du traitement. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec") }