lea/RProjects
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Mise en place API

Browse Source
This commit is contained in:
Léa
2026-06-11 10:23:33 +02:00
parent da46965f95
commit 699d976c80
5 changed files with 95 additions and 108 deletions
Download Patch File Download Diff File Expand all files Collapse all files
R/project/ecow_calculations.R
+23 -31
View File
@@ -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")
# )
R/project/postprocessing.R
+39 -23
View File
@@ -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){
R/project/preprocessing.R
+31 -20
View File
@@ -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)
}