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

[éCow] Correctifs taureaux lignées

Browse Source
This commit is contained in:
Léa
2026-08-07 11:24:30 +02:00
parent 46f7294fc0
commit 108562c69b
4 changed files with 54 additions and 68 deletions
Download Patch File Download Diff File Expand all files Collapse all files
R/project/ecow_calculations.R
+15 -12
View File
@@ -237,12 +237,12 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
v_camp <- v_camp %>%
mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100))
save_data_vaches(v_camp)
save_data_vaches(v_camp, cheptel)
# Enregistrement des données de campagne en base
synth_prod_vache_n <- synth_prod_vache_n %>%
mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100))
save_data_campagne(synth_prod_vache_n)
save_data_campagne(synth_prod_vache_n, cheptel)
if (step == 1) {
t1 <- Sys.time()
@@ -271,9 +271,9 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
# Calcul des stats par pere
stats_prod_directe <- get_stats_parent(produits_taureaux, pereGenetique)
stats_filles <- get_stats_filles(synth_filles_taureaux, "fillestot_", pereGenetique, actif = FALSE)
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)
stats_filles_act <- get_stats_filles(synth_filles_taureaux, "fillesact_", pereGenetique, actif = TRUE, cheptel)
grp_filles_et_act <- stats_filles %>%
dplyr::left_join(stats_filles_act, by = "pereGenetique") %>%
@@ -283,8 +283,9 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
stats_filles_renouv <- produits_cheptel %>%
filter(
is.na(NBPRODIPG),# TODO valider avec Lauréna que c'est bien ce champ là qu'on veut
sexe == "2",
nbFinGestation == 0 # TODO valider avec Lauréna que c'est bien ce champ là qu'on veut
is.na(dateSortDetenteur)
) %>%
group_by(pereGenetique) %>%
summarise(
@@ -303,7 +304,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
)
message("Enregistrement données taureaux")
save_data_taureau(stats_taureaux)
save_data_taureau(stats_taureaux, cheptel)
if (step == 2) {
t1 <- Sys.time()
@@ -314,7 +315,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
###################################################################################################################
#################################### Remontee des lignees femelles ########################################
###################################################################################################################
message("Début partie Lignées")
fondatrices <- cheptel_ecow$fondatrices
descendants <- add_data_ecow(cheptel_ecow$descendants, czhbc)
@@ -325,17 +326,19 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
# 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 ????
stats_fem_tot <- get_stats_filles(synth_vaches_lignees, "femtot_", fondatrice, actif = FALSE)
stats_fem_tot <- get_stats_filles(synth_vaches_lignees, "femtot_", fondatrice, actif = FALSE, cheptel)
stats_fem_act <- get_stats_filles(synth_vaches_lignees, "femact_", fondatrice, actif = TRUE)
stats_fem_act <- get_stats_filles(synth_vaches_lignees, "femact_", fondatrice, actif = TRUE, cheptel)
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)
is.na(dateSortDetenteur),
cheptelDetenteur == cheptel
) %>%
group_by(fondatrice) %>%
summarise(
@@ -352,12 +355,12 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) {
pctfem_avecprod =
round(femtot_nbavecprod / nb_femelles* 100, 1),
pctfemact_avecprod =
round(femact_nbavecprod / nb_femelles * 100, 1),
round(femact_nbavecprod / femtot_nbavecprod * 100, 1),
cheptel = cheptel
)
message("Enregistrement données lignées")
save_data_lignees(stats_lignees)
save_data_lignees(stats_lignees, cheptel)
t1 <- Sys.time()
message("Fin du traitement. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec")
}
R/project/postprocessing.R
+21 -10
View File
@@ -109,7 +109,7 @@ format_duration <- function(seconds) {
sprintf("%02d:%02d:%02d", h, m, s)
}
save_data_vaches <- function(vaches){
save_data_vaches <- function(vaches, cheptel){
tabfinal <- vaches %>%
select(
cheptelDetenteur, anim, nom, nom_pere, embryon, donneuse, porteuse, tempsprod, age_years, ecowcarr, rg_carr, ptgV,
@@ -125,6 +125,9 @@ save_data_vaches <- function(vaches){
"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"
)
nb_lignes_supp <- delete_data_today(cheptel, "VACHES")
if (nb_lignes_supp > 0) message("Lignes du jour supprimées dans la table ecowVaches : ", nb_lignes_supp)
tab_format <- tabfinal %>%
mutate(
across(
@@ -151,9 +154,9 @@ save_data_vaches <- function(vaches){
dbDisconnect(con)
}
save_data_campagne <- function(synth_camp){
save_data_campagne <- function(campagnes, cheptel){
# Stockage des données écow_camp
filtered_prod_camp <- synth_camp %>%
filtered_prod_camp <- campagnes %>%
select(
cheptel, numeroMipg, dateNaiss, rangVelageMipg, ecowcamp, nom_pere, produits
)
@@ -162,6 +165,9 @@ save_data_campagne <- function(synth_camp){
"cheptel", "mere_ipg", "danais", "ravelamer_corr", "note_ecow", "pere", "produits"
)
nb_lignes_supp <- delete_data_today(cheptel, "CAMPAGNES")
if (nb_lignes_supp > 0) message("Lignes du jour supprimées dans la table ecowCampagne : ", nb_lignes_supp)
con <- get_db_connection()
dbWriteTable(
@@ -174,14 +180,14 @@ save_data_campagne <- function(synth_camp){
dbDisconnect(con)
}
save_data_taureau <- function(data_taureaux){
save_data_taureau <- function(taureaux, cheptel){
# Stockage des données écow_taureaux
filtered_taureaux <- data_taureaux %>%
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,
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,
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
)
@@ -194,6 +200,9 @@ save_data_taureau <- function(data_taureaux){
"vieprod_fillesact", "dmad_fillesact", "dsad_fillesact", "afad_fillesact", "nbprod_fillesact", "txrepros_fillesact", "nbpp_fillesact", "prol_fillesact", "mort_fillesact",
"txvf_fillesact", "nbfilles_renouv"
)
nb_lignes_supp <- delete_data_today(cheptel, "TAUREAUX")
if (nb_lignes_supp > 0) message("Lignes du jour supprimées dans la table ecowTaureaux : ", nb_lignes_supp)
con <- get_db_connection()
@@ -207,13 +216,13 @@ save_data_taureau <- function(data_taureaux){
dbDisconnect(con)
}
save_data_lignees <- function(stats_lignees){
filtered_lignees <- stats_lignees %>%
save_data_lignees <- function(lignees, cheptel){
filtered_lignees <- 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,
p120f, p210m, p210f, dmsev, dssev, afsev, femtot_nbavecprod, pctfem_avecprod, 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,
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
)
@@ -227,6 +236,8 @@ save_data_lignees <- function(stats_lignees){
"mort_femact", "txvf_femact", "nbfem_renouv"
)
nb_lignes_supp <- delete_data_today(cheptel, "LIGNEES")
if (nb_lignes_supp > 0) message("Lignes du jour supprimées dans la table ecowLignees : ", nb_lignes_supp)
con <- get_db_connection()
R/project/preprocessing.R
+8 -4
View File
@@ -183,7 +183,7 @@ get_synth_prod_parent <- function(vaches, produits, params_ponderation){
ivv2Brut < 365 ~ 0,
TRUE ~ ivv2Brut - 365
),
days_since_last = as.numeric(difftime(Sys.Date(), last_danais, units = "days")),
days_since_last = as.numeric(difftime(if_else(is.na(dateSortDetenteur), Sys.Date(), dateSortDetenteur), last_danais, units = "days")),
e4 = dplyr::case_when(
is.na(days_since_last) ~ 0,
days_since_last < 365 ~ 0,
@@ -191,7 +191,7 @@ get_synth_prod_parent <- function(vaches, produits, params_ponderation){
),
# temps productif (%)
age_days = time_length( interval( dateNaiss, Sys.Date() ), "days" ),
age_days = time_length( interval( dateNaiss, if_else(is.na(dateSortDetenteur), Sys.Date(), dateSortDetenteur) ), "days" ),
age_years = round(age_days / 365, 1),
tempsprod = round( (age_days - (agevel1 * 30.4 + e2 + e3 * (nbcampvel - 2) + e4)) / age_days * 100, 1 ),
@@ -358,7 +358,7 @@ get_stats_parent <- function(produits, 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) {
get_stats_filles <- function(df, prefix, regroupement, actif = FALSE, cheptel) {
nb <- df %>%
group_by({{regroupement}}) %>%
summarise(
@@ -367,7 +367,11 @@ get_stats_filles <- function(df, prefix, regroupement, actif = FALSE) {
)
if (actif) {
df <- df %>% filter(is.na(dateSortDetenteur))
df <- df %>%
filter(
is.na(dateSortDetenteur),
cheptelDetenteur == cheptel # Vérifie pour les descendantes car elles ont pu être vendues
)
}
res <- df %>% group_by({{regroupement}}) %>%