[éCow] Correctifs et nettoyage

R/common/prepare_data.R

@@ -8,7 +8,7 @@ suppressPackageStartupMessages({
 #' @param tab_anims dataframe. Liste d'animaux brute
 #' @return Liste d'animaux nettoyée
 clean_data_anims<- function(tab_anims){
-  if (nrow(tab_anims) == 0) return()
+  if (is.null(tab_anims) || !isTRUE(nrow(tab_anims) > 0)) return()
   result_data <- tab_anims %>%
     mutate(
       dateNaiss = as.Date(as.POSIXct(dateNaiss / 1000, origin = "1970-01-01", tz = "UTC")),

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)
 }
 
@@ -61,6 +64,15 @@ get_cheptels_by_tech <- function(tech){
   )
 }
 
+#' Suppression des données du jour
+#' @param cheptel Numéro du cheptel
+#' @param table Nom de la table dont on veut supprimer les données : VACHES, CAMPAGNES, TAUREAUX, LIGNEES
+#' @return Nombre de lignes supprimées
+delete_data_today <- function(cheptel, table){
+  url_delete_data <- paste0(server_path,"webresources/ecow/delete/",cheptel,"/",table)
+  delete_data <- http_get( url = url_delete_data)
+}
+
 #' Renvoie la liste des certificats zoo totaux (Vivants + semences + embryons)
 #' @return Liste de cz
 get_cztotaux <- function(){
@@ -76,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)
@@ -93,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)) %>%
@@ -134,58 +143,38 @@ get_params_ponderation <- function(num_cheptel){
   return(format_ponderation(data))
 }
 
-#######################################################################################################
+#' Récupère le nombre de veaux total par parents à partir d'une extraction excel complétée par les données SPIE
-###################### Rien a voir avec ecow - WS pedigree de Pauline #################################
+#' Le nombre renvoyé est le nombre total tous cheptels confondus, sans détail sur les veaux
-fake <- function(){
-  library(httr)
-  library(jsonlite)
-  
-  animalIds <- c("FR7122418163","FR7122406165", "FR7122363258", "FR7122234414", "FR0311285868", "FR7122363239", "FR7122363251", "FR7122380260", "FR7122380284", "FR7122363268")
-  
-  body <- list(
-    animalsIds = animalIds,
-    #nbGenerations = 5,
-    voieFemelle = TRUE,
-    cheptel = "FR71499477"
-  )
-  
-  response <- POST(
-    #url = "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/getpedigreebyanimlist/",
-    url = "http://localhost:8080/HbcSchedulerAndServices/webresources/animals/getpedigreebyanimlist",
-    body = toJSON(body, auto_unbox = TRUE, null = "null"),
-    encode = "json"
-  )
-  
-  animalIds <- c("FR0800761491","FR0800761869")
-  
-  body <- list(
-    animalsIds = animalIds,
-    voieFemelle = TRUE,
-    cheptel = "FR08021009"
-  )
-  
-  response <- POST(
-    #url = "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/getfondatrices/",
-    url = "http://localhost:8080/HbcSchedulerAndServices/webresources/animals/getfondatrices",
-    body = toJSON(body, auto_unbox = TRUE, null = "null"),
-    encode = "json"
-  )
-  
-  result <- content(response, "parsed", encoding = "UTF-8")
-  print(result)
-}
-  
-########################################################################################################
-########################################################################################################
-
-#' 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 !!!!!!!!!!!!!!!!!!!!!!!!!!!
 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) 
 }

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
@@ -41,20 +42,20 @@ 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)
   
   
   ###################################################################################################################
   ####################################     Calcul ecow pour les vaches       ########################################
   ###################################################################################################################
-  message("Début partie vaches : ", length(vaches), " vaches à traiter.")
+  message("Début partie vaches : ", nrow(vaches), " vaches à traiter.")
   
   # Ajout info donneuses
   donneuses <- cheptel_ecow$donneuses
@@ -74,153 +75,26 @@ 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_brute_vaches <- get_synth_prod_parent(vaches, prod_vaches_corr, params_ponderation)
-  synth_vaches <- synth$synthese
   
-  # calcul des stats, valeurs extremes et references pour la normalisation
+  # Normalisation et calcul des notes carrières
-  stats_chep <- synth$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 #######
   
