[éCow] Ajout partie lignées
This commit is contained in:
+63
-244
@@ -12,6 +12,7 @@ suppressPackageStartupMessages({
|
||||
})
|
||||
source(here::here("R/common/ws_client.R"))
|
||||
source(here::here("R/project/preprocessing.R"))
|
||||
source(here::here("R/project/postprocessing.R"))
|
||||
|
||||
#' Fonction globale de mise à jour des indicateurs eCow pour vaches, taureaux et lignées
|
||||
#' Stockage des données directement en base
|
||||
@@ -74,11 +75,14 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
|
||||
pps <- params_ponderation$pointage$sevrage
|
||||
|
||||
# Ajout à la table vache des informations synthétisées de leur veaux
|
||||
synth <- get_synth_prod_vaches(vaches, prod_vaches_corr, params_ponderation)
|
||||
synth_vaches <- synth$synthese
|
||||
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$stats_chep
|
||||
stats_chep <- synth_norm$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 #######
|
||||
@@ -96,7 +100,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
|
||||
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
|
||||
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),
|
||||
@@ -261,113 +265,20 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
|
||||
# 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_ft <- get_synth_prod_vaches(filles_taureaux, pprod_filles_taureaux, params_ponderation)
|
||||
synth_filles_taureaux <- synth_ft$synthese
|
||||
# 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_peres <- produits_taureaux %>%
|
||||
group_by(pereGenetique) %>%
|
||||
summarise(
|
||||
nb_prod_in_chep = n(),
|
||||
.groups = "drop"
|
||||
) %>%
|
||||
filter(nb_prod_in_chep >= 5)
|
||||
stats_prod_directe <- get_stats_parent(produits_taureaux, pereGenetique)
|
||||
|
||||
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((sum(mortsev == "O" | mortnat == "O", na.rm = TRUE)) / n() * 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),
|
||||
dssev = round(mean(dsSevrage, na.rm = TRUE), 1),
|
||||
afsev = round(mean(afSevrage, na.rm = TRUE), 1),
|
||||
stats_filles <- get_stats_filles(synth_filles_taureaux, "fillestot_", pereGenetique, actif = FALSE)
|
||||
|
||||
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 / nbfilles_avecprod * 100, 1),
|
||||
|
||||
isu_fillesact = 0,
|
||||
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"
|
||||
)
|
||||
stats_filles_act <- get_stats_filles(synth_filles_taureaux, "fillesact_", pereGenetique, actif = TRUE)
|
||||
|
||||
grp_filles_et_act <- stats_filles %>%
|
||||
dplyr::left_join(stats_filles_act, by = "pereGenetique") %>%
|
||||
mutate(
|
||||
pctfillesact_avecprod = round( nbfillesact_avecprod / nbfilles_avecprod * 100, 1 )
|
||||
pctfillesact_avecprod = round( fillesact_nbavecprod / fillestot_nbavecprod * 100, 1 )
|
||||
)
|
||||
|
||||
stats_filles_renouv <- produits_cheptel %>%
|
||||
@@ -381,21 +292,18 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
|
||||
.groups = "drop"
|
||||
)
|
||||
|
||||
stats_taureaux <- stats_peres %>%
|
||||
dplyr::left_join(stats_prod_directe, by = "pereGenetique") %>%
|
||||
stats_taureaux <- stats_prod_directe %>%
|
||||
dplyr::left_join(grp_filles_et_act, by = "pereGenetique") %>%
|
||||
dplyr::left_join(stats_filles_renouv, by = "pereGenetique") %>%
|
||||
dplyr::left_join(taureaux, by = "pereGenetique")
|
||||
|
||||
# Récupère le nom
|
||||
stats_taureaux <- stats_taureaux %>%
|
||||
select(-nom, -dateNaiss, -nomCheptelNaiss) %>%
|
||||
dplyr::left_join(taureaux %>% select(anim, nom, dateNaiss, nomCheptelNaiss),
|
||||
by = c("pereGenetique" = "anim")) %>%
|
||||
mutate(nom = replace(nom, is.na(nom), "")) %>%
|
||||
mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100))
|
||||
dplyr::left_join(taureaux %>% select(anim, nom, dateNaiss, nomCheptelNaiss), by = c("pereGenetique" = "anim")) %>%
|
||||
mutate(
|
||||
nom = replace(nom, is.na(nom), ""),
|
||||
cheptel = cheptel,
|
||||
across(where(is.numeric), ~ trunc(.x * 100) / 100)
|
||||
)
|
||||
|
||||
save_data_taureau(stats_taureaux, cheptel)
|
||||
message("Enregistrement données taureaux")
|
||||
save_data_taureau(stats_taureaux)
|
||||
|
||||
if (step == 2) {
|
||||
t1 <- Sys.time()
|
||||
@@ -408,137 +316,48 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
|
||||
###################################################################################################################
|
||||
|
||||
fondatrices <- cheptel_ecow$fondatrices
|
||||
descendants <- cheptel_ecow$descendants
|
||||
descendants <- add_data_ecow(cheptel_ecow$descendants, czhbc)
|
||||
|
||||
vaches_lignees <- descendants %>%
|
||||
filter(anim %in% descendants$mereIpg)
|
||||
produits_lignees <- add_data_ecow(
|
||||
descendants %>%
|
||||
filter(mereIpg %in% descendants$anim)
|
||||
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_________________
|
||||
|
||||
stats_prod <- get_stats_parent(descendants, fondatrice) # produits lignées ou descendants ????
|
||||
|
||||
stats_fem_tot <- get_stats_filles(synth_vaches_lignees, "femtot_", fondatrice, actif = FALSE)
|
||||
|
||||
stats_fem_act <- get_stats_filles(synth_vaches_lignees, "femact_", fondatrice, actif = TRUE)
|
||||
|
||||
stats_renouv <- descendants %>%
|
||||
filter(
|
||||
is.na(NBPRODIPG),# TODO valider avec Lauréna que c'est bien ce champ là qu'on veut
|
||||
sexe == "2",
|
||||
is.na(dateSortDetenteur)
|
||||
) %>%
|
||||
group_by(fondatrice) %>%
|
||||
summarise(
|
||||
nbfilles_renouv = n(),
|
||||
.groups = "drop"
|
||||
)
|
||||
#
|
||||
# # TODO quel effet chep ? Comment on l'applique ?
|
||||
#
|
||||
# synth_vaches_lignees <- get_synth_prod_vaches(vaches_lignees, produits_lignees, params_ponderation, stats_chep)
|
||||
#
|
||||
# # 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 %>%
|
||||
# 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),
|
||||
# pctfemact_avecprod =
|
||||
# round(nbfemact_avecprod / nb_fem_prod * 100, 1)
|
||||
# )
|
||||
#
|
||||
# stats_lignees_final <- fondatrices %>%
|
||||
# mutate(anim = trim_str(anim)) %>%
|
||||
# dplyr::left_join(
|
||||
# stats_lignees %>% mutate(fondatrice = trim_str(fondatrice)),
|
||||
# by = c("anim" = "fondatrice")
|
||||
# )
|
||||
#
|
||||
# save_data_lignees(stats_lignees_final)
|
||||
|
||||
stats_lignees <- stats_prod %>%
|
||||
dplyr::left_join(stats_fem_tot, by = "fondatrice") %>%
|
||||
dplyr::left_join(stats_fem_act, by = "fondatrice") %>%
|
||||
dplyr::left_join(stats_renouv, by = "fondatrice") %>%
|
||||
dplyr::left_join(fondatrices %>% select(anim, nom, dateNaiss, nomCheptelNaiss), by = c("fondatrice" = "anim")) %>%
|
||||
mutate(
|
||||
pctfem_avecprod =
|
||||
round(femtot_nbavecprod / nb_femelles* 100, 1),
|
||||
pctfemact_avecprod =
|
||||
round(femact_nbavecprod / nb_femelles * 100, 1),
|
||||
cheptel = cheptel
|
||||
)
|
||||
|
||||
message("Enregistrement données lignées")
|
||||
save_data_lignees(stats_lignees)
|
||||
t1 <- Sys.time()
|
||||
message("Fin du traitement. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec")
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user