diff --git a/R/common/prepare_data.R b/R/common/prepare_data.R index 1a89e5b..8201ea9 100755 --- a/R/common/prepare_data.R +++ b/R/common/prepare_data.R @@ -8,6 +8,7 @@ suppressPackageStartupMessages({ #' @param tab_anims dataframe. Liste d'animaux brute #' @return Liste d'animaux nettoyée clean_data_anims<- function(tab_anims){ + if (nrow(tab_anims) == 0) return() result_data <- tab_anims %>% mutate( dateNaiss = as.Date(as.POSIXct(dateNaiss / 1000, origin = "1970-01-01", tz = "UTC")), diff --git a/R/common/ws_client.R b/R/common/ws_client.R index b2504b2..ca4f46d 100755 --- a/R/common/ws_client.R +++ b/R/common/ws_client.R @@ -35,6 +35,7 @@ http_get <- function(url, method = "GET", params = NULL, headers = NULL, auth = get_cheptel_ecow <- function(num_cheptel){ url_active_by_chep <- paste0(server_path, "webresources/animals/findInventaireEcowByChep/") active_by_chep <- http_get(url = paste0(url_active_by_chep, num_cheptel)) + if(nrow(active_by_chep$vaches) == 0 ) return(active_by_chep) donneuses <- active_by_chep$donneuses active_by_chep$donneuses <- NULL # Nettoyage des données pour les listes reçues diff --git a/R/project/ecow_calculations.R b/R/project/ecow_calculations.R index 5ed64b9..ee9a6f9 100755 --- a/R/project/ecow_calculations.R +++ b/R/project/ecow_calculations.R @@ -19,6 +19,8 @@ source(here::here("R/project/preprocessing.R")) #' @param cheptel character. Numéro du cheptel avec le FR devant calcul_ecow_by_chep <- function(cheptel, step = 3) { t0 <- Sys.time() + + ###################################### Préparation des données ########################################## # Récupère les paramètres de pondération params_ponderation <- get_params_ponderation(cheptel) @@ -28,13 +30,15 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { 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 + if (length(vaches) == 0) { + t1 <- Sys.time() + message("Arrêt du traitement, aucunes vaches à traiter. Temps d'exécution : ", round(difftime(t1, t0, units = "secs"), 2), " sec") + return(invisible(NULL)) + } + # 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 @@ -43,14 +47,19 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { 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) + + + ################################################################################################################### + #################################### Calcul ecow pour les vaches ######################################## + ################################################################################################################### + message("Début partie vaches : ", length(vaches), " vaches à traiter.") + # Ajout info donneuses donneuses <- cheptel_ecow$donneuses vaches$donneuse <- vaches$anim %in% donneuses - # 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) @@ -80,14 +89,14 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { synth_prod_vache <- prod_vaches_corr %>% group_by(numeroMipg, dateNaiss, rangVelageMipg) %>% summarise( - ivv = first(ivv1), # ------------------------------------------------------------------------- vraiment pas sure, à valider + ivv = first(ivv1), # ------------------------------------------------------------------------- TODO 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 + 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), @@ -221,9 +230,14 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { message("Enregistrement données vaches") # Enregistrement des données des vaches en base + v_camp <- v_camp %>% + mutate(across(where(is.numeric), ~ trunc(.x * 100) / 100)) + save_data_vaches(v_camp) # 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) if (step == 1) { @@ -250,10 +264,10 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { # 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, params_ponderation, stats_chep) + synth_ft <- get_synth_prod_vaches(filles_taureaux, pprod_filles_taureaux, params_ponderation) + synth_filles_taureaux <- synth_ft$synthese # Calcul des stats par pere - stats_peres <- produits_taureaux %>% group_by(pereGenetique) %>% summarise( @@ -261,7 +275,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { .groups = "drop" ) %>% filter(nb_prod_in_chep >= 5) - + stats_prod_directe <- produits_taureaux %>% group_by(pereGenetique) %>% summarise( @@ -286,14 +300,14 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { 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 ? + 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" ) - + stats_filles <- synth_filles_taureaux %>% group_by(pereGenetique) %>% summarise( @@ -320,7 +334,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { .groups = "drop" ) - + stats_filles_act <- synth_filles_taureaux %>% filter(is.na(dateSortDetenteur)) %>% group_by(pereGenetique) %>% @@ -328,7 +342,7 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { 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), + 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), @@ -370,6 +384,14 @@ calcul_ecow_by_chep <- function(cheptel, step = 3) { 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)) + save_data_taureau(stats_taureaux, cheptel) if (step == 2) { diff --git a/R/project/postprocessing.R b/R/project/postprocessing.R index e5afd60..9c52c93 100755 --- a/R/project/postprocessing.R +++ b/R/project/postprocessing.R @@ -166,7 +166,7 @@ save_data_taureau <- function(data_taureaux, cheptel){ # Stockage des données écow_taureaux filtered_taureaux <- data_taureaux %>% select( - cheptelDetenteur, pereGenetique, nb_prod_in_chep, utilgen, prol, mort, txrepros, nbpp, txvf, pnm, pnf, p120m, p120f, p210m, p210f, + 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, @@ -175,7 +175,7 @@ save_data_taureau <- function(data_taureaux, cheptel){ ) colnames(filtered_taureaux) <- c( - "cheptel", "anim", "nb_prod_in_chep", "utilgen", "prol", "mort", "txrepros", "nbpp", "txvf", "pnm", "pnf", "p120m", "p120f", "p210m", "p210f", + "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", diff --git a/R/project/preprocessing.R b/R/project/preprocessing.R index 6a337d7..31c7d01 100755 --- a/R/project/preprocessing.R +++ b/R/project/preprocessing.R @@ -12,6 +12,7 @@ source(here::here('R/common/utils.R')) add_data_ecow <- function(liste_produits, czhbc){ #Ajout d'une colonne avec le nombre de produits IPG ------------------ TODO PEUT ETRE PLUS UTILE, à comparer avec nb_fin_gestation + # Croisement avec les données SPIE parents_ipg <- get_parents_ipg() liste_produits <- base::merge(liste_produits, get_parents_ipg(), by.x='anim', by.y='ANIM', all.x=T, all.y=F)