-  # ==============================
+  # Calcul des notes ecowcamp par vache / date de naissance / Rang de vélage 
-  # 1. Aggrégation campagnes
+  synth_campagne <- get_note_campagne(prod_vaches_corr, params_ponderation)
-  # ==============================
+  # Attribution du numéro de cheptel pour l'enregistrement en base
-  synth_prod_vache <- prod_vaches_corr %>%
+  synth_campagne$cheptel <- cheptel
-    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
+  # Moyenne de la note ecowcamp par mère pour celle ayant une note > 10
-      produits = list(
+  moy_camp <- synth_campagne %>%
-        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
+  # 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(
@@ -233,12 +107,12 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
   v_camp <- v_camp %>%
     mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100))
   
-  save_data_vaches(v_camp)
+  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)
+  save_data_campagne(synth_campagne, cheptel)
 
   if (step == 1) {
     t1 <- Sys.time()
@@ -254,122 +128,36 @@ 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 
+  # Petits produits issus des filles des taureaux nés dans le cheptel
-  pprod_filles_taureaux <- add_data_ecow(cheptel_ecow$petits_produits, czhbc)
+  pprod_filles_taureaux <- add_data_ecow(cheptel_ecow$petits_produits, cheptel_ecow$nomsparents, czhbc)
   
-  # TODO quel effet chep ? Comment on l'applique ? 
+  # Calcul de la synthèse par fille de leur produits
-  # PLUS besoin de calculer effet chep car pas de calcul de rang -> fonction de synth à modifier
+  synth_filles_taureaux <- get_synth_prod_parent(filles_taureaux, pprod_filles_taureaux, params_ponderation)
-  
-  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 %>%
+  stats_prod_directe <- get_stats_parent(produits_taureaux, pereGenetique)
-    group_by(pereGenetique) %>%
-    summarise(
-      nb_prod_in_chep = n(),
-      .groups = "drop"
-    ) %>%
-    filter(nb_prod_in_chep >= 5)
   
-  stats_prod_directe <- produits_taureaux %>%
+  # Calcul des performances des filles pour les taureaux en ayant au moins 3 
-    group_by(pereGenetique) %>%
+  stats_filles <- get_stats_filles(synth_filles_taureaux, "fillestot_", pereGenetique, actif = FALSE, cheptel)
-    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(
+  stats_filles_act <- get_stats_filles(synth_filles_taureaux, "fillesact_", pereGenetique, actif = TRUE, cheptel)
-        sum(repro == "O", na.rm = TRUE) /
-          sum(is.na(mortsev) | is.na(mortnat)) * 100, 1
-      ),
   
-      nbpp  = sum(NBPRODIPG, na.rm = TRUE),
+  grp_filles_et_act <- stats_filles %>%
-      txvf  = round(mean(conditionNaiss %in% c("1", "2"), na.rm = TRUE) * 100, 1),
+    dplyr::left_join(stats_filles_act, by = "pereGenetique") %>%
-      
+    mutate(
-      pnm   = round(mean(poidsNaiss[sexe == "1"], na.rm = TRUE), 1),
+      pctfilles_avecprod = round(fillestot_nbavecprod / fillestot_count* 100, 1),
-      pnf   = round(mean(poidsNaiss[sexe == "2"], na.rm = TRUE), 1),
+      pctfillesact_avecprod = round( fillesact_nbavecprod / fillestot_nbavecprod * 100, 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 %>%
+  stats_filles_renouv <- produits_cheptel %>%
-    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(
+      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",
-      NBPRODIPG == 0
+      is.na(dateSortDetenteur)
     ) %>%
     group_by(pereGenetique) %>%
     summarise(
@@ -377,21 +165,17 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
       .groups = "drop"
     )
       
-  stats_taureaux <- stats_peres %>%
+  stats_taureaux <- stats_prod_directe %>%
-    dplyr::left_join(stats_prod_directe,   by = "pereGenetique") %>%
+    dplyr::left_join(grp_filles_et_act,    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")
+    dplyr::left_join(taureaux %>% select(anim, nom, dateNaiss, nomCheptelNaiss),  by = c("pereGenetique" = "anim")) %>%
-  
+    mutate(
-  # Récupère le nom 
+      nom = replace(nom, is.na(nom), ""),
-  stats_taureaux <- stats_taureaux %>%
+      cheptel = cheptel,
-    select(-nom, -dateNaiss, -nomCheptelNaiss) %>%
+      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), ""))  %>%
-    mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100))
 
