[éCow] Correctifs et nettoyage
This commit is contained in:
+156
-13
@@ -9,12 +9,14 @@ 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){
|
||||
add_data_ecow <- function(liste_produits, noms_parents, czhbc){
|
||||
|
||||
#Ajout d'une colonne avec le nombre de produits IPG ------------------ TODO PEUT ETRE PLUS UTILE, à comparer avec nb_fin_gestation
|
||||
# Croisement avec les données SPIE
|
||||
#Ajout d'une colonne avec le nombre de produits IPG (croisement base SIG et SPIE)
|
||||
parents_ipg <- get_parents_ipg()
|
||||
liste_produits <- base::merge(liste_produits, get_parents_ipg(), by.x='anim', by.y='ANIM', all.x=T, all.y=F)
|
||||
noms_parents <- as.data.frame(noms_parents)
|
||||
liste_produits$nommere <- noms_parents$V2[match(liste_produits$numeroMipg, noms_parents$V1)]
|
||||
liste_produits$nompere <- noms_parents$V2[match(liste_produits$pereGenetique, noms_parents$V1)]
|
||||
|
||||
# Calcul REPRO
|
||||
liste_produits <- liste_produits %>%
|
||||
@@ -22,7 +24,6 @@ add_data_ecow <- function(liste_produits, czhbc){
|
||||
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_
|
||||
)
|
||||
) %>%
|
||||
@@ -96,6 +97,7 @@ get_stats_tbl <- function(tab, nom_tab, cols, conditions = NULL, nom_cond = NA)
|
||||
})
|
||||
}
|
||||
|
||||
#' Renvoie la synthèse pour chaque vache des performances de ses produits
|
||||
get_synth_prod_parent <- function(vaches, produits, params_ponderation){
|
||||
# On récupère les coefficients de pondération pour les pointages adultes
|
||||
ppa <- params_ponderation$pointage$adulte
|
||||
@@ -313,8 +315,128 @@ get_note_carriere <- function(v_ref, params_ponderation){
|
||||
mutate(
|
||||
rg_carr = as.integer(rank(1 / ecowcarr, na.last="keep"))
|
||||
)
|
||||
}
|
||||
|
||||
get_note_campagne <- function(prod_vaches_corr, params_ponderation){
|
||||
|
||||
# Groupement et synthèse des données des produits par vache / date de naissance / rang de vélage de la mère
|
||||
# Ca permet de grouper les jumeaux
|
||||
synth_prod_vache <- prod_vaches_corr %>%
|
||||
group_by(numeroMipg, dateNaiss, rangVelageMipg) %>%
|
||||
summarise(
|
||||
ivv = first(ivv1), # ------------------------------------------------------------------------- TODO 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,
|
||||
mort = round(mean(mortsev == "O" | mortnat == "O") * 100, 1),
|
||||
pere = first(pereGenetique),
|
||||
nom_pere = first(nompere),
|
||||
|
||||
# infos des veaux pour simplifier l'affichage
|
||||
produits = list(
|
||||
pmap(
|
||||
list(
|
||||
nom = nom,
|
||||
anim = anim,
|
||||
sexe = sexe,
|
||||
mortnat = mortnat,
|
||||
mortsev = mortsev,
|
||||
# Nombre de produits tous cheptels confondus
|
||||
NBPRODIPG = NBPRODIPG,
|
||||
embryon = embryon
|
||||
),
|
||||
list
|
||||
)
|
||||
),
|
||||
.groups = "drop"
|
||||
)
|
||||
|
||||
# Calcul des stats campagne pour chaque variable
|
||||
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')
|
||||
)
|
||||
|
||||
list(synthese = v_final, stats_chep = stats_chep)
|
||||
pond_camp_fin <- unlist(params_ponderation$campagne$final)
|
||||
pond_camp_ahp <- unlist(params_ponderation$campagne$AHPtech)
|
||||
|
||||
# Normalisation des valeurs par rapport aux statistiques de campagnes
|
||||
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_camp$max[stats_camp$var=="synth_prod_vache$txvf"] - txvf) /
|
||||
abs(diff(range(stats_camp[stats_camp$var=="synth_prod_vache$txvf",c("min","max")]))), 3),
|
||||
|
||||
txm_n = round(1 - abs(stats_camp$max[stats_camp$var=="synth_prod_vache$txm"] - txm) /
|
||||
abs(diff(range(stats_camp[stats_camp$var=="synth_prod_vache$txm",c("min","max")]))), 3),
|
||||
|
||||
ptgp_n = round(1 - abs(stats_camp$max[stats_camp$var=="synth_prod_vache$ptgp"] - ptgp) /
|
||||
abs(diff(range(stats_camp[stats_camp$var=="synth_prod_vache$ptgp",c("min","max")]))), 3),
|
||||
|
||||
p120_n = round(1 - abs(stats_camp$max[stats_camp$var=="synth_prod_vache$p120_c"] - p120_c) /
|
||||
abs(diff(range(stats_camp[stats_camp$var=="synth_prod_vache$p120_c",c("min","max")]))), 3),
|
||||
|
||||
p210_n = round(1 - abs(stats_camp$max[stats_camp$var=="synth_prod_vache$p210_c"] - p210_c) /
|
||||
abs(diff(range(stats_camp[stats_camp$var=="synth_prod_vache$p210_c",c("min","max")]))), 3),
|
||||
# prol
|
||||
prol_n = case_when(
|
||||
is.na(prol) ~ NA_real_,
|
||||
prol == 100 ~ 0.8,
|
||||
TRUE ~ 1
|
||||
),
|
||||
# mortalité
|
||||
mort_n = round(exp(-0.031 * mort), 3),
|
||||
# IVV
|
||||
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)
|
||||
)
|
||||
) %>%
|
||||
|
||||
# Calcul du 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()
|
||||
}
|
||||
|
||||
get_stats_parent <- function(produits, regroupement){
|
||||
@@ -353,10 +475,9 @@ get_stats_parent <- function(produits, regroupement){
|
||||
filter(nb_prod_in_chep >= 5)
|
||||
}
|
||||
|
||||
#' Renvoie les statistiques des produits pour les éléments ayant plus de 3 produits
|
||||
#' Renvoie les statistiques des produits pour les éléments ayant plus de 3 produits dans le cheptel
|
||||
#' @param regroupement character. Champs sur lequel on veut faire le regroupement
|
||||
#' @param actif booléen. Filtre sur les produits
|
||||
#' selon le champs {}
|
||||
#' @param actif booléen. Filtre sur les produits actifs
|
||||
#' @return Liste d'adhérents
|
||||
get_stats_filles <- function(df, prefix, regroupement, actif = FALSE, cheptel) {
|
||||
nb <- df %>%
|
||||
@@ -364,7 +485,7 @@ get_stats_filles <- function(df, prefix, regroupement, actif = FALSE, cheptel) {
|
||||
summarise(
|
||||
"{prefix}count" := n(),
|
||||
.groups = "drop"
|
||||
)
|
||||
)
|
||||
|
||||
if (actif) {
|
||||
df <- df %>%
|
||||
@@ -374,10 +495,14 @@ get_stats_filles <- function(df, prefix, regroupement, actif = FALSE, cheptel) {
|
||||
)
|
||||
}
|
||||
|
||||
res <- df %>% group_by({{regroupement}}) %>%
|
||||
res <- df %>%
|
||||
filter(
|
||||
!is.na(n_veaux) # Garde seulement les filles ayant produit dans le cheptel
|
||||
) %>%
|
||||
group_by({{regroupement}}) %>%
|
||||
summarise(
|
||||
"{prefix}nbavecprod" := sum(NBPRODIPG > 0, na.rm = TRUE),
|
||||
"{prefix}pctavecprod" := round(sum(NBPRODIPG > 0, na.rm = TRUE) / n() * 100, 1),
|
||||
"{prefix}nbavecprod" := sum( n_veaux > 0, na.rm = TRUE),
|
||||
"{prefix}pctavecprod" := round(sum(n_veaux > 0, na.rm = TRUE) / n() * 100, 1),
|
||||
"{prefix}isu" := ifelse(n() >= 3, sum(embryon == "O", na.rm = TRUE), NA),
|
||||
"{prefix}age_sort" := ifelse(n() >= 3, round(mean(age_years, na.rm = TRUE), 1), NA),
|
||||
"{prefix}agevel1" := ifelse(n() >= 3, round(mean(agevel1, na.rm = TRUE), 1), NA),
|
||||
@@ -393,10 +518,28 @@ get_stats_filles <- function(df, prefix, regroupement, actif = FALSE, cheptel) {
|
||||
"{prefix}mort" := ifelse(n() >= 3, round(mean(mort, na.rm = TRUE), 1), NA),
|
||||
"{prefix}txvf" := ifelse(n() >= 3, round(mean(txvf, na.rm = TRUE), 1), NA),
|
||||
|
||||
"{prefix}nbprod" := ifelse(n() >= 3, sum(NBPRODIPG, na.rm = TRUE), NA),
|
||||
"{prefix}nbprod" := ifelse(n() >= 3, sum(n_veaux, na.rm = TRUE), NA), # On veut uniquement les produits dans le cheptel
|
||||
"{prefix}txrepros" := ifelse(n() >= 3, round(mean(txrepros, na.rm = TRUE), 1), NA),
|
||||
"{prefix}nbpp" := ifelse(n() >= 3, sum(nbpp, na.rm = TRUE), NA),
|
||||
|
||||
# infos des produits pour l'affichage
|
||||
produits = list(
|
||||
pmap(
|
||||
list(
|
||||
nom = nom,
|
||||
anim = anim,
|
||||
dateNaiss = dateNaiss,
|
||||
rangVelageMipg = rangVelageMipg,
|
||||
numeroMipg = numeroMipg,
|
||||
nommere = nommere,
|
||||
pereGenetique = pereGenetique,
|
||||
nompere = nompere,
|
||||
active = is.na(dateSortDetenteur) & cheptelDetenteur == cheptel
|
||||
),
|
||||
list
|
||||
)
|
||||
),
|
||||
"{prefix}produits" := toJSON(produits, auto_unbox = TRUE),
|
||||
.groups = "drop"
|
||||
)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user