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

[éCow] Correctifs et nettoyage

Browse Source
This commit is contained in:
Léa
2026-09-02 11:23:16 +02:00
parent 108562c69b
commit 9291831ee5
4 changed files with 218 additions and 184 deletions
Download Patch File Download Diff File Expand all files Collapse all files
R/project/ecow_calculations.R
+25 -154
View File
@@ -42,14 +42,14 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
# 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
# Ajout du nom du père pour affichage classement carrière
vaches <- vaches %>%
dplyr::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)
produits_cheptel <- add_data_ecow(cheptel_ecow$produits, cheptel_ecow$nomsparents, czhbc)
###################################################################################################################
@@ -78,153 +78,23 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
synth_brute_vaches <- get_synth_prod_parent(vaches, prod_vaches_corr, params_ponderation)
# Normalisation et calcul des notes carrières
synth_norm <- get_note_carriere(synth_brute_vaches, params_ponderation)
synth_vaches <- synth_norm$synthese
# calcul des stats, valeurs extremes et references pour la normalisation
stats_chep <- synth_norm$stats_chep
synth_vaches <- get_note_carriere(synth_brute_vaches, params_ponderation)
#################################### 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), # ------------------------------------------------------------------------- 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, # ------------------------------- 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"
)
# Calcul des notes ecowcamp par vache / date de naissance / Rang de vélage
synth_campagne <- get_note_campagne(prod_vaches_corr, params_ponderation)
# Attribution du numéro de cheptel pour l'enregistrement en base
synth_campagne$cheptel <- cheptel
# Récupère le nom du père
synth_prod_vache <- synth_prod_vache %>%
dplyr::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(params_ponderation$campagne$final)
pond_camp_ahp <- unlist(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 %>%
# Moyenne de la note ecowcamp par mère pour celle ayant une note > 10
moy_camp <- synth_campagne %>%
filter(ecowcamp > 10) %>%
group_by(numeroMipg) %>%
summarise(moyecowcamp = round(mean(ecowcamp, na.rm = TRUE), 1), .groups = "drop")
# 3) Fusion + transformations
# Ajout de la note moyenne de campagne au tableau récapitulatif des vaches
v_camp <-synth_vaches %>%
dplyr::left_join(moy_camp, by = c("anim" = "numeroMipg")) %>%
mutate(
@@ -240,9 +110,9 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
save_data_vaches(v_camp, cheptel)
# Enregistrement des données de campagne en base
synth_prod_vache_n <- synth_prod_vache_n %>%
synth_campagne <- synth_campagne %>%
mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100))
save_data_campagne(synth_prod_vache_n, cheptel)
save_data_campagne(synth_campagne, cheptel)
if (step == 1) {
t1 <- Sys.time()
@@ -258,19 +128,20 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
produits_taureaux <- produits_cheptel %>%
filter(pereGenetique %in% taureaux$anim & embryon != 'O')
# Récupères les filles des taureaux
# Récupères les filles des taureaux nées dans le cheptel
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)
# Petits produits issus des filles des taureaux nés dans le cheptel
pprod_filles_taureaux <- add_data_ecow(cheptel_ecow$petits_produits, cheptel_ecow$nomsparents, czhbc)
# Calcul de la synthèse par fille de leur produits
synth_filles_taureaux <- get_synth_prod_parent(filles_taureaux, pprod_filles_taureaux, params_ponderation)
# Calcul des stats par pere
stats_prod_directe <- get_stats_parent(produits_taureaux, pereGenetique)
# Calcul des performances des filles pour les taureaux en ayant au moins 3
stats_filles <- get_stats_filles(synth_filles_taureaux, "fillestot_", pereGenetique, actif = FALSE, cheptel)
stats_filles_act <- get_stats_filles(synth_filles_taureaux, "fillesact_", pereGenetique, actif = TRUE, cheptel)
@@ -278,12 +149,13 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
grp_filles_et_act <- stats_filles %>%
dplyr::left_join(stats_filles_act, by = "pereGenetique") %>%
mutate(
pctfilles_avecprod = round(fillestot_nbavecprod / fillestot_count* 100, 1),
pctfillesact_avecprod = round( fillesact_nbavecprod / fillestot_nbavecprod * 100, 1 )
)
stats_filles_renouv <- produits_cheptel %>%
filter(
is.na(NBPRODIPG),# TODO valider avec Lauréna que c'est bien ce champ là qu'on veut
is.na(NBPRODIPG), # Pas idéal car pas propre au cheptel, mais en même temps si ce sont des femelles de renouvellement elles ne devraient avoir aucun produit
sexe == "2",
is.na(dateSortDetenteur)
) %>%
@@ -317,17 +189,16 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
###################################################################################################################
message("Début partie Lignées")
fondatrices <- cheptel_ecow$fondatrices
descendants <- add_data_ecow(cheptel_ecow$descendants, czhbc)
descendants <- add_data_ecow(cheptel_ecow$descendants, cheptel_ecow$nomsparents, czhbc)
vaches_lignees <- descendants %>% filter(anim %in% descendants$mereGenetique)
produits_lignees <- descendants %>% filter(mereGenetique %in% vaches_lignees$anim)
synth_vaches_lignees <- get_synth_prod_parent(vaches_lignees, produits_lignees, params_ponderation)
# calcul des stats par fondatrice, ne gardant que celles ayant plus de 5 descendants dans le cheptel_________________
# Si je ne mets pas descendants, je perds les stats directe des vaches achetées car elles n'ont pas encore de petits_produits
stats_prod <- get_stats_parent(descendants, fondatrice) # produits lignées ou descendants ????
# Calcul des stats par fondatrice, ne gardant que celles ayant plus de 5 descendants dans le cheptel
# On utilise les descendants globaux afin de ne pas perdre les stats directes des vaches achetées qui n'auraient pas encore de petits_produits
stats_prod <- get_stats_parent(descendants, fondatrice)
stats_fem_tot <- get_stats_filles(synth_vaches_lignees, "femtot_", fondatrice, actif = FALSE, cheptel)
@@ -335,7 +206,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
stats_renouv <- descendants %>%
filter(
is.na(NBPRODIPG),# TODO valider avec Lauréna que c'est bien ce champ là qu'on veut
is.na(NBPRODIPG), # Pas idéal car pas propre au cheptel, mais en même temps si ce sont des femelles de renouvellement elles ne devraient avoir aucun produit
sexe == "2",
is.na(dateSortDetenteur),
cheptelDetenteur == cheptel
R/project/postprocessing.R
+5 -6
View File
@@ -100,7 +100,6 @@ maj_ecow_from_csv <- function() {
}
format_duration <- function(seconds) {
h <- as.integer(seconds %/% 3600)
m <- as.integer((seconds %% 3600) %/% 60)
@@ -185,11 +184,11 @@ save_data_taureau <- function(taureaux, cheptel){
filtered_taureaux <- taureaux %>%
select(
cheptel, pereGenetique, nom, dateNaiss, nomCheptelNaiss, nb_prod_in_chep, utilgen, prol, mort, txrepros, nbpp, txvf, pnm, pnf, p120m, p120f, p210m, p210f,
dmsev, dssev, afsev, fillestot_nbavecprod, fillestot_pctavecprod, fillestot_isu, fillestot_age_sort, fillestot_agevel1, fillestot_ivv1, fillestot_ivv2p,
dmsev, dssev, afsev, fillestot_nbavecprod, pctfilles_avecprod, fillestot_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, fillesact_nbavecprod, pctfillesact_avecprod, fillesact_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, nbfilles_renouv
fillesact_txvf, nbfilles_renouv, fillestot_produits
)
colnames(filtered_taureaux) <- c(
@@ -198,7 +197,7 @@ save_data_taureau <- function(taureaux, cheptel){
"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"
"txvf_fillesact", "nbfilles_renouv", "produits"
)
nb_lignes_supp <- delete_data_today(cheptel, "TAUREAUX")
@@ -224,7 +223,7 @@ save_data_lignees <- function(lignees, cheptel){
femtot_ivv2p, femtot_vieprod, femtot_dmad, femtot_dsad, femtot_afad, femtot_nbprod, femtot_txrepros, femtot_nbpp, femtot_prol,
femtot_mort, femtot_txvf, femact_nbavecprod, pctfemact_avecprod, femact_isu, femact_age_sort, femact_agevel1, femact_ivv1,
femact_ivv2p, femact_vieprod, femact_dmad, femact_dsad, femact_afad, femact_nbprod, femact_txrepros, femact_nbpp, femact_prol,
femact_mort, femact_txvf, nbfilles_renouv
femact_mort, femact_txvf, nbfilles_renouv, femtot_produits
)
colnames(filtered_lignees) <- c(
@@ -233,7 +232,7 @@ save_data_lignees <- function(lignees, cheptel){
"ivv2p_femtot", "vieprod_femtot", "dmad_femtot", "dsad_femtot", "afad_femtot", "nbprod_femtot", "txrepros_femtot", "nbpp_femtot", "prol_femtot",
"mort_femtot", "txvf_femtot", "nbfemact_avecprod", "pctfemact_avecprod", "isu_femact", "age_sort_femact", "agevel1_femact", "ivv1_femact",
"ivv2p_femact", "vieprod_femact", "dmad_femact", "dsad_femact", "afad_femact", "nbprod_femact", "txrepros_femact", "nbpp_femact", "prol_femact",
"mort_femact", "txvf_femact", "nbfem_renouv"
"mort_femact", "txvf_femact", "nbfem_renouv", "produits"
)
nb_lignes_supp <- delete_data_today(cheptel, "LIGNEES")
R/project/preprocessing.R
+156 -13
View File
@@ -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"
)