+  message("Enregistrement données taureaux")
   save_data_taureau(stats_taureaux, cheptel)
   
   if (step == 2) {
@@ -403,139 +187,51 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
   ###################################################################################################################
   ####################################     Remontee des lignees femelles     ########################################
   ###################################################################################################################
-  
+  message("Début partie Lignées")
   fondatrices <- cheptel_ecow$fondatrices
-  descendants <- cheptel_ecow$descendants
+  descendants <- add_data_ecow(cheptel_ecow$descendants, cheptel_ecow$nomsparents, czhbc)
 
-  vaches_lignees <- descendants %>% 
+  vaches_lignees <- descendants %>% filter(anim %in% descendants$mereGenetique)
-    filter(anim %in% descendants$mereIpg)
+  produits_lignees <- descendants %>% filter(mereGenetique %in% vaches_lignees$anim)
-  produits_lignees <- add_data_ecow(
+
-    descendants %>% 
+  synth_vaches_lignees <- get_synth_prod_parent(vaches_lignees, produits_lignees, params_ponderation)
-      filter(mereIpg %in% descendants$anim)
+
+  # 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"
     )
-  # 
+  
-  # # TODO quel effet chep ? Comment on l'applique ? 
+  stats_lignees <- stats_prod %>%
-  # 
+    dplyr::left_join(stats_fem_tot,  by = "fondatrice") %>%
-  # synth_vaches_lignees <- get_synth_prod_vaches(vaches_lignees, produits_lignees, params_ponderation, stats_chep)
+    dplyr::left_join(stats_fem_act,  by = "fondatrice") %>%
-  # 
+    dplyr::left_join(stats_renouv,   by = "fondatrice") %>%
-  # # calcul des stats par fondatrice ______________________________________________
+    dplyr::left_join(fondatrices %>% select(anim, nom, dateNaiss, nomCheptelNaiss),  by = c("fondatrice" = "anim")) %>%
-  # 
+    mutate(
-  # stats_prod <- produits_lignees %>%stats_prod <- produits_ligne%
+      pctfem_avecprod =
-  # summarise(
+        round(femtot_nbavecprod / nb_femelles* 100, 1),
-  #   nb_desc_in_chep = n(),
+      pctfemact_avecprod =
-  #   
+        round(femact_nbavecprod / femtot_nbavecprod * 100, 1),
-  #   utilgen = round(mean(ravelamere == 1, na.rm = TRUE) * 100, 1),
+      cheptel = cheptel
-  #   
+    )
-  #   prol = round(
+
-  #     n() / n_distinct(danais, mere) * 100, 1
+  message("Enregistrement données lignées")
-  #   ),
+  save_data_lignees(stats_lignees, cheptel)
-  #   
-  #   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")
 }

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,24 @@ 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)
@@ -92,27 +108,25 @@ format_duration <- function(seconds) {
   sprintf("%02d:%02d:%02d", h, m, s)
 }
 
