From 699d976c8095bee358c86df32939b507911c1875 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9a?= Date: Thu, 11 Jun 2026 10:23:33 +0200 Subject: [PATCH] Mise en place API --- R/common/prepare_data.R | 32 ------------------ R/common/ws_client.R | 4 +-- R/project/ecow_calculations.R | 54 +++++++++++++----------------- R/project/postprocessing.R | 62 ++++++++++++++++++++++------------- R/project/preprocessing.R | 51 +++++++++++++++++----------- 5 files changed, 95 insertions(+), 108 deletions(-) diff --git a/R/common/prepare_data.R b/R/common/prepare_data.R index 442ea63..1a89e5b 100755 --- a/R/common/prepare_data.R +++ b/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")) ) diff --git a/R/common/ws_client.R b/R/common/ws_client.R index 33e8fd7..07ac501 100755 --- a/R/common/ws_client.R +++ b/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) diff --git a/R/project/ecow_calculations.R b/R/project/ecow_calculations.R index ac841bf..16c485c 100755 --- a/R/project/ecow_calculations.R +++ b/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 - env_ecow$effets_chep <- effets$effets_chep + rapport_MF <- effets$rapport_MF - 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( - 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") - ) + 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 ####### @@ -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_ahp <- unlist(env_ecow$params_ponderation$campagne$AHPtech) + pond_camp_fin <- unlist(params_ponderation$campagne$final) + 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") %>% - left_join(stats_filles, by = "pereGenetique") %>% - left_join(stats_filles_act, by = "pereGenetique") %>% - left_join(stats_filles_renouv, by = "pereGenetique") %>% - left_join(taureaux, by = "pereGenetique") + 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") 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") %>% - # left_join(stats_fem_act, by = "fondatrice") %>% - # left_join(stats_renouv, by = "fondatrice") %>% + # 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), @@ -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") # ) diff --git a/R/project/postprocessing.R b/R/project/postprocessing.R index cf06bc0..a831b19 100755 --- a/R/project/postprocessing.R +++ b/R/project/postprocessing.R @@ -41,39 +41,55 @@ maj_ecow_for_all <- function() { } mafonctiondetest <- function(cheptel){ - source("R/common/ws_client.R", local = TRUE) - server_path <- "http://localhost:8080/HbcSchedulerAndServices/" - url_active_by_chep <- paste0(server_path, "webresources/animals/findAnimalEcowByActiveCheptel/") - maliste <- http_get(url = paste0(url_active_by_chep, cheptel)) - return(lengths(maliste)) + source(here::here("R/common/ws_client.R")) + cheptel_ecow <- get_cheptel_ecow(cheptel) + vaches <- cheptel_ecow$vaches + return(length(vaches)) } -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) { - tryCatch( - { - message(sprintf("→ Traitement cheptel %s ...", num_chep)) - out <- mafonctiondetest(num_chep) #' TODO MAJ avec la fonction de calcul globale - # out <- calcul_ecow_by_chep(num_chep) #' Appel de la fonction de calcul globale - message(sprintf("✓ OK cheptel %s : %s lignes", num_chep, ifelse(is.data.frame(out), nrow(out), NA_integer_))) - out - }, - error = function(e) { - # Log + continue - message(sprintf("✗ ERREUR cheptel %s : %s", num_chep, conditionMessage(e))) - NULL - }, + total <- length(list_cheptels) + start_time <- Sys.time() + message(sprintf("🚀 Début traitement - %s cheptels à traiter", total)) + + res <- lapply(seq_along(list_cheptels), function(i) { + num_chep <- list_cheptels[[i]] + withCallingHandlers( + 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 + message(sprintf("✓ OK cheptel %s", num_chep)) + 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){ diff --git a/R/project/preprocessing.R b/R/project/preprocessing.R index 6c89eff..646baff 100755 --- a/R/project/preprocessing.R +++ b/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){ - effets <- env_ecow$effets_chep %>% +apply_effet_chep <- function(produits, effets_chep, rapport_MF){ + 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), - ptgv_n = round(norm_chep(ptgV, "vaches$ptgV"), 3), - txvf_n = round(norm_chep(txvf, "vaches$txvf"), 3), - txm_n = round(norm_chep(txmales, "vaches$txmales"), 3), - txrepros_n = round(norm_chep(txrepros, "vaches$txrepros"), 3), - nbpp_n = round(norm_chep(nbpp_corr, "vaches$nbpp_corr"), 3), - ptgp_n = round(norm_chep(ptgP, "vaches$ptgP"), 3), - p120_n = round(norm_chep(p120_corr, "vaches$p120_corr"), 3), - p210_n = round(norm_chep(p210_corr, "vaches$p210_corr"), 3), + pad_n = round(norm_chep(pad, "vaches$pad", stats_chep), 3), + ptgv_n = round(norm_chep(ptgV, "vaches$ptgV", stats_chep), 3), + txvf_n = round(norm_chep(txvf, "vaches$txvf", stats_chep), 3), + txm_n = round(norm_chep(txmales, "vaches$txmales", stats_chep), 3), + txrepros_n = round(norm_chep(txrepros, "vaches$txrepros", stats_chep), 3), + nbpp_n = round(norm_chep(nbpp_corr, "vaches$nbpp_corr", stats_chep), 3), + ptgp_n = round(norm_chep(ptgP, "vaches$ptgP", stats_chep), 3), + p120_n = round(norm_chep(p120_corr, "vaches$p120_corr", stats_chep), 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) }