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/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)
}