-save_data_vaches <- function(vaches){
+save_data_vaches <- function(vaches, cheptel){
   tabfinal <- vaches %>%
     select(
-      cheptelDetenteur, anim, nom, nom_pere, embryon, donneuse, porteuse,
+      cheptelDetenteur, anim, nom, nom_pere, embryon, donneuse, porteuse, tempsprod, age_years, ecowcarr, rg_carr, ptgV,
-      tempsprod, age_years, ecowcarr, rg_carr,
+      agevel1, ivv1, ivv2Brut, prol, mort, txrepros, nbpp, txvf, 
-      ptgV, agevel1, ivv1, ivv2Brut,
+      pn_m, pn_f, p120_m, p120_f, p210_m, p210_f, ptgP, moyecowcamp, rg_camp
-      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",
+    "cheptel", "num_vache", "nom_vache", "pere", "isu", "donneuse", "porteuse", "pourc_vie_productive", "age_annees", "note_ecow_carr", "rang_carr", "pointage_vache", 
-    "ivv2plus_j", "prolificite_pourc", "mortalite_av_sevr_pourc", "pourc_produits_repros", "nb_petits_produits", "pourc_velages_tranquilles", "pn_males_kg",
+    "age_1_velage_m", "ivv1_j", "ivv2plus_j", "prolificite_pourc", "mortalite_av_sevr_pourc", "pourc_produits_repros", "nb_petits_produits", "pourc_velages_tranquilles", 
-    "pn_femelles_kg", "p120_males_kg", "p120_femelles_kg", "p210_males_kg", "p210_femelles_kg", "pointage_produits", "moy_notes_ecow_campagne", "rang_campagne"
+    "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"
   )
   
+  nb_lignes_supp <- delete_data_today(cheptel, "VACHES")
+  if (nb_lignes_supp > 0) message("Lignes du jour supprimées dans la table ecowVaches : ", nb_lignes_supp)
+  
   tab_format <- tabfinal %>%
     mutate(
       across(
@@ -139,9 +153,9 @@ save_data_vaches <- function(vaches){
   dbDisconnect(con)
 }
 
-save_data_campagne <- function(synth_camp){
+save_data_campagne <- function(campagnes, cheptel){
   # Stockage des données écow_camp
-  filtered_prod_camp <- synth_camp %>%
+  filtered_prod_camp <- campagnes %>%
     select(
       cheptel, numeroMipg, dateNaiss, rangVelageMipg, ecowcamp, nom_pere, produits
     )
@@ -150,6 +164,9 @@ save_data_campagne <- function(synth_camp){
     "cheptel", "mere_ipg", "danais", "ravelamer_corr", "note_ecow", "pere", "produits"
   )
   
+  nb_lignes_supp <- delete_data_today(cheptel, "CAMPAGNES")
+  if (nb_lignes_supp > 0) message("Lignes du jour supprimées dans la table ecowCampagne : ", nb_lignes_supp)
+  
   con <- get_db_connection()
   
   dbWriteTable(
@@ -162,28 +179,29 @@ save_data_campagne <- function(synth_camp){
   dbDisconnect(con) 
 }
 
-save_data_taureau <- function(data_taureaux, cheptel){
+save_data_taureau <- function(taureaux, cheptel){
   # Stockage des données écow_taureaux
-  filtered_taureaux <- data_taureaux %>%
+  filtered_taureaux <- taureaux %>%
     select(
-      cheptelDetenteur, pereGenetique, nom, dateNaiss, nomCheptelNaiss, nb_prod_in_chep, utilgen, prol, mort, txrepros, nbpp, txvf, pnm, pnf, p120m, p120f, p210m, p210f, 
+      cheptel, 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, 
+      dmsev, dssev, afsev,  fillestot_nbavecprod, pctfilles_avecprod, fillestot_isu, fillestot_age_sort, fillestot_agevel1, fillestot_ivv1, fillestot_ivv2p, 
-      vieprod_fillestot, dmad_fillestot, dsad_fillestot, afad_fillestot, nbprod_fillestot, txrepros_fillestot, nbpp_fillestot, prol_fillestot,
+      fillestot_vieprod, fillestot_dmad, fillestot_dsad, fillestot_afad, fillestot_nbprod, fillestot_txrepros, fillestot_nbpp, fillestot_prol, fillestot_mort, 
-      mort_fillestot, txvf_fillestot, nbfillesact_avecprod, pctfillesact_avecprod, isu_fillesact, age_sort_fillesact, agevel1_fillesact, ivv1_fillesact, 
+      fillestot_txvf, fillesact_nbavecprod, pctfillesact_avecprod, fillesact_isu, fillesact_age_sort, fillesact_agevel1, fillesact_ivv1, fillesact_ivv2p, 
-      ivv2p_fillesact, vieprod_fillesact, dmad_fillesact, dsad_fillesact, afad_fillesact, nbprod_fillesact, txrepros_fillesact, nbpp_fillesact,
+      fillesact_vieprod, fillesact_dmad, fillesact_dsad, fillesact_afad, fillesact_nbprod, fillesact_txrepros, fillesact_nbpp, fillesact_prol, fillesact_mort, 
-      prol_fillesact, mort_fillesact, txvf_fillesact, nbfilles_renouv
+      fillesact_txvf, nbfilles_renouv, fillestot_produits
     )
   
   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", 
+    "vieprod_fillestot", "dmad_fillestot", "dsad_fillestot", "afad_fillestot", "nbprod_fillestot", "txrepros_fillestot", "nbpp_fillestot", "prol_fillestot", "mort_fillestot", 
-    "mort_fillestot", "txvf_fillestot", "nbfillesact_avecprod", "pctfillesact_avecprod", "isu_fillesact", "age_sort_fillesact", "agevel1_fillesact", "ivv1_fillesact", 
+    "txvf_fillestot", "nbfillesact_avecprod", "pctfillesact_avecprod", "isu_fillesact", "age_sort_fillesact", "agevel1_fillesact", "ivv1_fillesact", "ivv2p_fillesact", 
-    "ivv2p_fillesact", "vieprod_fillesact", "dmad_fillesact", "dsad_fillesact", "afad_fillesact", "nbprod_fillesact", "txrepros_fillesact", "nbpp_fillesact", 
+    "vieprod_fillesact", "dmad_fillesact", "dsad_fillesact", "afad_fillesact", "nbprod_fillesact", "txrepros_fillesact", "nbpp_fillesact", "prol_fillesact", "mort_fillesact", 
-    "prol_fillesact", "mort_fillesact", "txvf_fillesact", "nbfilles_renouv"
+    "txvf_fillesact", "nbfilles_renouv", "produits" 
   )
   
-  filtered_taureaux$cheptel <- cheptel
+  nb_lignes_supp <- delete_data_today(cheptel, "TAUREAUX")
+  if (nb_lignes_supp > 0) message("Lignes du jour supprimées dans la table ecowTaureaux : ", nb_lignes_supp)
 
   con <- get_db_connection()
   
@@ -197,15 +215,38 @@ save_data_taureau <- function(data_taureaux, cheptel){
   dbDisconnect(con) 
 }
 
-save_data_lignees <- function(stats_lignees){
+save_data_lignees <- function(lignees, cheptel){
+  filtered_lignees <- 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, pctfem_avecprod, 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, 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, femtot_produits
+    )
+  
+  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", "produits" 
+  )
+  
+  nb_lignes_supp <- delete_data_today(cheptel, "LIGNEES")
+  if (nb_lignes_supp > 0) message("Lignes du jour supprimées dans la table ecowLignees : ", nb_lignes_supp)
+  
   con <- get_db_connection()
   
   dbWriteTable(
     con,
     Id(schema = "hbc", table = "ecow_lignees"),
-    stats_lignees,
+    filtered_lignees,
     append = TRUE,
     row.names = FALSE
   )
   dbDisconnect(con) 
 }
+

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
+  #Ajout d'une colonne avec le nombre de produits IPG (croisement base SIG et SPIE)
-  # Croisement avec les données 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,7 +97,8 @@ get_stats_tbl <- function(tab, nom_tab, cols, conditions = NULL, nom_cond = NA)
   })
 }
 
-get_synth_prod_vaches <- function(vaches, produits, params_ponderation){
+#' 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
   
@@ -183,7 +185,7 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){
         ivv2Brut < 365  ~ 0,
         TRUE         ~ ivv2Brut - 365
       ),
-      days_since_last = as.numeric(difftime(Sys.Date(), last_danais, units = "days")),
+      days_since_last = as.numeric(difftime(if_else(is.na(dateSortDetenteur), Sys.Date(), dateSortDetenteur), last_danais, units = "days")),
       e4 = dplyr::case_when(
         is.na(days_since_last) ~ 0,
         days_since_last < 365  ~ 0,
@@ -191,7 +193,7 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){
       ),
       
       # temps productif (%)
-      age_days = time_length( interval( dateNaiss, Sys.Date() ),  "days" ),
+      age_days = time_length( interval( dateNaiss, if_else(is.na(dateSortDetenteur), Sys.Date(), dateSortDetenteur) ),  "days" ),
       age_years = round(age_days / 365, 1),
       tempsprod = round( (age_days - (agevel1 * 30.4 + e2 + e3 * (nbcampvel - 2) + e4)) / age_days * 100, 1 ),
       
@@ -206,7 +208,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 +220,7 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){
   )
   
   # =========================
-  # 3) Normalisations
+  # Normalisation
   # =========================
   v_norm <- v_ref %>%
     mutate(
@@ -278,7 +282,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)
@@ -311,7 +315,233 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){
     mutate(
       rg_carr = as.integer(rank(1 / ecowcarr, na.last="keep"))
     )
-  
-  list(synthese = v_final, stats_chep = stats_chep)
 }
 
+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')
+  )
+  
+  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){
+  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 dans le cheptel
+#' @param regroupement character. Champs sur lequel on veut faire le regroupement
+#' @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 %>% 
+    group_by({{regroupement}}) %>%
+    summarise(
+      "{prefix}count" := n(),
+      .groups = "drop"
+    ) 
+  
+  if (actif) {
+    df <- df %>% 
+      filter(
+        is.na(dateSortDetenteur),
+        cheptelDetenteur == cheptel # Vérifie pour les descendantes car elles ont pu être vendues
+      )
+  }
+  
+  res <- df %>% 
+    filter(
+      !is.na(n_veaux) # Garde seulement les filles ayant produit dans le cheptel
+    )  %>% 
+    group_by({{regroupement}}) %>%
+    summarise(
+      "{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),
+      "{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(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"
+    )
+  
+  res <- left_join(res, nb, by = rlang::as_name(rlang::ensym(regroupement)))
+}