[é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")
|
||||
}
|
||||
|
||||
+65
-34
@@ -40,19 +40,13 @@ maj_ecow_for_all <- function() {
|
||||
maj_ecow_for_list_cheptels(list_chep)
|
||||
}
|
||||
|
||||
mafonctiondetest <- function(cheptel){
|
||||
source(here::here("R/common/ws_client.R"))
|
||||
cheptel_ecow <- get_cheptel_ecow(cheptel)
|
||||
vaches <- cheptel_ecow$vaches
|
||||
return(length(vaches))
|
||||
}
|
||||
|
||||
#' 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){
|
||||
total <- length(list_cheptels)
|
||||
start_time <- Sys.time()
|
||||
message(sprintf("🚀 Début traitement - %s cheptels à traiter", total))
|
||||
flush.console()
|
||||
|
||||
res <- lapply(seq_along(list_cheptels), function(i) {
|
||||
num_chep <- list_cheptels[[i]]
|
||||
@@ -60,17 +54,21 @@ maj_ecow_for_list_cheptels <- function(list_cheptels){
|
||||
tryCatch(
|
||||
{
|
||||
message(sprintf("[%s/%s] Traitement cheptel %s ...", i, total, num_chep))
|
||||
out <- calcul_ecow_by_chep(num_chep, 1) # Pour l'instant on s'arrête aux vaches
|
||||
flush.console()
|
||||
out <- calcul_ecow_by_chep(num_chep, 3) # Pour l'instant on s'arrête aux vaches
|
||||
message(sprintf("✓ OK cheptel %s", num_chep))
|
||||
flush.console()
|
||||
out
|
||||
},
|
||||
error = function(e) {
|
||||
message(sprintf("✗ ERREUR cheptel %s : %s", num_chep, conditionMessage(e)))
|
||||
flush.console()
|
||||
NULL
|
||||
}
|
||||
),
|
||||
warning = function(w) {
|
||||
message(sprintf("! AVERTISSEMENT cheptel %s : %s", num_chep, conditionMessage(w)))
|
||||
flush.console()
|
||||
invokeRestart("muffleWarning")
|
||||
}
|
||||
)
|
||||
@@ -84,6 +82,25 @@ maj_ecow_for_list_cheptels <- function(list_cheptels){
|
||||
return(res)
|
||||
}
|
||||
|
||||
|
||||
maj_ecow_from_csv <- function() {
|
||||
|
||||
cheptels <- read.csv('cheptels_liste.csv', stringsAsFactors = FALSE)
|
||||
|
||||
if (!"login" %in% names(cheptels)) {
|
||||
stop("Colonne 'login' absente du CSV")
|
||||
}
|
||||
|
||||
if (nrow(cheptels) == 0) {
|
||||
message("Aucun cheptel à traiter")
|
||||
return(NULL)
|
||||
}
|
||||
|
||||
maj_ecow_for_list_cheptels(as.list(cheptels$login))
|
||||
|
||||
}
|
||||
|
||||
|
||||
format_duration <- function(seconds) {
|
||||
h <- as.integer(seconds %/% 3600)
|
||||
m <- as.integer((seconds %% 3600) %/% 60)
|
||||
@@ -95,22 +112,17 @@ format_duration <- function(seconds) {
|
||||
save_data_vaches <- function(vaches){
|
||||
tabfinal <- vaches %>%
|
||||
select(
|
||||
cheptelDetenteur, anim, nom, nom_pere, embryon, donneuse, porteuse,
|
||||
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
|
||||
cheptelDetenteur, anim, nom, nom_pere, embryon, donneuse, porteuse, 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", "donneuse", "porteuse", "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"
|
||||
"cheptel", "num_vache", "nom_vache", "pere", "isu", "donneuse", "porteuse", "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 %>%
|
||||
@@ -162,28 +174,26 @@ save_data_campagne <- function(synth_camp){
|
||||
dbDisconnect(con)
|
||||
}
|
||||
|
||||
save_data_taureau <- function(data_taureaux, cheptel){
|
||||
save_data_taureau <- function(data_taureaux){
|
||||
# Stockage des données écow_taureaux
|
||||
filtered_taureaux <- data_taureaux %>%
|
||||
select(
|
||||
cheptelDetenteur, pereGenetique, nom, dateNaiss, nomCheptelNaiss, 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
|
||||
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,
|
||||
fillestot_vieprod, fillestot_dmad, fillestot_dsad, fillestot_afad, fillestot_nbprod, fillestot_txrepros, fillestot_nbpp, fillestot_prol, fillestot_mort,
|
||||
fillestot_txvf, fillesact_nbavecprod, fillesact_pctavecprod, 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
|
||||
)
|
||||
|
||||
colnames(filtered_taureaux) <- c(
|
||||
"cheptel", "anim", "nom", "date_naissance", "nom_chep_naiss", "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"
|
||||
"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()
|
||||
|
||||
@@ -198,14 +208,35 @@ save_data_taureau <- function(data_taureaux, cheptel){
|
||||
}
|
||||
|
||||
save_data_lignees <- function(stats_lignees){
|
||||
filtered_lignees <- stats_lignees %>%
|
||||
select(
|
||||
cheptel, fondatrice, nom, dateNaiss, nomCheptelNaiss, nb_prod_in_chep, utilgen, prol, mort, txrepros, nbpp, txvf, pnm, pnf, p120m,
|
||||
p120f, p210m, p210f, dmsev, dssev, afsev, femtot_nbavecprod, femtot_pctavecprod, femtot_isu, femtot_age_sort, femtot_agevel1, femtot_ivv1,
|
||||
femtot_ivv2p, femtot_vieprod, femtot_dmad, femtot_dsad, femtot_afad, femtot_nbprod, femtot_txrepros, femtot_nbpp, femtot_prol,
|
||||
femtot_mort, femtot_txvf, femact_nbavecprod, femact_pctavecprod, 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
|
||||
)
|
||||
|
||||
colnames(filtered_lignees) <- c(
|
||||
"cheptel", "anim", "nom", "date_naissance", "nom_chep_naiss", "nb_desc_in_chep", "utilgen", "prol", "mort", "txrepros", "nbpp", "txvf", "pnm", "pnf", "p120m",
|
||||
"p120f", "p210m", "p210f", "dmsev", "dssev", "afsev", "nbfem_avecprod", "pctfem_avecprod", "isu_femtot", "age_sort_femtot", "agevel1_femtot", "ivv1_femtot",
|
||||
"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"
|
||||
)
|
||||
|
||||
|
||||
con <- get_db_connection()
|
||||
|
||||
dbWriteTable(
|
||||
con,
|
||||
Id(schema = "hbc", table = "ecow_lignees"),
|
||||
stats_lignees,
|
||||
filtered_lignees,
|
||||
append = TRUE,
|
||||
row.names = FALSE
|
||||
)
|
||||
dbDisconnect(con)
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
@@ -96,7 +96,7 @@ get_stats_tbl <- function(tab, nom_tab, cols, conditions = NULL, nom_cond = NA)
|
||||
})
|
||||
}
|
||||
|
||||
get_synth_prod_vaches <- function(vaches, produits, params_ponderation){
|
||||
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
|
||||
|
||||
@@ -206,7 +206,9 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){
|
||||
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_, .)
|
||||
))
|
||||
|
||||
}
|
||||
|
||||
get_note_carriere <- function(v_ref, params_ponderation){
|
||||
# calcul des stats, valeurs extremes et references pour la normalisation
|
||||
stats_chep <- get_stats_tbl(
|
||||
tab = v_ref,
|
||||
@@ -216,7 +218,7 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){
|
||||
)
|
||||
|
||||
# =========================
|
||||
# 3) Normalisations
|
||||
# Normalisation
|
||||
# =========================
|
||||
v_norm <- v_ref %>%
|
||||
mutate(
|
||||
@@ -278,7 +280,7 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){
|
||||
)
|
||||
|
||||
# =========================
|
||||
# 4) Note carrière (pondérée)
|
||||
# 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(params_ponderation$carriere, 1)
|
||||
@@ -315,3 +317,84 @@ get_synth_prod_vaches <- function(vaches, produits, params_ponderation){
|
||||
list(synthese = v_final, stats_chep = stats_chep)
|
||||
}
|
||||
|
||||
get_stats_parent <- function(produits, regroupement){
|
||||
produits %>%
|
||||
group_by({{regroupement}}) %>%
|
||||
summarise(
|
||||
nb_prod_in_chep = n(),
|
||||
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),
|
||||
|
||||
nb_femelles = sum(sexe == "2", na.rm = TRUE),
|
||||
.groups = "drop"
|
||||
) %>%
|
||||
filter(nb_prod_in_chep >= 5)
|
||||
}
|
||||
|
||||
#' Renvoie les statistiques des produits pour les éléments ayant plus de 3 produits
|
||||
#' @param regroupement character. Champs sur lequel on veut faire le regroupement
|
||||
#' @param actif booléen. Filtre sur les produits
|
||||
#' selon le champs {}
|
||||
#' @return Liste d'adhérents
|
||||
get_stats_filles <- function(df, prefix, regroupement, actif = FALSE) {
|
||||
nb <- df %>%
|
||||
group_by({{regroupement}}) %>%
|
||||
summarise(
|
||||
"{prefix}count" := n(),
|
||||
.groups = "drop"
|
||||
)
|
||||
|
||||
if (actif) {
|
||||
df <- df %>% filter(is.na(dateSortDetenteur))
|
||||
}
|
||||
|
||||
res <- df %>% 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}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),
|
||||
"{prefix}ivv1" := ifelse(n() >= 3, round(mean(ivv1, na.rm = TRUE), 1), NA),
|
||||
"{prefix}ivv2p" := ifelse(n() >= 3, round(mean(ivv2Brut, na.rm = TRUE), 1), NA),
|
||||
"{prefix}vieprod" := ifelse(n() >= 3, round(mean(tempsprod, na.rm = TRUE), 1), NA),
|
||||
|
||||
"{prefix}dmad" := ifelse(n() >= 3, round(mean(dmcAdulte, na.rm = TRUE), 1), NA),
|
||||
"{prefix}dsad" := ifelse(n() >= 3, round(mean(dsAdulte, na.rm = TRUE), 1), NA),
|
||||
"{prefix}afad" := ifelse(n() >= 3, round(mean(afAdulte, na.rm = TRUE), 1), NA),
|
||||
|
||||
"{prefix}prol" := ifelse(n() >= 3, round(mean(prol, na.rm = TRUE), 1), NA),
|
||||
"{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}txrepros" := ifelse(n() >= 3, round(mean(txrepros, na.rm = TRUE), 1), NA),
|
||||
"{prefix}nbpp" := ifelse(n() >= 3, sum(nbpp, na.rm = TRUE), NA),
|
||||
|
||||
.groups = "drop"
|
||||
)
|
||||
|
||||
res <- left_join(res, nb, by = rlang::as_name(rlang::ensym(regroupement)))
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user