[éCow] Ajout partie lignées

R/project/preprocessing.R

@@ -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)))
+}