Mise en place projet R
This commit is contained in:
Executable
+523
@@ -0,0 +1,523 @@
|
||||
suppressPackageStartupMessages({
|
||||
library(roxygen2)
|
||||
library(dplyr)
|
||||
library(lubridate)
|
||||
library(purrr)
|
||||
library(stringr)
|
||||
library(DBI)
|
||||
library(RPostgres)
|
||||
library(here)
|
||||
library(httr)
|
||||
library(jsonlite)
|
||||
})
|
||||
source(here::here("R/common/ws_client.R"))
|
||||
source(here::here("R/project/preprocessing.R"))
|
||||
|
||||
#' Fonction globale de mise à jour des indicateurs eCow pour vaches, taureaux et lignées
|
||||
#' Stockage des données directement en base
|
||||
#' step : 1 si calcul des vaches uniquement, 2 si vaches et taureaux, 3 global
|
||||
#' @param cheptel character. Numéro du cheptel avec le FR devant
|
||||
calcul_ecow_by_chep <- function(cheptel, step = 3) {
|
||||
message("Début fonction calcul_ecow_by_chep")
|
||||
t0 <- Sys.time()
|
||||
|
||||
# Définit un environnement avec tous les paramètres qu'on veut rendre accessibles
|
||||
env_ecow <- new.env()
|
||||
# Récupère les paramètres de pondération
|
||||
env_ecow$params_ponderation <- get_params_ponderation(cheptel)
|
||||
# Récupère la liste des certificats zoo issue de Doli
|
||||
czhbc <- data.frame(ANIM = get_cztotaux())
|
||||
|
||||
message("Début import des données")
|
||||
cheptel_ecow <- get_cheptel_ecow(cheptel)
|
||||
|
||||
###################################################################################################################
|
||||
#################################### Calcul ecow pour les vaches ########################################
|
||||
###################################################################################################################
|
||||
message("Début partie vaches")
|
||||
# Vaches actives ayant déjà eu une fin de gestation
|
||||
vaches <- cheptel_ecow$vaches
|
||||
|
||||
# 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
|
||||
vaches <- vaches %>%
|
||||
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)
|
||||
|
||||
# Récupère les produits des vaches actives du cheptel et les embryons portés dans le cheptel
|
||||
produits_vaches <- produits_cheptel %>%
|
||||
filter(numeroMipg %in% vaches$anim)
|
||||
|
||||
# Récupère les effets cheptel # TODO A REVOIR AVEC LAURENA
|
||||
effets <- get_effets_cheptel(produits_vaches)
|
||||
env_ecow$rapport_MF <- effets$rapport_MF
|
||||
env_ecow$effets_chep <- effets$effets_chep
|
||||
|
||||
prod_vaches_corr <- apply_effet_chep(produits_vaches)
|
||||
|
||||
# On récupère les coefficients de pondération pour les pointages au sevrage
|
||||
pps <- env_ecow$params_ponderation$pointage$sevrage
|
||||
|
||||
# Ajout à la table vache des informations synthétisées de leur veaux
|
||||
synth_vaches <- get_synth_prod_vaches(vaches, prod_vaches_corr)
|
||||
|
||||
# calcul des stats, valeurs extremes et references pour la normalisation
|
||||
stats_chep <- get_stats_tbl(
|
||||
tab = synth_vaches,
|
||||
nom_tab = "vaches",
|
||||
cols = c("agevel1", "ivv1", "ivv2Brut", "prol", "mort", "txrepros", "nbpp_corr", "txvf", "txmales", "ptgP", "pn_corr", "p120_corr", # TODO attention aux champs texte
|
||||
"p210_corr", "pad", "ptgV", "age_years", "tempsprod", "pn_m", "pn_f", "p120_m", "p120_f", "p210_m", "p210_f", "nbpp")
|
||||
)
|
||||
|
||||
#################################### 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), # ------------------------------------------------------------------------- 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"
|
||||
)
|
||||
|
||||
# Récupère le nom du père
|
||||
synth_prod_vache <- synth_prod_vache %>%
|
||||
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(env_ecow$params_ponderation$campagne$final)
|
||||
pond_camp_ahp <- unlist(env_ecow$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 %>%
|
||||
filter(ecowcamp > 10) %>%
|
||||
group_by(numeroMipg) %>%
|
||||
summarise(moyecowcamp = round(mean(ecowcamp, na.rm = TRUE), 1), .groups = "drop")
|
||||
|
||||
# 3) Fusion + transformations
|
||||
v_camp <-synth_vaches %>%
|
||||
left_join(moy_camp, by = c("anim" = "numeroMipg")) %>%
|
||||
mutate(
|
||||
rg_camp = as.integer(rank(1 / moyecowcamp, na.last='keep'))
|
||||
)
|
||||
|
||||
message("Enregistrement données vaches")
|
||||
|
||||
# Enregistrement des données des vaches en base
|
||||
save_data_vaches(v_camp)
|
||||
|
||||
# Enregistrement des données de campagne en base
|
||||
save_data_campagne(synth_prod_vache_n)
|
||||
|
||||
if (step == 1) {
|
||||
t1 <- Sys.time()
|
||||
message("Fin du traitement. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec")
|
||||
return(invisible(NULL))
|
||||
}
|
||||
|
||||
###################################################################################################################
|
||||
#################################### Calcul ecow pour les taureaux ########################################
|
||||
###################################################################################################################
|
||||
message("Début partie taureaux")
|
||||
# Recupère les produits des taureaux
|
||||
produits_taureaux <- produits_cheptel %>%
|
||||
filter(pereGenetique %in% taureaux$anim & embryon != 'O')
|
||||
|
||||
# Récupères les filles des taureaux
|
||||
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)
|
||||
|
||||
# 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_filles_taureaux <- get_synth_prod_vaches(filles_taureaux, pprod_filles_taureaux)
|
||||
|
||||
# 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 <- 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(mean(mortsev == "O" | mortnat == "O") * 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), # TODO -------- a voir avec Lauréna, pq dm pour mal et ds pour femelle ? Faut-il ajouter af ?
|
||||
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"
|
||||
)
|
||||
|
||||
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 / n() * 100, 1),
|
||||
|
||||
isu_fillesact = ifelse(n() >= 3, round(mean(embryon, na.rm = TRUE), 1), NA),
|
||||
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"
|
||||
)
|
||||
|
||||
inventaire <- bind_rows(cheptel_ecow$vaches, cheptel_ecow$produits)
|
||||
inventaire <- add_data_ecow(inventaire, czhbc)
|
||||
stats_filles_renouv <- inventaire %>%
|
||||
filter(
|
||||
sexe == "2",
|
||||
NBPRODIPG == 0
|
||||
) %>%
|
||||
group_by(pereGenetique) %>%
|
||||
summarise(
|
||||
nbfilles_renouv = n(),
|
||||
.groups = "drop"
|
||||
)
|
||||
|
||||
stats_taureaux <- stats_peres %>%
|
||||
left_join(stats_prod_directe, by = "pereGenetique") %>%
|
||||
left_join(stats_filles, by = "pereGenetique") %>%
|
||||
left_join(stats_filles_act, by = "pereGenetique") %>%
|
||||
left_join(stats_filles_renouv, by = "pereGenetique") %>%
|
||||
left_join(taureaux, by = "pereGenetique")
|
||||
|
||||
save_data_taureau(stats_taureaux, cheptel)
|
||||
|
||||
if (step == 2) {
|
||||
t1 <- Sys.time()
|
||||
message("Fin du traitement. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec")
|
||||
return(invisible(NULL))
|
||||
}
|
||||
|
||||
###################################################################################################################
|
||||
#################################### Remontee des lignees femelles ########################################
|
||||
###################################################################################################################
|
||||
|
||||
fondatrices <- cheptel_ecow$fondatrices
|
||||
descendants <- cheptel_ecow$descendants
|
||||
|
||||
vaches_lignees <- descendants %>%
|
||||
filter(anim %in% descendants$mereIpg)
|
||||
produits_lignees <- add_data_ecow(
|
||||
descendants %>%
|
||||
filter(mereIpg %in% descendants$anim)
|
||||
)
|
||||
#
|
||||
# # TODO quel effet chep ? Comment on l'applique ?
|
||||
#
|
||||
# synth_vaches_lignees <- get_synth_prod_vaches(vaches_lignees, produits_lignees)
|
||||
#
|
||||
# # 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 %>%
|
||||
# left_join(stats_fem_tot, by = "fondatrice") %>%
|
||||
# left_join(stats_fem_act, by = "fondatrice") %>%
|
||||
# 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)) %>%
|
||||
# left_join(
|
||||
# stats_lignees %>% mutate(fondatrice = trim_str(fondatrice)),
|
||||
# by = c("anim" = "fondatrice")
|
||||
# )
|
||||
#
|
||||
# save_data_lignees(stats_lignees_final)
|
||||
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