Mise en place API

R/common/prepare_data.R

@@ -4,44 +4,12 @@ suppressPackageStartupMessages({
   library(tidyr)
 })
 
-#' #' Nettoie une liste d'animaux hbcanim -------------------------------ANCIENNE VERSION
-#' #' @param tab_anims dataframe. Liste d'animaux brute
-#' #' @return Liste d'animaux nettoyée
-#' clean_data_anims<- function(tab_anims, num_cheptel){
-#'   result_data <- tab_anims %>%
-#'     select(numero, chantiersPointage) %>%
-#'     unnest(chantiersPointage, names_sep = "_", keep_empty = TRUE) %>%
-#'     
-#'     # garder le dernier chantier adulte avant d'unnest les codes
-#'     filter(chantiersPointage_typePointage == "Adulte") %>%
-#'     group_by(numero) %>%
-#'     arrange(desc(chantiersPointage_datePointage)) %>%
-#'     slice(1) %>%
-#'     ungroup() %>%
-#'     
-#'     # maintenant seulement on unnest les codes du chantier sélectionné
-#'     unnest(chantiersPointage_pointages, names_sep = "_", keep_empty = TRUE) %>%
-#'     
-#'     pivot_wider(
-#'       names_from = chantiersPointage_pointages_codePointage,
-#'       values_from = chantiersPointage_pointages_notePointage,
-#'       names_glue = "{.name}_adulte"
-#'     ) %>%
-#'     mutate(across(any_of(c("DM_adulte", "DS_adulte", "AF_adulte")), as.numeric))
-#'   
-#'   result <- tab_anims %>%
-#'     left_join(result_data, by = "numero")
-#' }
-
-
 #' Nettoie une liste d'animaux hbcanim
 #' @param tab_anims dataframe. Liste d'animaux brute
 #' @return Liste d'animaux nettoyée
 clean_data_anims<- function(tab_anims){
   result_data <- tab_anims %>%
     mutate(
-      # across(c("dmAdulte", "dsAdulte", "afAdulte", "pat12M", "pat18M", "pat24M",  "rangVelageMipg", "fiabIiv1", "fiabIvv2Corr", "agevel1", "pat120", "pat210",
-      #               "pat120Corrige", "pat210Corrige", "dmSevrage", "dsSevrage", "afSevrage", "nbVelageVeauxDeclares", "nbFinGestation"), as.numeric),
       dateNaiss = as.Date(as.POSIXct(dateNaiss / 1000, origin = "1970-01-01", tz = "UTC")),
       dateSortDetenteur = as.Date(as.POSIXct(dateSortDetenteur / 1000, origin = "1970-01-01", tz = "UTC"))
     ) 

R/common/ws_client.R

@@ -215,10 +215,10 @@ fake <- function(){
 get_parents_ipg <- function(){
   rep_imp <- "/home/lea/Documents/ecow/"
   
-  meresIPG <- read_csv(paste(rep_imp, "nb_prod_IPG_byMERE_20260106.csv", sep='')) # ok 20230327
+  meresIPG <- read_csv(paste(rep_imp, "nb_prod_IPG_byMERE_20260106.csv", sep=''), show_col_types = FALSE)
   colnames(meresIPG) <- c('ANIM','NBPRODIPG')
   
-  peresIPG <- read_csv(paste(rep_imp, "nb_prod_IPG_byPERE_20260106.csv", sep='')) # ok 20230327
+  peresIPG <- read_csv(paste(rep_imp, "nb_prod_IPG_byPERE_20260106.csv", sep=''), show_col_types = FALSE)
   colnames(peresIPG) <- c('ANIM','NBPRODIPG')
   
   parentsIPG <- rbind(meresIPG, peresIPG) 

R/project/ecow_calculations.R

@@ -18,13 +18,10 @@ source(here::here("R/project/preprocessing.R"))
 #' 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) {
-  message("Début fonction calcul_ecow_by_chep pour cheptel : ", cheptel)
   t0 <- Sys.time()
 
-  # Définit un environnement avec tous les paramètres qu'on veut rendre accessibles 
-  env_ecow <- new.env()
   # Récupère les paramètres de pondération
-  env_ecow$params_ponderation <- get_params_ponderation(cheptel)
+  params_ponderation <- get_params_ponderation(cheptel)
   # Récupère la liste des certificats zoo issue de Doli
   czhbc <- data.frame(ANIM = get_cztotaux())
   
@@ -42,7 +39,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
   taureaux <- cheptel_ecow$taureaux
   # Ajout du nom du père
   vaches <- vaches %>%
-    left_join(
+    dplyr::left_join(
       taureaux %>% select(anim, nom_pere = nom),
       by = c("pereGenetique" = "anim")
     )
@@ -56,24 +53,19 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
   
   # Récupère les effets cheptel # TODO A REVOIR AVEC LAURENA
   effets <- get_effets_cheptel(produits_vaches)
-  env_ecow$rapport_MF <- effets$rapport_MF
+  rapport_MF <- effets$rapport_MF
-  env_ecow$effets_chep <- effets$effets_chep
   
-  prod_vaches_corr <- apply_effet_chep(produits_vaches)
+  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 <- env_ecow$params_ponderation$pointage$sevrage
+  pps <- params_ponderation$pointage$sevrage
   
   # Ajout à la table vache des informations synthétisées de leur veaux
-  synth_vaches <- get_synth_prod_vaches(vaches, prod_vaches_corr)
+  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 <- get_stats_tbl(
+  stats_chep <- synth$stats_chep
-    tab = synth_vaches,
-    nom_tab = "vaches",
-    cols = c("agevel1", "ivv1", "ivv2Brut", "prol", "mort", "txrepros", "nbpp_corr", "txvf", "txmales", "ptgP", "pn_corr", "p120_corr", # TODO attention aux champs texte
-              "p210_corr", "pad", "ptgV", "age_years", "tempsprod", "pn_m", "pn_f", "p120_m", "p120_f", "p210_m", "p210_f", "nbpp")
-  )
 
   ####################################     Calcul des notes campagnes       ########################################
   ####### En réalité on travaille sur les rangs de velages, ce qui correspond dans 99% des cas aux campagnes #######
@@ -108,7 +100,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
   
   # Récupère le nom du père
   synth_prod_vache <- synth_prod_vache %>%
-    left_join(
+    dplyr::left_join(
       taureaux %>% select(anim, nom_pere = nom),
       by = c("pere" = "anim")
     )
@@ -121,8 +113,8 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
   
   stats_chep <- rbind(stats_chep, stats_camp)
   
-  pond_camp_fin <- unlist(env_ecow$params_ponderation$campagne$final)
+  pond_camp_fin <- unlist(params_ponderation$campagne$final)
-  pond_camp_ahp <- unlist(env_ecow$params_ponderation$campagne$AHPtech)
+  pond_camp_ahp <- unlist(params_ponderation$campagne$AHPtech)
   
   # ==============================
   # 2. Normalisation complète
@@ -217,7 +209,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
   
   # 3) Fusion + transformations
   v_camp <-synth_vaches %>%
-    left_join(moy_camp, by = c("anim" = "numeroMipg")) %>%
+    dplyr::left_join(moy_camp, by = c("anim" = "numeroMipg")) %>%
     mutate(
       rg_camp = as.integer(rank(1 / moyecowcamp, na.last='keep'))
     )
@@ -254,7 +246,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
   # 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_filles_taureaux <- get_synth_prod_vaches(filles_taureaux, pprod_filles_taureaux)
+  synth_filles_taureaux <- get_synth_prod_vaches(filles_taureaux, pprod_filles_taureaux, params_ponderation, stats_chep)
   
   # Calcul des stats par pere
   
@@ -368,11 +360,11 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
     )
       
   stats_taureaux <- stats_peres %>%
-    left_join(stats_prod_directe,   by = "pereGenetique") %>%
+    dplyr::left_join(stats_prod_directe,   by = "pereGenetique") %>%
-    left_join(stats_filles,         by = "pereGenetique") %>%
+    dplyr::left_join(stats_filles,         by = "pereGenetique") %>%
-    left_join(stats_filles_act,     by = "pereGenetique") %>%
+    dplyr::left_join(stats_filles_act,     by = "pereGenetique") %>%
-    left_join(stats_filles_renouv,  by = "pereGenetique") %>%
+    dplyr::left_join(stats_filles_renouv,  by = "pereGenetique") %>%
-    left_join(taureaux,             by = "pereGenetique")
+    dplyr::left_join(taureaux,             by = "pereGenetique")
   
   save_data_taureau(stats_taureaux, cheptel)
   
@@ -398,7 +390,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
   # 
   # # TODO quel effet chep ? Comment on l'applique ? 
   # 
-  # synth_vaches_lignees <- get_synth_prod_vaches(vaches_lignees, produits_lignees)
+  # synth_vaches_lignees <- get_synth_prod_vaches(vaches_lignees, produits_lignees, params_ponderation, stats_chep)
   # 
   # # calcul des stats par fondatrice ______________________________________________
   # 
@@ -500,9 +492,9 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
   #   summarise(nbfem_renouv = n())
   # 
   # stats_lignees <- stats_prod %>%
-  #   left_join(stats_fem_tot,  by = "fondatrice") %>%
+  #   dplyr::left_join(stats_fem_tot,  by = "fondatrice") %>%
-  #   left_join(stats_fem_act,  by = "fondatrice") %>%
+  #   dplyr::left_join(stats_fem_act,  by = "fondatrice") %>%
-  #   left_join(stats_renouv,   by = "fondatrice") %>%
+  #   dplyr::left_join(stats_renouv,   by = "fondatrice") %>%
   #   mutate(
   #     pctfem_avecprod =
   #       round(nbfem_avecprod / nb_fem_prod * 100, 1),
@@ -512,7 +504,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
   # 
   # stats_lignees_final <- fondatrices %>%
   #   mutate(anim = trim_str(anim)) %>%
-  #   left_join(
+  #   dplyr::left_join(
   #     stats_lignees %>% mutate(fondatrice = trim_str(fondatrice)),
   #     by = c("anim" = "fondatrice")
   #   )

R/project/postprocessing.R

@@ -41,39 +41,55 @@ maj_ecow_for_all <- function() {
 }
 
 mafonctiondetest <- function(cheptel){ 
-  source("R/common/ws_client.R", local = TRUE)
+  source(here::here("R/common/ws_client.R"))
-  server_path <- "http://localhost:8080/HbcSchedulerAndServices/"
+  cheptel_ecow <-  get_cheptel_ecow(cheptel)
-  url_active_by_chep <- paste0(server_path, "webresources/animals/findAnimalEcowByActiveCheptel/")
+  vaches <- cheptel_ecow$vaches
-  maliste <- http_get(url = paste0(url_active_by_chep, cheptel))
+  return(length(vaches))
-  return(lengths(maliste))
 }
 
-cheptels <- list("FR71499477", "FR71499477635", "FR71499477")
-
 #' 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){
-  res <- lapply(cheptels, function(num_chep) {
+  total <- length(list_cheptels)
-    tryCatch(
+  start_time <- Sys.time()
-      {
+  message(sprintf("🚀 Début traitement - %s cheptels à traiter", total))
-        message(sprintf("→ Traitement cheptel %s ...", num_chep))
+  
-        out <- mafonctiondetest(num_chep) #' TODO MAJ avec la fonction de calcul globale
+  res <- lapply(seq_along(list_cheptels), function(i) {
-        #        out <- calcul_ecow_by_chep(num_chep) #' Appel de la fonction de calcul globale
+    num_chep <- list_cheptels[[i]]
-        message(sprintf("✓ OK cheptel %s : %s lignes", num_chep, ifelse(is.data.frame(out), nrow(out), NA_integer_)))
+    withCallingHandlers(
-        out
+      tryCatch(
-      },
+        {
-      error = function(e) {
+          message(sprintf("[%s/%s] Traitement cheptel %s ...", i, total, num_chep))
-        # Log + continue
+          out <- calcul_ecow_by_chep(num_chep, 1) # Pour l'instant on s'arrête aux vaches
-        message(sprintf("✗ ERREUR cheptel %s : %s", num_chep, conditionMessage(e)))
+          message(sprintf("✓ OK cheptel %s", num_chep))
-        NULL
+          out
-      },
+        },
+        error = function(e) {
+          message(sprintf("✗ ERREUR cheptel %s : %s", num_chep, conditionMessage(e)))
+          NULL
+        }
+      ),
       warning = function(w) {
-        # Tu peux décider de logger les warnings sans interrompre
         message(sprintf("! AVERTISSEMENT cheptel %s : %s", num_chep, conditionMessage(w)))
-        invokeRestart("muffleWarning")  # évite d’imprimer plusieurs fois le warning
+        invokeRestart("muffleWarning")
       }
     )
   })
+  
+  end_time <- Sys.time()
+  duration_sec <- round(as.numeric(difftime(end_time, start_time, units = "secs")), 2)
+  duration_fmt <- format_duration(duration_sec)
+  message(sprintf("🏁 Fin traitement - %s cheptels traités en %s",  total, duration_fmt))
+  
+  return(res)
+}
+
+
+format_duration <- function(seconds) {
+  h <- seconds %/% 3600
+  m <- (seconds %% 3600) %/% 60
+  s <- seconds %% 60
+  sprintf("%02d:%02d:%02d", h, m, s)
 }
 
 save_data_vaches <- function(vaches){

R/project/preprocessing.R

@@ -13,7 +13,7 @@ add_data_ecow <- function(liste_produits, czhbc){
 
   #Ajout d'une colonne avec le nombre de produits IPG ------------------ TODO PEUT ETRE PLUS UTILE, à comparer avec nb_fin_gestation
   parents_ipg <- get_parents_ipg()
-  liste_produits <- merge(liste_produits, get_parents_ipg(), by.x='anim', by.y='ANIM', all.x=T, all.y=F)
+  liste_produits <- base::merge(liste_produits, get_parents_ipg(), by.x='anim', by.y='ANIM', all.x=T, all.y=F)
 
   # Calcul REPRO
   liste_produits <- liste_produits %>%
@@ -46,22 +46,22 @@ add_data_ecow <- function(liste_produits, czhbc){
 
 #' Ajoute à un tableau de produits les valeurs corrigées par l'effet cheptel
 #' @param produits dataframe. Tab des produits
-apply_effet_chep <- function(produits){
+apply_effet_chep <- function(produits, effets_chep, rapport_MF){
-  effets <- env_ecow$effets_chep %>%
+  effets <- effets_chep %>%
     select(sexe, typeMipg, diff_pn, diff_p120, diff_p210)
 
   # Associe les bons effets à chaque produit
   produits <- produits %>%
-    left_join(effets, by = c("sexe", "typeMipg")) %>%
+    dplyr::left_join(effets, by = c("sexe", "typeMipg")) %>%
     mutate(
-      nbpp_corr  = if_else(sexe == "2", NBPRODIPG * env_ecow$rapport_MF, NBPRODIPG),
+      nbpp_corr  = if_else(sexe == "2", NBPRODIPG * rapport_MF, NBPRODIPG),
       pn_corr    = if_else(!is.na(poidsNaiss),  poidsNaiss  + diff_pn,    NA_real_)
     )
 }
 
 #' Normalisation des stats cheptel
 #' 1 = max
-norm_chep <- function(x, var) {
+norm_chep <- function(x, var, stats_chep) {
   r <- stats_chep %>% dplyr::filter(var == !!var)
   if (nrow(r) == 0) return(rep(NA_real_, length(x)))
   mmin <- r$min[1]; mmax <- r$max[1]
@@ -95,12 +95,12 @@ get_stats_tbl <- function(tab, nom_tab, cols, conditions = NULL, nom_cond = NA)
   })
 }
 
-get_synth_prod_vaches <- function(vaches, produits){
+get_synth_prod_vaches <- function(vaches, produits, params_ponderation){
   # On récupère les coefficients de pondération pour les pointages adultes 
-  ppa <- env_ecow$params_ponderation$pointage$adulte
+  ppa <- params_ponderation$pointage$adulte
   
   # On récupère les coefficients de pondération pour les pointages au sevrage 
-  pps <- env_ecow$params_ponderation$pointage$sevrage
+  pps <- params_ponderation$pointage$sevrage
   
   # =========================
   # 1) Synthèse veaux par mère
@@ -115,6 +115,7 @@ get_synth_prod_vaches <- function(vaches, produits){
       campn_max = {cn <- campagneNaiss[!is.na(campagneNaiss)]; if (length(cn)) max(cn) else NA_integer_},
       nbcampvel = ifelse(!is.na(campn_min) & !is.na(campn_max),
                          campn_max - campn_min + 1, NA_integer_),
+      #porteuse = summary$embryon,
       
       # date du dernier anais (dernier événement)
       last_danais = {d <- dateNaiss[!is.na(dateNaiss)]; if (length(d)) max(d) else as.Date(NA)},
@@ -152,7 +153,7 @@ get_synth_prod_vaches <- function(vaches, produits){
   # 2) Jointure & calculs vaches
   # =========================
   v_ref <- vaches %>%
-    left_join(veaux_summary, by = c("anim" = "numeroMipg")) %>%
+    dplyr::left_join(veaux_summary, by = c("anim" = "numeroMipg")) %>%
     mutate(
       
       # pointage adulte synthétique
@@ -205,6 +206,14 @@ get_synth_prod_vaches <- function(vaches, produits){
       ~ ifelse(is.nan(.), NA_real_, .)
     ))
   
+  # calcul des stats, valeurs extremes et references pour la normalisation
+  stats_chep <- get_stats_tbl(
+    tab = v_ref,
+    nom_tab = "vaches",
+    cols = c("agevel1", "ivv1", "ivv2Brut", "prol", "mort", "txrepros", "nbpp_corr", "txvf", "txmales", "ptgP", "pn_corr", "p120_corr",
+             "p210_corr", "pad", "ptgV", "age_years", "tempsprod", "pn_m", "pn_f", "p120_m", "p120_f", "p210_m", "p210_f", "nbpp")
+  )
+  
   # =========================
   # 3) Normalisations
   # =========================
@@ -236,15 +245,15 @@ get_synth_prod_vaches <- function(vaches, produits){
         TRUE ~ round(1 - abs(365 - ivv2Brut) / abs(365 - 435), 3)
       ),
       # normalisations "cheptel 1 = max"
-      pad_n        = round(norm_chep(pad,        "vaches$pad"),        3),
+      pad_n        = round(norm_chep(pad,        "vaches$pad", stats_chep),        3),
-      ptgv_n       = round(norm_chep(ptgV,       "vaches$ptgV"),       3),
+      ptgv_n       = round(norm_chep(ptgV,       "vaches$ptgV", stats_chep),       3),
-      txvf_n       = round(norm_chep(txvf,       "vaches$txvf"),       3),
+      txvf_n       = round(norm_chep(txvf,       "vaches$txvf", stats_chep),       3),
-      txm_n        = round(norm_chep(txmales,    "vaches$txmales"),    3),
+      txm_n        = round(norm_chep(txmales,    "vaches$txmales", stats_chep),    3),
-      txrepros_n   = round(norm_chep(txrepros,   "vaches$txrepros"),   3),
+      txrepros_n   = round(norm_chep(txrepros,   "vaches$txrepros", stats_chep),   3),
-      nbpp_n       = round(norm_chep(nbpp_corr,  "vaches$nbpp_corr"),  3),
+      nbpp_n       = round(norm_chep(nbpp_corr,  "vaches$nbpp_corr", stats_chep),  3),
-      ptgp_n       = round(norm_chep(ptgP,       "vaches$ptgP"),       3),
+      ptgp_n       = round(norm_chep(ptgP,       "vaches$ptgP", stats_chep),       3),
-      p120_n       = round(norm_chep(p120_corr,  "vaches$p120_corr"),  3),
+      p120_n       = round(norm_chep(p120_corr,  "vaches$p120_corr", stats_chep),  3),
-      p210_n       = round(norm_chep(p210_corr,  "vaches$p210_corr"),  3),
+      p210_n       = round(norm_chep(p210_corr,  "vaches$p210_corr", stats_chep),  3),
       
       # prolificité
       prol_n = dplyr::case_when(
@@ -271,7 +280,7 @@ get_synth_prod_vaches <- function(vaches, produits){
   # 4) 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(env_ecow$params_ponderation$carriere, 1)
+  weights <- purrr::map_dbl(params_ponderation$carriere, 1)
   
   v_final <- v_norm %>%
     rowwise() %>%
@@ -301,5 +310,7 @@ get_synth_prod_vaches <- function(vaches, produits){
     mutate(
       rg_carr = as.integer(rank(1 / ecowcarr, na.last="keep"))
     )
+  
+  list(synthese = v_final, stats_chep = stats_chep)
 }