Mise en place projet R
This commit is contained in:
Executable
+7
@@ -0,0 +1,7 @@
|
||||
# fichier à supprimer, fonction test pour mise en place de l'api
|
||||
ma_fonction <- function() {
|
||||
list(
|
||||
status = "youhou",
|
||||
time = Sys.time()
|
||||
)
|
||||
}
|
||||
Executable
+523
@@ -0,0 +1,523 @@
|
||||
suppressPackageStartupMessages({
|
||||
library(roxygen2)
|
||||
library(dplyr)
|
||||
library(lubridate)
|
||||
library(purrr)
|
||||
library(stringr)
|
||||
library(DBI)
|
||||
library(RPostgres)
|
||||
library(here)
|
||||
library(httr)
|
||||
library(jsonlite)
|
||||
})
|
||||
source(here::here("R/common/ws_client.R"))
|
||||
source(here::here("R/project/preprocessing.R"))
|
||||
|
||||
#' Fonction globale de mise à jour des indicateurs eCow pour vaches, taureaux et lignées
|
||||
#' Stockage des données directement en base
|
||||
#' 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")
|
||||
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)
|
||||
# Récupère la liste des certificats zoo issue de Doli
|
||||
czhbc <- data.frame(ANIM = get_cztotaux())
|
||||
|
||||
message("Début import des données")
|
||||
cheptel_ecow <- get_cheptel_ecow(cheptel)
|
||||
|
||||
###################################################################################################################
|
||||
#################################### Calcul ecow pour les vaches ########################################
|
||||
###################################################################################################################
|
||||
message("Début partie vaches")
|
||||
# Vaches actives ayant déjà eu une fin de gestation
|
||||
vaches <- cheptel_ecow$vaches
|
||||
|
||||
# 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
|
||||
vaches <- vaches %>%
|
||||
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)
|
||||
|
||||
# Récupère les produits des vaches actives du cheptel et les embryons portés dans le cheptel
|
||||
produits_vaches <- produits_cheptel %>%
|
||||
filter(numeroMipg %in% vaches$anim)
|
||||
|
||||
# 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
|
||||
|
||||
prod_vaches_corr <- apply_effet_chep(produits_vaches)
|
||||
|
||||
# On récupère les coefficients de pondération pour les pointages au sevrage
|
||||
pps <- env_ecow$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)
|
||||
|
||||
# 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")
|
||||
)
|
||||
|
||||
#################################### Calcul des notes campagnes ########################################
|
||||
####### En réalité on travaille sur les rangs de velages, ce qui correspond dans 99% des cas aux campagnes #######
|
||||
|
||||
# ==============================
|
||||
# 1. Aggrégation campagnes
|
||||
# ==============================
|
||||
synth_prod_vache <- prod_vaches_corr %>%
|
||||
group_by(numeroMipg, dateNaiss, rangVelageMipg) %>%
|
||||
summarise(
|
||||
ivv = first(ivv1), # ------------------------------------------------------------------------- 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
|
||||
produits = list(
|
||||
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 %>%
|
||||
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(env_ecow$params_ponderation$campagne$final)
|
||||
pond_camp_ahp <- unlist(env_ecow$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
|
||||
v_camp <-synth_vaches %>%
|
||||
left_join(moy_camp, by = c("anim" = "numeroMipg")) %>%
|
||||
mutate(
|
||||
rg_camp = as.integer(rank(1 / moyecowcamp, na.last='keep'))
|
||||
)
|
||||
|
||||
message("Enregistrement données vaches")
|
||||
|
||||
# Enregistrement des données des vaches en base
|
||||
save_data_vaches(v_camp)
|
||||
|
||||
# Enregistrement des données de campagne en base
|
||||
save_data_campagne(synth_prod_vache_n)
|
||||
|
||||
if (step == 1) {
|
||||
t1 <- Sys.time()
|
||||
message("Fin du traitement. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec")
|
||||
return(invisible(NULL))
|
||||
}
|
||||
|
||||
###################################################################################################################
|
||||
#################################### Calcul ecow pour les taureaux ########################################
|
||||
###################################################################################################################
|
||||
message("Début partie taureaux")
|
||||
# Recupère les produits des taureaux
|
||||
produits_taureaux <- produits_cheptel %>%
|
||||
filter(pereGenetique %in% taureaux$anim & embryon != 'O')
|
||||
|
||||
# Récupères les filles des taureaux
|
||||
filles_taureaux <- produits_taureaux %>%
|
||||
filter(sexe == 2)
|
||||
|
||||
# Petits produits issus des filles des taureaux
|
||||
pprod_filles_taureaux <- add_data_ecow(cheptel_ecow$petits_produits, czhbc)
|
||||
|
||||
# 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)
|
||||
|
||||
# Calcul des stats par pere
|
||||
|
||||
stats_peres <- produits_taureaux %>%
|
||||
group_by(pereGenetique) %>%
|
||||
summarise(
|
||||
nb_prod_in_chep = n(),
|
||||
.groups = "drop"
|
||||
) %>%
|
||||
filter(nb_prod_in_chep >= 5)
|
||||
|
||||
stats_prod_directe <- produits_taureaux %>%
|
||||
group_by(pereGenetique) %>%
|
||||
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(
|
||||
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), # TODO -------- a voir avec Lauréna, pq dm pour mal et ds pour femelle ? Faut-il ajouter af ?
|
||||
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 %>%
|
||||
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 = ifelse(n() >= 3, round(mean(embryon, na.rm = TRUE), 1), NA),
|
||||
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(
|
||||
sexe == "2",
|
||||
NBPRODIPG == 0
|
||||
) %>%
|
||||
group_by(pereGenetique) %>%
|
||||
summarise(
|
||||
nbfilles_renouv = n(),
|
||||
.groups = "drop"
|
||||
)
|
||||
|
||||
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")
|
||||
|
||||
save_data_taureau(stats_taureaux, cheptel)
|
||||
|
||||
if (step == 2) {
|
||||
t1 <- Sys.time()
|
||||
message("Fin du traitement. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec")
|
||||
return(invisible(NULL))
|
||||
}
|
||||
|
||||
###################################################################################################################
|
||||
#################################### Remontee des lignees femelles ########################################
|
||||
###################################################################################################################
|
||||
|
||||
fondatrices <- cheptel_ecow$fondatrices
|
||||
descendants <- cheptel_ecow$descendants
|
||||
|
||||
vaches_lignees <- descendants %>%
|
||||
filter(anim %in% descendants$mereIpg)
|
||||
produits_lignees <- add_data_ecow(
|
||||
descendants %>%
|
||||
filter(mereIpg %in% descendants$anim)
|
||||
)
|
||||
#
|
||||
# # TODO quel effet chep ? Comment on l'applique ?
|
||||
#
|
||||
# synth_vaches_lignees <- get_synth_prod_vaches(vaches_lignees, produits_lignees)
|
||||
#
|
||||
# # calcul des stats par fondatrice ______________________________________________
|
||||
#
|
||||
# stats_prod <- produits_lignees %>%stats_prod <- produits_ligne%
|
||||
# summarise(
|
||||
# nb_desc_in_chep = n(),
|
||||
#
|
||||
# utilgen = round(mean(ravelamere == 1, na.rm = TRUE) * 100, 1),
|
||||
#
|
||||
# prol = round(
|
||||
# n() / n_distinct(danais, mere) * 100, 1
|
||||
# ),
|
||||
#
|
||||
# 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 %>%
|
||||
# left_join(stats_fem_tot, by = "fondatrice") %>%
|
||||
# left_join(stats_fem_act, by = "fondatrice") %>%
|
||||
# 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)) %>%
|
||||
# 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")
|
||||
}
|
||||
Executable
+3746
File diff suppressed because it is too large
Load Diff
Executable
+3705
File diff suppressed because it is too large
Load Diff
Executable
+3436
File diff suppressed because it is too large
Load Diff
Executable
+195
@@ -0,0 +1,195 @@
|
||||
source(here::here("R/common/db_client.R"))
|
||||
|
||||
save_or_return <- function(results, write_to_db = FALSE) {
|
||||
if (isTRUE(write_to_db)) {
|
||||
df <- as.data.frame(results, optional = TRUE)
|
||||
status <- insert_results(df)
|
||||
return(status)
|
||||
}
|
||||
results
|
||||
}
|
||||
|
||||
#' TODO voir ce qu'on retourne -> surement tableau de résultats, stockage en base géré dans une autre fonction
|
||||
#' Met à jour les données éCow pour un cheptel
|
||||
#' @param cheptel character. Code du cheptel avec le FR
|
||||
#' @return A définir
|
||||
maj_ecow_by_cheptel <- function(cheptel) {
|
||||
list_chep <-list(cheptel)
|
||||
|
||||
maj_ecow_for_list_cheptels(list_chep)
|
||||
}
|
||||
|
||||
#' Met à jour les données éCow pour tous les cheptels suivis par un technicien
|
||||
#' @param tech character. Identifiant à 5 lettres du technicien
|
||||
maj_ecow_by_tech <- function(tech) {
|
||||
# On récupère tous les cheptels d'un technicien
|
||||
cheps_tech <- get_cheptels_by_tech(tech)
|
||||
# On en extrait la liste des numéros de cheptels suivi par le tech
|
||||
list_chep <- as.list(cheps_tech$numeroCheptel)
|
||||
|
||||
maj_ecow_for_list_cheptels(list_chep)
|
||||
}
|
||||
|
||||
#' Met à jour les données éCow pour tous les cheptels des adhérents actifs
|
||||
maj_ecow_for_all <- function() {
|
||||
# On récupère tous les adhérents dans Dolibarr
|
||||
adh_hbc <- get_all_adherents_active()
|
||||
# On en extrait la liste des numéros de cheptels
|
||||
list_chep <- as.list(adh_hbc$Numchep)
|
||||
|
||||
maj_ecow_for_list_cheptels(list_chep)
|
||||
}
|
||||
|
||||
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))
|
||||
}
|
||||
|
||||
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
|
||||
},
|
||||
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
|
||||
}
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
save_data_vaches <- function(vaches){
|
||||
tabfinal <- vaches %>%
|
||||
select(
|
||||
cheptelDetenteur, anim, nom, nom_pere, embryon,
|
||||
tempsprod, age_years, ecowcarr, rg_carr,
|
||||
ptgV, agevel1, ivv1, ivv2Brut,
|
||||
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", "pourc_vie_productive", "age_annees", "note_ecow_carr", "rang_carr", "pointage_vache", "age_1_velage_m", "ivv1_j",
|
||||
"ivv2plus_j", "prolificite_pourc", "mortalite_av_sevr_pourc", "pourc_produits_repros", "nb_petits_produits", "pourc_velages_tranquilles", "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"
|
||||
)
|
||||
|
||||
tab_format <- tabfinal %>%
|
||||
mutate(
|
||||
across(
|
||||
where(is.character),
|
||||
~ str_replace_all(.x, ",", ".")
|
||||
),
|
||||
isu = case_when(
|
||||
isu == "O" ~ TRUE,
|
||||
isu == "N" ~ FALSE,
|
||||
TRUE ~ NA
|
||||
),
|
||||
rang_carr = as.numeric(rang_carr)
|
||||
)
|
||||
|
||||
con <- get_db_connection()
|
||||
|
||||
dbWriteTable(
|
||||
con,
|
||||
Id(schema = "hbc", table = "ecow_vaches"),
|
||||
tab_format,
|
||||
append = TRUE,
|
||||
row.names = FALSE
|
||||
)
|
||||
dbDisconnect(con)
|
||||
}
|
||||
|
||||
save_data_campagne <- function(synth_camp){
|
||||
# Stockage des données écow_camp
|
||||
filtered_prod_camp <- synth_camp %>%
|
||||
select(
|
||||
cheptel, numeroMipg, dateNaiss, rangVelageMipg, ecowcamp, nom_pere, produits
|
||||
)
|
||||
|
||||
colnames(filtered_prod_camp) <- c(
|
||||
"cheptel", "mere_ipg", "danais", "ravelamer_corr", "note_ecow", "pere", "produits"
|
||||
)
|
||||
|
||||
con <- get_db_connection()
|
||||
|
||||
dbWriteTable(
|
||||
con,
|
||||
Id(schema = "hbc", table = "ecow_campagne"),
|
||||
filtered_prod_camp,
|
||||
append = TRUE,
|
||||
row.names = FALSE
|
||||
)
|
||||
dbDisconnect(con)
|
||||
}
|
||||
|
||||
save_data_taureau <- function(data_taureaux, cheptel){
|
||||
# Stockage des données écow_taureaux
|
||||
filtered_taureaux <- data_taureaux %>%
|
||||
select(
|
||||
cheptelDetenteur, pereGenetique, 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,
|
||||
mort_fillestot, txvf_fillestot, nbfillesact_avecprod, pctfillesact_avecprod, isu_fillesact, age_sort_fillesact, agevel1_fillesact, ivv1_fillesact,
|
||||
ivv2p_fillesact, vieprod_fillesact, dmad_fillesact, dsad_fillesact, afad_fillesact, nbprod_fillesact, txrepros_fillesact, nbpp_fillesact,
|
||||
prol_fillesact, mort_fillesact, txvf_fillesact, nbfilles_renouv
|
||||
)
|
||||
|
||||
colnames(filtered_taureaux) <- c(
|
||||
"cheptel", "anim", "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",
|
||||
"mort_fillestot", "txvf_fillestot", "nbfillesact_avecprod", "pctfillesact_avecprod", "isu_fillesact", "age_sort_fillesact", "agevel1_fillesact", "ivv1_fillesact",
|
||||
"ivv2p_fillesact", "vieprod_fillesact", "dmad_fillesact", "dsad_fillesact", "afad_fillesact", "nbprod_fillesact", "txrepros_fillesact", "nbpp_fillesact",
|
||||
"prol_fillesact", "mort_fillesact", "txvf_fillesact", "nbfilles_renouv"
|
||||
)
|
||||
|
||||
filtered_taureaux$cheptel <- cheptel
|
||||
|
||||
con <- get_db_connection()
|
||||
|
||||
dbWriteTable(
|
||||
con,
|
||||
Id(schema = "hbc", table = "ecow_taureaux"),
|
||||
filtered_taureaux,
|
||||
append = TRUE,
|
||||
row.names = FALSE
|
||||
)
|
||||
dbDisconnect(con)
|
||||
}
|
||||
|
||||
save_data_lignees(stats_lignees){
|
||||
con <- get_db_connection()
|
||||
|
||||
dbWriteTable(
|
||||
con,
|
||||
Id(schema = "hbc", table = "ecow_lignees"),
|
||||
stats_lignees,
|
||||
append = TRUE,
|
||||
row.names = FALSE
|
||||
)
|
||||
dbDisconnect(con)
|
||||
}
|
||||
Executable
+305
@@ -0,0 +1,305 @@
|
||||
suppressPackageStartupMessages({
|
||||
library(tibble)
|
||||
library(dplyr)
|
||||
library(rlang)
|
||||
library(purrr)
|
||||
})
|
||||
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){
|
||||
|
||||
#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)
|
||||
|
||||
# Calcul REPRO
|
||||
liste_produits <- liste_produits %>%
|
||||
mutate(
|
||||
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_
|
||||
)
|
||||
) %>%
|
||||
# Calcul MORTALITÉ
|
||||
mutate(
|
||||
age_jours = as.numeric(difftime(dateSortDetenteur, dateNaiss, units = "days")),
|
||||
mortnat = if_else(
|
||||
!is.na(causeSortDetenteur) & causeSortDetenteur == "M" &
|
||||
!is.na(age_jours) & age_jours < 3,
|
||||
"O",
|
||||
NA_character_
|
||||
),
|
||||
mortsev = if_else(
|
||||
!is.na(causeSortDetenteur) & causeSortDetenteur == "M" &
|
||||
!is.na(age_jours) & age_jours >= 3 & age_jours < 211,
|
||||
"O",
|
||||
NA_character_
|
||||
),
|
||||
) %>%
|
||||
select(-age_jours) # colonne intermédiaire à retirer si inutile
|
||||
}
|
||||
|
||||
#' 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 %>%
|
||||
select(sexe, typeMipg, diff_pn, diff_p120, diff_p210)
|
||||
|
||||
# Associe les bons effets à chaque produit
|
||||
produits <- produits %>%
|
||||
left_join(effets, by = c("sexe", "typeMipg")) %>%
|
||||
mutate(
|
||||
nbpp_corr = if_else(sexe == "2", NBPRODIPG * env_ecow$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) {
|
||||
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]
|
||||
1 - (abs(mmax - x) / abs(mmax - mmin))
|
||||
}
|
||||
|
||||
#' Calcul des statistiques pour les colonnes d'un tableau
|
||||
get_stats_tbl <- function(tab, nom_tab, cols, conditions = NULL, nom_cond = NA) {
|
||||
|
||||
# Si conditions présentes → filtrer
|
||||
if (!is.null(conditions)) {
|
||||
tab <- tab %>% filter(!! enquo(conditions))
|
||||
}
|
||||
|
||||
# Pour chaque colonne → calculer les stats
|
||||
map_df(cols, function(col) {
|
||||
x <- tab[[col]]
|
||||
|
||||
tibble(
|
||||
var = paste0(nom_tab, "$", col),
|
||||
cond = nom_cond,
|
||||
min = round(min(as.numeric(x), na.rm = TRUE), 1),
|
||||
q1 = round(quantile(as.numeric(x), 0.25, na.rm = TRUE), 1),
|
||||
med = round(median(as.numeric(x), na.rm = TRUE), 1),
|
||||
moy = round(mean(as.numeric(x), na.rm = TRUE), 1),
|
||||
q3 = round(quantile(as.numeric(x), 0.75, na.rm = TRUE), 1),
|
||||
max = round(max(as.numeric(x), na.rm = TRUE), 1),
|
||||
nbval = sum(!is.na(as.numeric(x))),
|
||||
nas = sum(is.na(as.numeric(x)))
|
||||
)
|
||||
})
|
||||
}
|
||||
|
||||
get_synth_prod_vaches <- function(vaches, produits){
|
||||
# On récupère les coefficients de pondération pour les pointages adultes
|
||||
ppa <- env_ecow$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
|
||||
|
||||
# =========================
|
||||
# 1) Synthèse veaux par mère
|
||||
# =========================
|
||||
veaux_summary <- produits %>%
|
||||
group_by(numeroMipg) %>%
|
||||
summarise(
|
||||
n_veaux = n(),
|
||||
|
||||
# plage de campagnes velages (max - min + 1), robustes aux NA
|
||||
campn_min = {cn <- campagneNaiss[!is.na(campagneNaiss)]; if (length(cn)) min(cn) else NA_integer_},
|
||||
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_),
|
||||
|
||||
# date du dernier anais (dernier événement)
|
||||
last_danais = {d <- dateNaiss[!is.na(dateNaiss)]; if (length(d)) max(d) else as.Date(NA)},
|
||||
|
||||
# moyennes nécessaires pour ptgP et précocité
|
||||
mean_devmus = mean(dmSevrage, na.rm = TRUE),
|
||||
mean_devsqe = mean(dsSevrage, na.rm = TRUE),
|
||||
mean_af = mean(afSevrage, na.rm = TRUE),
|
||||
mean_diff_dev = mean(dsSevrage - dmSevrage, na.rm = TRUE),
|
||||
|
||||
# indicateurs produits
|
||||
mort = round((sum(mortsev == "O" | mortnat == "O", na.rm = TRUE)) / n_veaux * 100, 1),
|
||||
txrepros = round(sum(repro == "O", na.rm = TRUE) / n_veaux * 100, 1),
|
||||
nbpp = sum(NBPRODIPG, na.rm = TRUE),
|
||||
nbpp_corr = if ("nbpp_corr" %in% names(.)) sum(nbpp_corr, na.rm = TRUE) else NA_real_,
|
||||
txmales = round(sum(sexe == "1", na.rm = TRUE) / n_veaux * 100, 1),
|
||||
txvf = round(sum(conditionNaiss %in% c("1","2"), na.rm = TRUE) / n_veaux * 100, 1),
|
||||
|
||||
# moyennes par sexe
|
||||
pn_m = round(mean(poidsNaiss[sexe == "1"], na.rm = TRUE), 1),
|
||||
p120_m = round(mean(pat120[sexe == "1"], na.rm = TRUE), 1),
|
||||
p210_m = round(mean(pat210[sexe == "1"], na.rm = TRUE), 1),
|
||||
pn_f = round(mean(poidsNaiss[sexe == "2"], na.rm = TRUE), 1),
|
||||
p120_f = round(mean(pat120[sexe == "2"], na.rm = TRUE), 1),
|
||||
p210_f = round(mean(pat210[sexe == "2"], na.rm = TRUE), 1),
|
||||
|
||||
# versions corrigées
|
||||
pn_corr = if ("pn_corr" %in% names(.)) round(mean(pn_corr, na.rm = TRUE), 1) else NA_real_,
|
||||
p120_corr = round(mean(pat120Corrige, na.rm = TRUE), 1),
|
||||
p210_corr = round(mean(pat210Corrige, na.rm = TRUE), 1),
|
||||
.groups = "drop"
|
||||
)
|
||||
|
||||
# =========================
|
||||
# 2) Jointure & calculs vaches
|
||||
# =========================
|
||||
v_ref <- vaches %>%
|
||||
left_join(veaux_summary, by = c("anim" = "numeroMipg")) %>%
|
||||
mutate(
|
||||
|
||||
# pointage adulte synthétique
|
||||
ptgV = ifelse(!is.na(dmcAdulte), round(ppa$dmC * dmcAdulte + ppa$ds * dsAdulte + ppa$af * afAdulte, 1), NA_real_),
|
||||
|
||||
# précocité & alpha
|
||||
precocite = ifelse(!is.na(n_veaux) & n_veaux > 3, round(mean_diff_dev, 2), NA_real_), # TODO à voir pour changer la formule de précocité avec LJ
|
||||
alpha = ifelse(is.na(precocite), 1.62, 1.62 - 0.01 * precocite), # TODO A MAJ
|
||||
|
||||
# estimation du poids adulte (pad)
|
||||
pad = dplyr::case_when( # TODO rajouter paramètre cohérence des données, créer max et min
|
||||
!is.na(pat24M) ~ round((pat24M - 50 * exp(-720 * alpha * 10^(-3))) / (1 - exp(-720 * alpha * 10^(-3))), 1),
|
||||
!is.na(pat18M) ~ round((pat18M - 50 * exp(-540 * alpha * 10^(-3))) / (1 - exp(-540 * alpha * 10^(-3))), 1),
|
||||
!is.na(pat12M) ~ round((pat12M - 50 * exp(-360 * alpha * 10^(-3))) / (1 - exp(-360 * alpha * 10^(-3))), 1),
|
||||
TRUE ~ NA_real_
|
||||
),
|
||||
|
||||
# temps improductif (e2, e3, e4)
|
||||
e2 = dplyr::case_when(
|
||||
is.na(ivv1) ~ 0,
|
||||
ivv1 < 390 ~ 0,
|
||||
TRUE ~ ivv1 - 390
|
||||
),
|
||||
e3 = dplyr::case_when(
|
||||
is.na(ivv2Brut) ~ 0, # TODO voir avec Lauréna si on prend ajust ou brut
|
||||
ivv2Brut < 365 ~ 0,
|
||||
TRUE ~ ivv2Brut - 365
|
||||
),
|
||||
days_since_last = as.numeric(difftime(Sys.Date(), last_danais, units = "days")),
|
||||
e4 = dplyr::case_when(
|
||||
is.na(days_since_last) ~ 0,
|
||||
days_since_last < 365 ~ 0,
|
||||
TRUE ~ days_since_last - 365
|
||||
),
|
||||
|
||||
# temps productif (%)
|
||||
age_days = time_length( interval( dateNaiss, Sys.Date() ), "days" ),
|
||||
age_years = round(age_days / 365, 1),
|
||||
tempsprod = round( (age_days - (agevel1 * 30.4 + e2 + e3 * (nbcampvel - 2) + e4)) / age_days * 100, 1 ),
|
||||
|
||||
# prolificité
|
||||
prol = round(n_veaux / nbcampvel * 100, 1),
|
||||
|
||||
# pointage produits
|
||||
ptgP = round(pps$devmus * mean_devmus + pps$devsqe * mean_devsqe + pps$af * mean_af, 1)
|
||||
) %>%
|
||||
# Conversion des NaN en NA sur certaines moyennes
|
||||
mutate(across(
|
||||
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_, .)
|
||||
))
|
||||
|
||||
# =========================
|
||||
# 3) Normalisations
|
||||
# =========================
|
||||
v_norm <- v_ref %>%
|
||||
mutate(
|
||||
# age au 1er vêlage normalisé
|
||||
agevel1_n = dplyr::case_when(
|
||||
is.na(agevel1) ~ NA_real_,
|
||||
agevel1 > 48 ~ 0,
|
||||
TRUE ~ round(
|
||||
-2 * (10^(-6)) * (agevel1 * 30.4)^2 +
|
||||
0.0027 * (agevel1 * 30.4) +
|
||||
8 * (10^(-15)),
|
||||
3
|
||||
)
|
||||
),
|
||||
# ivv1 normalisé
|
||||
ivv1_n = dplyr::case_when(
|
||||
is.na(ivv1) ~ NA_real_,
|
||||
ivv1 > 460 ~ 0,
|
||||
ivv1 < 390 ~ 1,
|
||||
TRUE ~ round(1 - abs(390 - ivv1) / abs(390 - 460), 3)
|
||||
),
|
||||
# ivv2+ normalisé
|
||||
ivv2p_n = dplyr::case_when(
|
||||
is.na(ivv2Brut) | is.nan(ivv2Brut) ~ NA_real_,
|
||||
ivv2Brut > 435 ~ 0,
|
||||
ivv2Brut < 365 ~ 1,
|
||||
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),
|
||||
|
||||
# prolificité
|
||||
prol_n = dplyr::case_when(
|
||||
is.na(prol) ~ NA_real_,
|
||||
prol >= 100 ~ 1,
|
||||
prol < 50 ~ 0,
|
||||
TRUE ~ round(1 - (abs(100 - prol) / abs(100 - 50)), 3)
|
||||
),
|
||||
|
||||
# poids naissance corrigé
|
||||
pn_n = dplyr::case_when(
|
||||
is.na(pn_corr) ~ NA_real_,
|
||||
40 < pn_corr & pn_corr < 50 ~ 1,
|
||||
22 > pn_corr | pn_corr > 68 ~ 0,
|
||||
22 < pn_corr & pn_corr < 40 ~ round(0.056 * (pn_corr - 22), 3),
|
||||
TRUE ~ round(1 - 0.056 * (pn_corr - 50), 3)
|
||||
),
|
||||
|
||||
# mortalité
|
||||
mort_n = round(1.0 * exp(-0.031 * mort), 3)
|
||||
)
|
||||
|
||||
# =========================
|
||||
# 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)
|
||||
|
||||
v_final <- v_norm %>%
|
||||
rowwise() %>%
|
||||
mutate(
|
||||
SOMME_tot = {
|
||||
x <- c_across(all_of(names(weights)))
|
||||
w <- weights
|
||||
mask <- !is.na(x) & !is.na(w) &
|
||||
is.finite(x) & is.finite(w) &
|
||||
w != 0
|
||||
|
||||
if (sum(mask) == 0) {
|
||||
NA_real_
|
||||
} else {
|
||||
weighted.mean(x[mask], w[mask]) * 10
|
||||
}
|
||||
},
|
||||
ecowcarr = if_else(
|
||||
is.na(ptgp_n) & is.na(p120_n) & is.na(p210_n), # règle d'exclusion VA4 : si pas ces trois valeurs ça enlève 1/4 de la note -> pas classable, voir pour créer une alternative pour éleveurs
|
||||
NA_real_,
|
||||
round(SOMME_tot * 100, 0)
|
||||
)
|
||||
) %>%
|
||||
ungroup()
|
||||
|
||||
v_final <- v_final %>%
|
||||
mutate(
|
||||
rg_carr = as.integer(rank(1 / ecowcarr, na.last="keep"))
|
||||
)
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user