From 265e5f1db63059bb86d02b8dd8b0fe33b62a291f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9a?= Date: Mon, 8 Jun 2026 16:16:27 +0200 Subject: [PATCH] Mise en place projet R --- .Rprofile | 3 + .gitignore | 12 + DESCRIPTION | 9 + Dockerfile | 13 + R/api/plumber.R | 47 + R/common/db_client.R | 29 + R/common/logging.R | 13 + R/common/prepare_data.R | 101 + R/common/utils.R | 12 + R/common/ws_client.R | 225 ++ R/notes.R | 210 ++ R/project/Untitled.R | 7 + R/project/ecow_calculations.R | 523 +++++ R/project/old_commente.R | 3746 +++++++++++++++++++++++++++++++ R/project/old_ecow_general.R | 3705 ++++++++++++++++++++++++++++++ R/project/old_ecow_individuel.R | 3436 ++++++++++++++++++++++++++++ R/project/postprocessing.R | 195 ++ R/project/preprocessing.R | 305 +++ README.md | 30 + config/config.yml | 7 + config/logging.yml | 2 + r-microservice.Rproj | 13 + scripts/run.R | 13 + tests/testthat.R | 26 + tests/testthat/test_calculs.R | 9 + tests/testthat/test_db.R | 3 + tests/testthat/test_ws.R | 3 + 27 files changed, 12697 insertions(+) create mode 100755 .Rprofile create mode 100755 .gitignore create mode 100755 DESCRIPTION create mode 100755 Dockerfile create mode 100755 R/api/plumber.R create mode 100755 R/common/db_client.R create mode 100755 R/common/logging.R create mode 100755 R/common/prepare_data.R create mode 100755 R/common/utils.R create mode 100755 R/common/ws_client.R create mode 100644 R/notes.R create mode 100755 R/project/Untitled.R create mode 100755 R/project/ecow_calculations.R create mode 100755 R/project/old_commente.R create mode 100755 R/project/old_ecow_general.R create mode 100755 R/project/old_ecow_individuel.R create mode 100755 R/project/postprocessing.R create mode 100755 R/project/preprocessing.R create mode 100755 README.md create mode 100755 config/config.yml create mode 100755 config/logging.yml create mode 100755 r-microservice.Rproj create mode 100755 scripts/run.R create mode 100755 tests/testthat.R create mode 100755 tests/testthat/test_calculs.R create mode 100755 tests/testthat/test_db.R create mode 100755 tests/testthat/test_ws.R diff --git a/.Rprofile b/.Rprofile new file mode 100755 index 0000000..93ec078 --- /dev/null +++ b/.Rprofile @@ -0,0 +1,3 @@ +options(stringsAsFactors = FALSE) +# Réduire le bruit de readr si utilisé plus tard +options(readr.show_col_types = FALSE) diff --git a/.gitignore b/.gitignore new file mode 100755 index 0000000..17e6db1 --- /dev/null +++ b/.gitignore @@ -0,0 +1,12 @@ +.Rhistory +.RData +.Rproj.user/ +.Renviron +.Ruserdata +.DS_Store +*.log +*/.DS_Store +.Rproj.user +.httr-oauth +.quarto +.positai diff --git a/DESCRIPTION b/DESCRIPTION new file mode 100755 index 0000000..46a2f1d --- /dev/null +++ b/DESCRIPTION @@ -0,0 +1,9 @@ +Package: rMicroserviceSkeleton +Type: Project +Title: Squelette de microservice R (Plumber) +Version: 0.0.1 +Authors@R: person(given = "Léa", family = "CIMETIERE", role = c("aut","cre")) +Description: Squelette prêt pour exposer des calculs R via API et écrire en base. +Depends: R (>= 4.2.0) +Encoding: UTF-8 +LazyData: true diff --git a/Dockerfile b/Dockerfile new file mode 100755 index 0000000..7114d7e --- /dev/null +++ b/Dockerfile @@ -0,0 +1,13 @@ +FROM rocker/r-ver:4.3 + +# Dépendances système (Postgres client libs) +RUN apt-get update && apt-get install -y --no-install-recommends libpq-dev && rm -rf /var/lib/apt/lists/* + +# Packages R requis +RUN R -e "install.packages(c('plumber','jsonlite','httr','DBI','RPostgres','tibble','config','testthat'), repos='https://cloud.r-project.org')" + +WORKDIR /app +COPY . . + +EXPOSE 8080 +CMD ["Rscript", "scripts/run.R"] diff --git a/R/api/plumber.R b/R/api/plumber.R new file mode 100755 index 0000000..c1cac6c --- /dev/null +++ b/R/api/plumber.R @@ -0,0 +1,47 @@ +# Point d'entrée du routeur Plumber +source(here::here('R/project/ecow_calculations.R')) +source(here::here('R/project/Untitled.R')) +source(here::here('R/project/postprocessing.R')) + +API_KEY <- 'mon_super_token_long_et_secret' + +#* @filter authenticate +authenticate <- function(req, res) { + + api_key_req <- req$args$RAPIKEY + api_key_ref <- API_KEY + + if (is.null(api_key_req) || api_key_req != api_key_ref) { + res$status <- 401 + return(list(error = "Unauthorized")) + } + + forward() +} + +#' Fonction pour tester appel de l'API +#' @get /admin/test +#' @serializer json +test <- function() { + ma_fonction() +} + +#' @get /ecow/cheptel/ +#' @param cheptel:number +#' @serializer unboxedJSON +maj_ecow_chep <- function(cheptel) { + maj_ecow_by_cheptel(cheptel) +} + +#' @get /ecow/tech/ +#' @param tech:number +#' @serializer unboxedJSON +maj_ecow_tech <- function(tech) { + maj_ecow_by_tech(tech) +} + +#' @get /ecow/all +#' @serializer unboxedJSON +maj_ecow_all <- function() { + maj_ecow_for_all() +} \ No newline at end of file diff --git a/R/common/db_client.R b/R/common/db_client.R new file mode 100755 index 0000000..dbd7fc5 --- /dev/null +++ b/R/common/db_client.R @@ -0,0 +1,29 @@ +#' Client base de données Postgres (réutilisable) +suppressPackageStartupMessages({ + library(DBI) + library(RPostgres) + library(config) +}) + +db_connect <- function() { + cfg <- config::get('database') + DBI::dbConnect( + RPostgres::Postgres(), + dbname = cfg$dbname, + host = cfg$host, + port = cfg$port, + user = cfg$user, + password = cfg$password + ) +} + +insert_results <- function(df, table = 'results_table') { + conn <- db_connect() + on.exit(DBI::dbDisconnect(conn), add = TRUE) + tryCatch({ + DBI::dbWriteTable(conn, table, df, append = TRUE, row.names = FALSE) + list(success = TRUE, code = 0) + }, error = function(e) { + list(success = FALSE, code = 500, message = conditionMessage(e)) + }) +} diff --git a/R/common/logging.R b/R/common/logging.R new file mode 100755 index 0000000..4680de9 --- /dev/null +++ b/R/common/logging.R @@ -0,0 +1,13 @@ + #' Logging minimaliste (stdout) + log_info <- function(msg, ...) { + cat(sprintf('[INFO ] %s - %s +', format(Sys.time(), '%Y-%m-%d %H:%M:%S'), sprintf(msg, ...))) + } + log_warn <- function(msg, ...) { + cat(sprintf('[WARN ] %s - %s +', format(Sys.time(), '%Y-%m-%d %H:%M:%S'), sprintf(msg, ...))) + } + log_error <- function(msg, ...) { + cat(sprintf('[ERROR] %s - %s +', format(Sys.time(), '%Y-%m-%d %H:%M:%S'), sprintf(msg, ...))) + } diff --git a/R/common/prepare_data.R b/R/common/prepare_data.R new file mode 100755 index 0000000..442ea63 --- /dev/null +++ b/R/common/prepare_data.R @@ -0,0 +1,101 @@ +# Fichier contenant toutes les fonctions communes de nettoyage et mise en forme des données +suppressPackageStartupMessages({ + library(dplyr) + library(tidyr) +}) + +#' #' Nettoie une liste d'animaux hbcanim -------------------------------ANCIENNE VERSION +#' #' @param tab_anims dataframe. Liste d'animaux brute +#' #' @return Liste d'animaux nettoyée +#' clean_data_anims<- function(tab_anims, num_cheptel){ +#' result_data <- tab_anims %>% +#' select(numero, chantiersPointage) %>% +#' unnest(chantiersPointage, names_sep = "_", keep_empty = TRUE) %>% +#' +#' # garder le dernier chantier adulte avant d'unnest les codes +#' filter(chantiersPointage_typePointage == "Adulte") %>% +#' group_by(numero) %>% +#' arrange(desc(chantiersPointage_datePointage)) %>% +#' slice(1) %>% +#' ungroup() %>% +#' +#' # maintenant seulement on unnest les codes du chantier sélectionné +#' unnest(chantiersPointage_pointages, names_sep = "_", keep_empty = TRUE) %>% +#' +#' pivot_wider( +#' names_from = chantiersPointage_pointages_codePointage, +#' values_from = chantiersPointage_pointages_notePointage, +#' names_glue = "{.name}_adulte" +#' ) %>% +#' mutate(across(any_of(c("DM_adulte", "DS_adulte", "AF_adulte")), as.numeric)) +#' +#' result <- tab_anims %>% +#' left_join(result_data, by = "numero") +#' } + + +#' Nettoie une liste d'animaux hbcanim +#' @param tab_anims dataframe. Liste d'animaux brute +#' @return Liste d'animaux nettoyée +clean_data_anims<- function(tab_anims){ + result_data <- tab_anims %>% + mutate( + # across(c("dmAdulte", "dsAdulte", "afAdulte", "pat12M", "pat18M", "pat24M", "rangVelageMipg", "fiabIiv1", "fiabIvv2Corr", "agevel1", "pat120", "pat210", + # "pat120Corrige", "pat210Corrige", "dmSevrage", "dsSevrage", "afSevrage", "nbVelageVeauxDeclares", "nbFinGestation"), as.numeric), + dateNaiss = as.Date(as.POSIXct(dateNaiss / 1000, origin = "1970-01-01", tz = "UTC")), + dateSortDetenteur = as.Date(as.POSIXct(dateSortDetenteur / 1000, origin = "1970-01-01", tz = "UTC")) + ) +} + +#' Nettoie une liste d'animaux hbcanim -----------------------------NORMALEMENT PLUS UTILISE CAR clean_data_anims +#' TODO A TESTER MAJ 19/03 Encore utile ? +#' @param produits dataframe. Liste d'animaux brute +#' @return Liste d'animaux reformatée +clean_produits <- function(produits){ + produits <- produits %>% + mutate( + # Dates + across(c(dateNaissance, dateSortie), ~ as.Date(.x, format = "%Y-%m-%d")), + # Nettoyage chaînes : trim + squish (supprime espaces multiples) + numero = str_squish(numero), #TODO appliquer un squish sur l'appel au numéro des parents + # Numériques (tolérant aux NA / strings) + across( + c(ravelamere, campagneNaissance, poidsNaissance, pat120, pat210), #TODO on avait un ivv aussi mais comme maintenant c'est un objet je l'ai enlevé (19/03), enlevé aptfon aussi car à priori pas utilisé + ~ suppressWarnings(as.numeric(.x)) + ) + ) %>% + unnest(chantiersPointage, names_sep = "_", keep_empty = TRUE) %>% + unnest(chantiersPointage_pointages, names_sep = "_", keep_empty = TRUE) %>% + filter(chantiersPointage_typePointage == "Sevrage") %>% + pivot_wider( + names_from = chantiersPointage_pointages_codePointage, + values_from = chantiersPointage_pointages_notePointage, + names_glue = "{.name}_sevrage" + ) %>% + mutate(across(any_of(c("DM_sevrage", "DS_sevrage", "AF_sevrage")), as.numeric)) +} + +#' Calcule les effets du cheptel +#' @param num_cheptel character. Numéro du cheptel avec le FR +get_effets_cheptel <- function(produits_chep){ + # Calcul des effets du cheptel : rang de velage et sexe du veau -> voir si on peut utiliser poids naissance corrigé de l'infocentre + effets <- produits_chep %>% + summarise(m_PN = round(mean(poidsNaiss, na.rm=T), 1), + m_p120 = round(mean(pat120, na.rm=T), 1), + m_p210 = round(mean(pat210, na.rm=T), 1), + .by = c(typeMipg, sexe)) + effets$diff_pn <- effets$m_PN - subset(effets, effets$sexe == '1' & effets$typeMipg == 'V')$m_PN[1] + effets$diff_p120 <- effets$m_p120 - subset(effets, effets$sexe == '1' & effets$typeMipg == 'V')$m_p120[1] # idem infocentre pour val corrigée + effets$diff_p210 <- effets$m_p210 - subset(effets, effets$sexe == '1' & effets$typeMipg == 'V')$m_p210[1] # idem infocentre pour val corrigée + + # calcul des effets du cheptel : sexe sur la repro -> à faire !!!!! Calcule la diff moyen nb prod vache et nb prod taureau + # voir pour corriger ces effets en prenant tous les veaux en compte pour vache actives, taureaux et lignées femelles + effetsexe <- produits_chep %>% filter(NBPRODIPG > 0) %>% group_by(sexe) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexe == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexe == '2')$nbpp_med[1], 0) + list(rapport_MF = rapport_MF, effets_chep = effets) +} diff --git a/R/common/utils.R b/R/common/utils.R new file mode 100755 index 0000000..4878ef8 --- /dev/null +++ b/R/common/utils.R @@ -0,0 +1,12 @@ +#' Utilitaires transversaux +`%||%` <- function(a, b) if (is.null(a)) b else a + +safe_numeric <- function(x) { + suppressWarnings(as.numeric(x)) +} + +validate_numeric <- function(x, name = 'values') { + if (is.null(x)) stop(sprintf("Champ '%s' manquant", name)) + if (!is.numeric(x)) stop(sprintf("Champ '%s' doit être numérique", name)) + invisible(TRUE) +} diff --git a/R/common/ws_client.R b/R/common/ws_client.R new file mode 100755 index 0000000..05baa6e --- /dev/null +++ b/R/common/ws_client.R @@ -0,0 +1,225 @@ +#' Clients HTTP génériques (réutilisables) +suppressPackageStartupMessages({ + library(httr) + library(jsonlite) + library(tidyverse) +}) +source(here::here("R/common/prepare_data.R")) + +#environnement <- "prod" +environnement <- "recette" +#environnement <- "local" + +if(environnement == "prod"){ + server_path <- "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/" + + infos_con <- list( + drv = RPostgres::Postgres(), + dbname = "hbc", + host = "10.1.225.66", + user = "client_prod", + password = "vYl9Z^@k9rGTTOG~T1rR" + ) +} else if(environnement == "recette"){ + server_path <- "https://recette.tomcat.racecharolaise.fr/HbcSchedulerAndServices-2.0-SNAPSHOT/" + + infos_con <- list( + drv = RPostgres::Postgres(), + dbname = "hbc-R7", + host = "10.1.234.197", + user = "client_recette", + password = "3J3d7nbZ7E4neP" + ) + +} else { + server_path <- "http://localhost:8080/HbcSchedulerAndServices/" + + infos_con <- list( + drv = RPostgres::Postgres(), + dbname = "hbc-R7", + host = "10.1.234.197", + user = "client_recette", + password = "3J3d7nbZ7E4neP" + ) +} + + +#' Fonction d'appel des webservices +http_get <- function(url, method = "GET", params = NULL, headers = NULL, auth = NULL, timeout_sec = 500) { + req <- httr::VERB( + verb = method, + url = url, + query = if (method == "GET") params else NULL, + body = if (method != "GET") params else NULL, + encode = "json", + httr::add_headers(.headers = headers), + httr::timeout(timeout_sec), + if (!is.null(auth)) httr::authenticate(auth$user, auth$password) else NULL + ) + # Si HTTP status >= 400 => stop() automatique + httr::stop_for_status(req) + + txt <- httr::content(req, as = "text", encoding = "UTF-8") + if (!nzchar(txt)) { + stop("HTTP_OK_BUT_EMPTY: la réponse est vide (pas de contenu).") + } + jsonlite::fromJSON(txt, simplifyVector = TRUE) +} + +#' Renvoie les animaux utilisé dans éCow pour un cheptel +#' @param num_cheptel Code du cheptel avec le FR +#' @return Liste de vache, Liste de taureaux, liste de produits et liste de petits produits +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)) + # Nettoyage des données pour les listes reçues + active_by_chep <- lapply(active_by_chep, clean_data_anims) +} + +#' Renvoie la liste des adhérents HBC actifs dans Dolibarr +#' @return Liste d'adhérents +get_all_adherents_active <- function(){ + url_adh_active_hbc <- paste0(server_path,"webresources/dolibarr/membersActiv") + activ_adh <- http_get(url = url_adh_active_hbc) +} + +#' Renvoie la liste des cheptels suivis par un technicien +#' @param tech character. Identifiant à 5 lettres du technicien +#' @return Liste de cheptels +get_cheptels_by_tech <- function(tech){ + url_cheps_tech <- paste0(server_path,"app/cheptelApp/getListeCheptelByTech/") + activ_adh <- http_get( + url = paste0(url_cheps_tech,tech) + ) +} + +#' Renvoie la liste des certificats zoo totaux (Vivants + semences + embryons) +#' @return Liste de cz +get_cztotaux <- function(){ + url_czAV <- paste0(server_path,"webresources/zootechnique/getListCertifsAV/all") + czAV <- http_get(url = url_czAV) + + url_czS <- paste0(server_path,"webresources/zootechnique/getListCertifsS/all") + czS <- http_get(url = url_czS) + + url_czE <- paste0(server_path,"webresources/zootechnique/getListCertifsE/all") + czE <- http_get(url = url_czE) + + c(czAV$animal, czS$animal, czE$animalo) +} + +########################################################################################### + +# Retourne les informations de connection à la base +get_db_connection <- function() { + do.call(DBI::dbConnect, infos_con) +} + +# Fonction pour vérifier si un cheptel a déjà des données +cheptel_has_ponderation <- function(con, num_cheptel) { + query <- paste0( + "SELECT count(*) FROM hbc.ecow_ponderations WHERE cheptel = '", num_cheptel,"'" + ) + count <- dbGetQuery(con, query)$count + return(count > 0) +} + +#' Met en forme les données issues de la BDD pour qu'elles soient directement interrogeable +#' +format_ponderation <- function(df) { + df %>% + mutate(sous_categorie = ifelse(is.na(sous_categorie), "NA", sous_categorie)) %>% + group_by(categorie, sous_categorie) %>% + summarise(valeurs = list(as.list(setNames(valeur, variable))), .groups = "drop") %>% + group_by(categorie) %>% + summarise( + sous_cats = list( + if (n() == 1 && first(sous_categorie) == "NA") + valeurs[[1]] # Pas de sous-catégorie : retourne la liste nommée + else + setNames(valeurs, sous_categorie) # Avec sous-catégories : liste de listes nommées + ), + .groups = "drop" + ) %>% + deframe() %>% + map(~ if (is.list(.x) && length(.x) == 1 && names(.x) == "NA") .x[[1]] else .x) +} + +#' Renvoie la liste des paramètres de pondération pour un éleveur +#' @param num_cheptel character. Numero de cheptel avec le FR +get_params_ponderation <- function(num_cheptel){ + + num_cheptel <- 'FR03142115' + + con <- get_db_connection() + + # Si le cheptel n'a pas de paramètres de pondération personnalisés, on récupère ceux par défaut + if (!cheptel_has_ponderation(con, num_cheptel)) { + num_cheptel <- 'default' + } + + # Récupérer les données + query <- paste0("SELECT categorie, sous_categorie, variable, valeur FROM hbc.ecow_ponderations WHERE cheptel = '", num_cheptel,"'") + data <- dbGetQuery(con, query) + dbDisconnect(con) + + return(format_ponderation(data)) +} + +####################################################################################################### +###################### Rien a voir avec ecow - WS pedigree de Pauline ################################# +fake <- function(){ + library(httr) + library(jsonlite) + + animalIds <- c("FR7122418163","FR7122406165", "FR7122363258", "FR7122234414", "FR0311285868", "FR7122363239", "FR7122363251", "FR7122380260", "FR7122380284", "FR7122363268") + + body <- list( + animalsIds = animalIds, + #nbGenerations = 5, + voieFemelle = TRUE, + cheptel = "FR71499477" + ) + + response <- POST( + #url = "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/getpedigreebyanimlist/", + url = "http://localhost:8080/HbcSchedulerAndServices/webresources/animals/getpedigreebyanimlist", + body = toJSON(body, auto_unbox = TRUE, null = "null"), + encode = "json" + ) + + animalIds <- c("FR0800761491","FR0800761869") + + body <- list( + animalsIds = animalIds, + voieFemelle = TRUE, + cheptel = "FR08021009" + ) + + response <- POST( + #url = "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/getfondatrices/", + url = "http://localhost:8080/HbcSchedulerAndServices/webresources/animals/getfondatrices", + body = toJSON(body, auto_unbox = TRUE, null = "null"), + encode = "json" + ) + + result <- content(response, "parsed", encoding = "UTF-8") + print(result) +} + +######################################################################################################## +######################################################################################################## + +#' TODO Pour l'instant on récupère la dernière extraction, à terme il faudra récupérer l'intégration SPIE +#' ATTENTION problème import fichier à cause des \ User !!!!!!!!!!!!!!!!!!!!!!!!!!! +get_parents_ipg <- function(){ + rep_imp <- "/home/lea/Documents/ecow/" + + meresIPG <- read_csv(paste(rep_imp, "nb_prod_IPG_byMERE_20260106.csv", sep='')) # ok 20230327 + colnames(meresIPG) <- c('ANIM','NBPRODIPG') + + peresIPG <- read_csv(paste(rep_imp, "nb_prod_IPG_byPERE_20260106.csv", sep='')) # ok 20230327 + colnames(peresIPG) <- c('ANIM','NBPRODIPG') + + parentsIPG <- rbind(meresIPG, peresIPG) +} diff --git a/R/notes.R b/R/notes.R new file mode 100644 index 0000000..9078efb --- /dev/null +++ b/R/notes.R @@ -0,0 +1,210 @@ +################################################################################################################### +################# REFACTO COPILOT A VALIDER pour double boucle for sur les vaches ####################### +################################################################################################################### + +# ========================= +# Helpers (normalisations) +# ========================= + +# Normalisation vs stats cheptel: 1 = max +norm_chep <- function(x, var) { + r <- stats_chep %>% dplyr::filter(var == !!var) + if (nrow(r) == 0) return(rep(NA_real_, length(x))) + mmin <- r$min[1]; mmax <- r$max[1] + 1 - (abs(mmax - x) / abs(mmax - mmin)) +} + +# ========================= +# 1) Synthèse veaux par mère +# ========================= +veaux_summary <- PROD %>% + group_by(mere) %>% + summarise( + n_veaux = n(), + + # plage de campagnes velages (max - min + 1), robustes aux NA + campn_min = {cn <- campn[!is.na(campn)]; if (length(cn)) min(cn) else NA_integer_}, + campn_max = {cn <- campn[!is.na(campn)]; if (length(cn)) max(cn) else NA_integer_}, + nbcampvel = ifelse(!is.na(campn_min) & !is.na(campn_max), + campn_max - campn_min + 1, NA_integer_), + + # age au 1er vêlage et IVV1 (première occurrence) + agevel1 = {x <- agevel[ravelamere == 1]; if (length(x)) x[1] else NA_real_}, + ivv1 = {x <- ivv[ravelamere == 2]; if (length(x)) x[1] else NA_real_}, + ivv2p = round(mean(ivv[ravelamere > 2], na.rm = TRUE), 1), + + # date du dernier anais (dernier événement) + last_danais = {d <- danais[!is.na(danais)]; if (length(d)) max(d) else as.Date(NA)}, + + # moyennes nécessaires pour ptgP et précocité + mean_devmus = mean(devmus, na.rm = TRUE), + mean_devsqe = mean(devsqe, na.rm = TRUE), + mean_diff_dev = mean(devsqe - devmus, na.rm = TRUE), + + # indicateurs produits + mort = round(sum(mortsev == "O", na.rm = TRUE) / n_veaux * 100, 1), + txrepros = round(sum(repro == "O", na.rm = TRUE) / n_veaux * 100, 1), + nbpp = sum(NBPRODIPG, na.rm = TRUE), + nbpp_corr = sum(nbpp_corr, na.rm = TRUE), + txmales = round(sum(sexbov == "1", na.rm = TRUE) / n_veaux * 100, 1), + txvf = round(sum(conais %in% c("1","2"), na.rm = TRUE) / n_veaux * 100, 1), + + # moyennes par sexe + pn_m = round(mean(ponais[sexbov == "1"], na.rm = TRUE), 1), + p120_m = round(mean(pat04m[sexbov == "1"], na.rm = TRUE), 1), + p210_m = round(mean(pat07m[sexbov == "1"], na.rm = TRUE), 1), + pn_f = round(mean(ponais[sexbov == "2"], na.rm = TRUE), 1), + p120_f = round(mean(pat04m[sexbov == "2"], na.rm = TRUE), 1), + p210_f = round(mean(pat07m[sexbov == "2"], na.rm = TRUE), 1), + + # versions corrigées + pn_corr = round(mean(pn_corr, na.rm = TRUE), 1), + p120_corr = round(mean(p120_corr, na.rm = TRUE), 1), + p210_corr = round(mean(p210_corr, na.rm = TRUE), 1), + .groups = "drop" + ) + +# ========================= +# 2) Jointure & calculs vaches +# ========================= +v_ref <- vaches %>% + left_join(veaux_summary, by = c("anim" = "mere")) %>% + mutate( + # pointage adulte synthétique + ptgV = ifelse(!is.na(dmC), round(0.6 * dmC + 0.15 * ds + 0.25 * af, 1), NA_real_), + + # précocité & alpha + precocite = ifelse(!is.na(n_veaux) & n_veaux > 3, round(mean_diff_dev, 2), NA_real_), + alpha = ifelse(is.na(precocite), 1.62, 1.62 - 0.01 * precocite), + + # estimation du poids adulte (pad) + pad = dplyr::case_when( + !is.na(pat24m) ~ round((pat24m - 50 * exp(-720 * alpha * 10^(-3))) / (1 - exp(-720 * alpha * 10^(-3))), 1), + !is.na(pat18m) ~ round((pat18m - 50 * exp(-540 * alpha * 10^(-3))) / (1 - exp(-540 * alpha * 10^(-3))), 1), + !is.na(pat12m) ~ round((pat12m - 50 * exp(-360 * alpha * 10^(-3))) / (1 - exp(-360 * alpha * 10^(-3))), 1), + TRUE ~ NA_real_ + ), + + # temps improductif (e2, e3, e4) + e2 = dplyr::case_when( + is.na(ivv1) ~ 0, + ivv1 < 390 ~ 0, + TRUE ~ ivv1 - 390 + ), + e3 = dplyr::case_when( + is.na(ivv2p) ~ 0, + ivv2p < 365 ~ 0, + TRUE ~ ivv2p - 365 + ), + days_since_last = as.numeric(difftime(Sys.Date(), last_danais, units = "days")), + e4 = dplyr::case_when( + is.na(days_since_last) ~ 0, + days_since_last < 365 ~ 0, + TRUE ~ days_since_last - 365 + ), + + # temps productif (%) + tempsprod = round( + (age_days - (agevel1 * 30.4 + e2 + e3 * (nbcampvel - 2) + e4)) / age_days * 100, 1 + ), + + # pointage produits + ptgP = round(0.75 * mean_devmus + 0.25 * mean_devsqe, 1) + ) %>% + # Conversion des NaN en NA sur certaines moyennes + mutate(across( + 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_, .) + )) + +# ========================= +# 3) Normalisations +# ========================= +v_norm <- v_ref %>% + mutate( + # age au 1er vêlage normalisé + agevel1_n = dplyr::case_when( + is.na(agevel1) ~ NA_real_, + agevel1 > 48 ~ 0, + TRUE ~ round( + -2 * (10^(-6)) * (agevel1 * 30.4)^2 + + 0.0027 * (agevel1 * 30.4) + + 8 * (10^(-15)), + 3 + ) + ), + # ivv1 normalisé + ivv1_n = dplyr::case_when( + is.na(ivv1) ~ NA_real_, + ivv1 > 460 ~ 0, + ivv1 < 390 ~ 1, + TRUE ~ round(1 - abs(390 - ivv1) / abs(390 - 460), 3) + ), + # ivv2+ normalisé + ivv2p_n = dplyr::case_when( + is.na(ivv2p) | is.nan(ivv2p) ~ NA_real_, + ivv2p > 435 ~ 0, + ivv2p < 365 ~ 1, + TRUE ~ round(1 - abs(365 - ivv2p) / abs(365 - 435), 3) + ), + # normalisations "cheptel 1 = max" + pad_n = round(norm_chep(pad, "vaches$pad"), 3), + ptgv_n = round(norm_chep(ptgV, "vaches$ptgV"), 3), + txvf_n = round(norm_chep(txvf, "vaches$txvf"), 3), + txm_n = round(norm_chep(txmales, "vaches$txmales"), 3), + txrepros_n = round(norm_chep(txrepros, "vaches$txrepros"), 3), + nbpp_n = round(norm_chep(nbpp_corr, "vaches$nbpp_corr"), 3), + ptgp_n = round(norm_chep(ptgP, "vaches$ptgP"), 3), + p120_n = round(norm_chep(p120_corr, "vaches$p120_corr"), 3), + p210_n = round(norm_chep(p210_corr, "vaches$p210_corr"), 3), + + # prolificité + prol_n = dplyr::case_when( + is.na(prol) ~ NA_real_, + prol >= 100 ~ 1, + prol < 50 ~ 0, + TRUE ~ round(1 - (abs(100 - prol) / abs(100 - 50)), 3) + ), + + # poids naissance corrigé + pn_n = dplyr::case_when( + is.na(pn_corr) ~ NA_real_, + 40 < pn_corr & pn_corr < 50 ~ 1, + 22 > pn_corr | pn_corr > 68 ~ 0, + 22 < pn_corr & pn_corr < 40 ~ round(0.056 * (pn_corr - 22), 3), + TRUE ~ round(1 - 0.056 * (pn_corr - 50), 3) + ), + + # mortalité + mort_n = round(1.0 * exp(-0.031 * mort), 3) + ) + +# ========================= +# 4) Note carrière (pondérée) +# ========================= +weights <- as.numeric(Pcar[1, 2:16]) # 15 pondérations +norm_cols <- c( + "agevel1_n","ivv1_n","ivv2p_n","pad_n","ptgv_n","prol_n","pn_n", + "txvf_n","txm_n","mort_n","txrepros_n","nbpp_n","ptgp_n","p120_n","p210_n" +) + +v_final <- v_norm %>% + rowwise() %>% + mutate( + SOMME_tot = { + x <- c_across(all_of(norm_cols)) + w <- weights + mask <- !is.na(x) & !is.na(w) + if (sum(mask) == 0) NA_real_ else (sum(x[mask] * w[mask]) / sum(w[mask])) * 10 + }, + ecowcarr = if_else( + is.na(ptgp_n) & is.na(p120_n) & is.na(p210_n), # règle d'exclusion VA4 + NA_real_, + round(SOMME_tot * 100, 0) + ) + ) %>% + ungroup() +`` + +################################################################################################################### +############################## FIN DE REFACTO #################################################################### \ No newline at end of file diff --git a/R/project/Untitled.R b/R/project/Untitled.R new file mode 100755 index 0000000..6257cbc --- /dev/null +++ b/R/project/Untitled.R @@ -0,0 +1,7 @@ +# fichier à supprimer, fonction test pour mise en place de l'api +ma_fonction <- function() { + list( + status = "youhou", + time = Sys.time() + ) +} diff --git a/R/project/ecow_calculations.R b/R/project/ecow_calculations.R new file mode 100755 index 0000000..4e987f6 --- /dev/null +++ b/R/project/ecow_calculations.R @@ -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") +} diff --git a/R/project/old_commente.R b/R/project/old_commente.R new file mode 100755 index 0000000..2cd2b24 --- /dev/null +++ b/R/project/old_commente.R @@ -0,0 +1,3746 @@ + +# version finale eCow - 5eme calcul +# LJ - 01/07/2021 + +################################################################################ +### chgt des libraries ######################################################### +################################################################################ + +library(tidyverse) +library(lubridate) +library(jsonlite) + +library(optiSel) +library(staplr) +library(png) +library(grid) + +options(scipen = 999) #permet d'?crire les nombres en entier quand ils sont au format scientifique +# necessaire pour la convertion des dates au format unix + +################################################################################ +### chgt des fichiers et donn?es utiles ######################################## +################################################################################ + +rep_exp <- "C:/Users/LéaCIMETIERE/OneDrive - HERD BOOK CHAROLAIS/Documents/eCow/Fichiers de Lauréna JEANNOT - eCow5/EXPORTS_lc/" + +rep_imp <- "C:/Users/LéaCIMETIERE/OneDrive - HERD BOOK CHAROLAIS/Documents/eCow/Fichiers de Lauréna JEANNOT - eCow5/IMPORTS_R/" + +date_imp <- as.Date("2025-06-18") #date données IPG et embryons + +adhhbc <- read_delim(paste(rep_imp, "adhhbc_20250618.csv", sep=''), # ok 20230327 + ";", escape_double = FALSE, trim_ws = TRUE) + +czhbc <- read_csv(paste(rep_imp, "cz_20250618.csv", sep='')) # ok 20230327 + +#pas utile au final, à enlever +# LETTRES <- read_delim(paste(rep_imp, "LETTRES.csv", sep=''), +# ";", escape_double = FALSE, trim_ws = TRUE) + +#embryons -> infocentre +indite <- read_csv(paste(rep_imp, "indite_20250618.csv", sep=''), # ok 20230327 + col_types = cols(DANAIS = col_date(format = "%Y-%m-%d"))) +indite <- indite[-which(duplicated(indite$ANIM)),] +#$indite <- subset(indite, !is.na(indite$MEREIPG)) + +#infocentre à terme +meresIPG <- read_csv(paste(rep_imp, "nbprodIPG_byMERE_20250618.csv", sep='')) # ok 20230327 +colnames(meresIPG) <- c('ANIM','NBPRODIPG') + +peresIPG <- read_csv(paste(rep_imp, "nbprodIPG_byPERE_20250618.csv", sep='')) # ok 20230327 +colnames(peresIPG) <- c('ANIM','NBPRODIPG') + +parentsIPG <- rbind(meresIPG, peresIPG) + +### liste des webservices ###################################################### + +# appel du listing d'un cheptel +webappli <- "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/findbyactivecheptel/" + +# appel de l'IC pour un animal +hbcanim <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/" + +# appel de hbcgene pour un animal -> à enlever, pas dupliquée +hbcgene <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcgene/" + +# liste des produits d'une vache -tranférer vers nouveau ws +reqMere <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/findstringfieldbynamedquery/Hbcanim.findByMere/" + +# liste des produits d'un taureau +reqPere <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/findstringfieldbynamedquery/Hbcanim.findByPere/" + +# liste des produits d'un animal n?s dans un cheptel cible -> pour taureau IA descendance +reqProdNaiss <- "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/findProductByAnimAndChna/" +# ? completer par anim/chna, ex : FR7121831530/FR71499477 + +#_______________________________________________________________PONDERATIONS AHP +## Ponderations Carriere #### +Pcar=data.frame(type='final', agevel1_n=3, ivv1_n=6, ivv2p_n=12, + ptgv_n=4, pad_n=2, prol_n=2, mort_n=12, + txrepros_n=8, nbpp_n=10, txm_n=1, txvf_n=10, + ptgp_n=6, pn_n=4, p120_n=10, p210_n=10) + +### Ponderations Campagne #### +Pcamp=rbind(data.frame(type='AHPtech', pn_n=5.3, txvf_n=14.9, txm_n=4.5, + ptgp_n=8.2, p120_n=15.1, p210_n=12.6, + prol_n=3.2, mort_n=19.9, ivv_n=16.2), + data.frame(type='final', pn_n=6, txvf_n=15, txm_n=1, + ptgp_n=9, p120_n=15, p210_n=15, + prol_n=3, mort_n=18, ivv_n=18)) +# pond?rations finales ajustees ? partir de l'enquete +# peut etre pas judicieux + +################################################################################ +### fonctions utiles ########################################################### +################################################################################ + +# suppression des espaces superflus +trim_str = function (string) { + gsub("\\s+", " ", gsub("^\\s+|\\s+$", "", string)) +} + +# recuperation de l'inventaire des animaux actifs du cheptel -> get_anims_active_by_cheptel +get_inventaire <- function(cheptel) { + old <- Sys.time() + # liste des animaux du cheptel + lichep <- fromJSON(paste(webappli, cheptel, sep='')) + inventaire <- lichep$hbcanim + # calcul du temps de chargement + new <- Sys.time()-old + cat("Chargement de l'inventaire :", round(new, 1) , "sec \n") + # resultat + return(inventaire) +} + +# mise en forme d'un retour de WS sous forme de dataframe +# necessaire quand l'appel ne concerne qu'un animal car le retour est une liste nomm?e +appel_infos <- function(animal, url_ws, cheptel = NA) { + animal <- trim_str(animal) + if (!is.na(cheptel)) { + li_anim <- try(fromJSON(paste(url_ws, animal, '/', cheptel, sep = '')), silent = TRUE) + } else { + li_anim <- try(fromJSON(paste(url_ws, animal, sep = '')), silent = TRUE) + } + if (inherits(li_anim, "try-error")) { + return(NA) + } else { + if (class(li_anim) == "list" & length(li_anim) > 0) { + li_anim[sapply(li_anim, function(x) length(x) == 0L)] <- NA + df_anim <- as.data.frame(t(unlist(li_anim))) + return(df_anim) + } else if (class(li_anim) == "data.frame") { + return(li_anim) + } + } +} + +# appel des donnees anim en fonction de leur existance +# si animal absent de hbcanim, on va voir dans hbcgene -> plus besoin +chgt_infos <- function(animal) { + # on va chercher la ligne animal dans hbcanim + line_anim <- try(appel_infos(animal, hbcanim), silent = TRUE) + # Si erreur, on va chercher dans hbcgene + if (!is.data.frame(line_anim) | inherits(line_anim, "try-error")) { + line_anim <- appel_infos(animal, hbcgene) + } + return(line_anim) +} + +# fonction de cr?ation d'un dataframe vide +create_df <- function(nbl, liste_nomcol){ + new <- data.frame(matrix(NA, ncol=length(liste_nomcol), nrow=nbl)) + colnames(new) <- liste_nomcol + return(new) +} + +get_stats <- function(tab, nom_tab, col,conditions, nom_cond) { # à simplifier avec summary + if (missing(conditions) & missing(nom_cond)) { + x <- tab + nom_cond <- NA + } else { + x <- subset(tab, conditions) + } + min <- round(min(x[,col], na.rm=TRUE), 1) + q1 <- round(quantile(x[[col]], probs=0.25, na.rm=TRUE), 1) + med <- round(median(x[[col]], na.rm=TRUE), 1) + moy <- round(mean(x[[col]], na.rm=TRUE), 1) + q3 <- round(quantile(x[[col]], probs=0.75, na.rm=TRUE), 1) + max <- round(max(x[,col], na.rm=TRUE), 1) + nbval <- nrow(subset(x, is.na(x[,col]) == FALSE)) + nas <- nrow(subset(x, is.na(x[,col]) == TRUE)) + tab_col <- as.character(paste(nom_tab, col, sep='$')) + sc <- data.frame('var'=tab_col, 'cond'=nom_cond, 'min'=min, 'q1'=q1, + 'med'=med, 'moy'=moy, 'q3'=q3, 'max'=max, 'nbval'=nbval, 'nas'=nas) + rownames(sc) <- '' + return(sc) +} + +# fonction de recuperation des produits d'un taureau +# recup annul?e si taureau d'IA avec bcp de produits ie >275 -> plus utilisée +get_produits_taureau <- function(animal) { + old <- Sys.time() + anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ### + if (!is.na(anim) & (class(anim) == "try-error") == FALSE) { # _______________________________ + if (anim$sexbov[1] == '1') { + if (as.numeric(anim$nbdescendants[1]) >= 275 & anim$taureauia[1] == '1') { + produits <- NA + cat("\n", "Produits non charg?s car taureau d'IA avec production superieure ? 275") + } else if ( (as.numeric(anim$nbdescendants[1]) > 0 + & anim$taureauia[1] == '0') | + (as.numeric(anim$nbdescendants[1]) < 275 + & anim$taureauia[1] == '1') ) { + produits <- try(appel_infos(animal, reqPere), silent=TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + cat("\n", "Produits non charg?s car non disponibles") + produits <- NA + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } else { + produits <- NA + cat("\n", "???") + } + } else { + produits <- NA + cat("\n", "L'animal n'est pas un m?le") + } + } else if ((class(anim) == "try-error") == TRUE) { # _________________________ + cat("\n", "P?re sans ligne individuelle dans HBCANIM") + produits <- try(appel_infos(animal, reqPere), silent = TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + produits <- NA + cat("\n", "Produits non charg?s car non disponibles") + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } + return(produits) +} + +# fonction de recuperation des produits d'une vache +get_produits_vache <- function(animal) { + old <- Sys.time() + anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ### + if ((class(anim) == "try-error") == FALSE) { # _______________________________ + if (anim$sexbov[1] == '2') { + produits <- try(appel_infos(animal, reqMere), silent=TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + cat("\n", "Produits non charg?s car non disponibles") + produits <- NA + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } else { + produits <- NA + cat("\n", "L'animal n'est pas une femelle") + } + } else if ((class(anim) == "try-error") == TRUE) { # _________________________ + produits <- try(appel_infos(animal, reqMere), silent = TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + produits <- NA + cat("\n", "Produits non charg?s car non disponibles") + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } + return(produits) +} + +# fonction de recuperation des produits d'un animal dans un cheptel naisseur +get_produits_in_chep <- function(animal, cheptel) { + old <- Sys.time() + anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ### + if ((class(anim) == "try-error") == FALSE) { # _______________________________ + produits <- try(appel_infos(animal, reqProdNaiss, cheptel), silent=TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + cat("\n", "Produits non charg?s car non disponibles") + produits <- NA + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } else if ((class(anim) == "try-error") == TRUE) { # _________________________ + produits <- try(appel_infos(animal, reqMere), silent = TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + produits <- NA + cat("\n", "Produits non charg?s car non disponibles") + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } + return(produits) +} + +# fonction de modif des formats dates à partir du retour d'un WS -> a voir si besoin selon formats des dates, permettait de palier les chgt format dates ws +change_format_date_unix <- function(dataframe) { + if (is.data.frame(dataframe)){ + # recup des indices de colonnes de dates : commencent par 'da' ou 'DA' + li_ix_dates <- c(grep("^da", colnames(dataframe))) + if (length(li_ix_dates) == 0){ + li_ix_dates <- c(grep("^DA", colnames(dataframe))) + } + # si existance de colonnes de dates : + if (length(li_ix_dates) > 0) { + for(j in li_ix_dates) { + # on recupere les valeurs non nulles + not_na <- c(which(!is.na(dataframe[,j]))) + if(length(not_na) > 0) { + # on verifie que c'est bien un format UNIX + if ( dataframe[not_na[1],j] > 1*(10**8) ) { + # puis on modifie le format + tryCatch({ + dataframe[,j] <- as.Date(as.POSIXct(dataframe[,j] / 1000, origin = "1970-01-01")) + }, + error = function(e){ + next + }) + } else { + #print("Dates pas au format UNIX") + } + } else { + #print("Aucune date non nulle dans cette colonne") + } + } + return(dataframe) + } else { + print("Pas de colonne commençant par 'da'/'DA'") + } + } else { + print("l'objet n'est pas un dataframe") + } +} +### génération du rapport HTML ################################################ + +render_report = function(CHEP, TECH, date_imp) { + print(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), + '/', CHEP, '_rapport_eCow5.html', sep = "")) + rmarkdown::render( + paste(substr(rep_exp, 1, nchar(rep_exp)-10), "eCow5_rapport_v3.Rmd", sep=''), params = list( + CHEP = CHEP, + TECH = TECH, + date_imp = date_imp + ), + output_file = paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), + '/', CHEP, '_rapport_eCow5.html', sep = "") + ) +} + +render_synthese = function(CHEP, TECH, date_imp) { # -> normalement plus besoin mais étapes à vérifier + print(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), + '/', CHEP, '_synthese_eCow5.html', sep = "")) + rmarkdown::render( + paste(substr(rep_exp, 1, nchar(rep_exp)-10), "eCow5_synthese.Rmd", sep=''), params = list( + CHEP = CHEP, + TECH = TECH, + date_imp = date_imp + ), + output_file = paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), + '/', CHEP, '_synthese_eCow5.html', sep = "") + ) +} + +# fonction de création du rapport pour la VN 2021 #### + +# render_vn = function(CHEP, TECH) { +# rmarkdown::render( +# paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/", "test_VN.Rmd", sep=''), +# params = list( +# CHEP = CHEP, +# TECH = TECH +# ), +# output_file = paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/", +# CHEP, '_VN.html', sep = "") +# ) +# } + + +################################################################################ +### fonction du calcul total ################################################### +################################################################################ + + +render_all_fic <- function(cheptel, tech, VN = FALSE) { # cheptel avec le FR, tech = abrev 5 lettres + CHEP <- cheptel # avec le FR + TECH <- tech + + # creation du repertoire d'export + dir.create(path=paste(rep_exp, TECH, '/', CHEP, sep='')) + rep <- paste(rep_exp, TECH, '/' ,CHEP, sep='') + + + ################################################################################ + ### calcul du classement vaches ################################################ + ################################################################################ + CHEP <- "FR71499477" + + OLD=Sys.time() + ## r?cup des animaux de l'inventaire + old <- Sys.time() + + inventaire <- get_inventaire(CHEP) + + if (is.data.frame(inventaire) && nrow(inventaire) > 0 ) { + + # modif du 28/03/2023 : ajout de la verif chepdet = CHEP + inventaire <- inventaire %>% filter(trim_str(chepdet) == CHEP) + + # if ( inventaire$danais[1] > 1*(10**8) ) { + # inventaire$danais <- as.Date(as.POSIXct(inventaire$danais / 1000, origin="1970-01-01")) + # } + #inventaire <- change_format_date_unix(inventaire) + + inventaire$danais <- as.Date(inventaire$danais, format = "%Y-%m-%d") + inventaire$mere <- trim_str(inventaire$mere) + inventaire$pere <- trim_str(inventaire$pere) + inventaire$anim <- trim_str(inventaire$anim) + + inventaire$ds <- as.numeric(inventaire$ds) + inventaire$af <- as.numeric(inventaire$af) + inventaire$dmC <- as.numeric(inventaire$dmC) + + # vaches actives + vaches <- subset(inventaire, + inventaire$sexbov == 2 & inventaire$nbdescendants > 0) + + # recherche des meres dans les porteuses pour aller chercher + # les produits s'ils existent dans HBCANIM + + porteuses <- subset(indite, !is.na(indite$MEREIPG) + & indite$MEREIPG %in% trim_str(vaches$anim)) + donneuses <- subset(indite, !is.na(indite$MERECPB) # ça a priori on en fait rien + & indite$MERECPB %in% trim_str(vaches$anim)) + # l'indicateur de donneuse d'embryon est renseign? apres dans --> vaches$ACINAC colonne non utilisée réutilisée pour stockage donneuse/porteuse + + vaches$age_days <- time_length(interval(vaches$danais, Sys.Date()), unit="days") + vaches$age_years <- round(vaches$age_days / 365, 1) + vaches$acinac <- NA + + # liste de tous leurs produits + produits <- vaches[0,] + + if (nrow(vaches) > 0 ) { + for (i in 1:nrow(vaches)){ + # r?cup des produits dans HBCANIM + temp <- try(fromJSON(paste(reqMere, trim_str(vaches$anim[i]), sep='')), silent = TRUE) + if (inherits(temp, "try-error")) { + temp <- vaches[0,] + } else { + #temp <- fromJSON(paste(reqMere, trim_str(vaches$anim[i]), sep='')) # a voir : gerer les retours vides !!!! + produits <- rbind(produits, temp) + # on annote les donneuses + if( is.data.frame(subset(temp, temp$indite == 'O')) ) { + if (nrow(subset(temp, temp$indite == 'O')) > 0){ + vaches$acinac[i] <- 'DONNEUSE' # a voir si indicateur donneuse dans infocentre + } + } + # ajout d'un nom a la vache si null -> plus besoin + if (is.na(vaches$nobovi[i])) { + lettre <- subset(LETTRES, LETTRES$ANNEE == vaches$campn[i]) + vaches$nobovi[i] <- paste(lettre$LETTRE[1], vaches$nutrav[i], sep='_') + } + } + } + } else { + print("AUCUNE VACHE ACTIVE DANS LE CHEPTEL") + } + + + # les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant -> remplacer le numéro de la mère génétique d'un produit par + # le numéro de la mère porteuse et ajouter les produits qui du coup n'étaient pas dans la liste + # Y a des cas ou le veau est déjà dans la liste si les mères porteuse et donneuse sont dans le même cheptel + # CF schéma de Lauréna + if (nrow(porteuses) > 0) { + for (i in 1:nrow(porteuses)) { + if (!(porteuses$ANIM[i] %in% trim_str(produits$anim))) { #si le veau de la porteuse n'est pas dans les produits + + temp <- appel_infos(porteuses$ANIM[i], hbcanim) #récupère sa ligne dans hbcanim + li_mere <- subset(vaches, vaches$anim == porteuses$MEREIPG[i]) # récupère dans les vaches la ligne de sa mère IPG + + if ( is.data.frame(temp) && nrow(temp) > 0 ) { + temp$mere[1] <- porteuses$MEREIPG[i] #sa mère devient la porteuse + temp[1, c(60:67, 86:103)] <- NA # on supprime les infos qui concernent la mère ? + if ( nrow(li_mere) > 0){ + temp$danaismere[1] <- as.character(li_mere$danais[1]) # remplace date nais mère gen par celle mere porteuse + } + temp$indite[1] <- 'O_corr' # indicateur pour dire que donneuse remplacée par porteuse + + produits <- rbind(produits, temp) + } + } + } + } + + # tous les produits au propre y compris embryons + + # modifs des types de donn?es, pour calcul par la suite + produits$danais <- as.Date(produits$danais, format = "%Y-%m-%d") + produits$dasort <- as.Date(produits$dasort, format = "%Y-%m-%d") + + produits$mere <- trim_str(produits$mere) + produits$pere <- trim_str(produits$pere) + produits$anim <- trim_str(produits$anim) + + produits$ravelamere <- as.numeric(produits$ravelamere) + produits$ivv <- as.numeric(produits$ivv) + produits$campn <- as.numeric(produits$campn) + + produits$ponais <- as.numeric(produits$ponais) + produits$pat04m <- as.numeric(produits$pat04m) + produits$pat07m <- as.numeric(produits$pat07m) + + produits$devsqe <- as.numeric(produits$devsqe) + produits$devmus <- as.numeric(produits$devmus) + produits$aptfon <- as.numeric(produits$aptfon) + + # on ne garde que les TE potés par une vache active du cheptel + # à voir si ceux qui ont été fait dans le même cheptel sont traitrés correctement avec les deux vaches donneuses et porteuses vivantes + PROD <- subset(produits, produits$indite != 'O') + + # ajout d'une colonne contenant le nombre produits IPG + PROD <- merge(PROD, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + PROD <- PROD[order(PROD$danais, decreasing = F),] + PROD <- PROD[order(PROD$mere, decreasing = T),] + + # correction des ravelamere des TE si possible + # quand emb, rang velage pas bon car pas remonté + if (nrow(PROD) >0){ + for (i in 1:nrow(PROD)) { + if (is.na(PROD$ravelamere[i])) { + if (!is.na(PROD$ravelamere[i+1]) & PROD$ravelamere[i+1] %in% c(1, 2)) { + PROD$ravelamere[i] <- 1 + PROD$typemere[i] <- 'G' #Génisse + } else if (!is.na(PROD$ravelamere[i+1]) & PROD$ravelamere[i+1] > 1) { + PROD$ravelamere[i] <- PROD$ravelamere[i+1] - 1 + PROD$typemere[i] <- 'V' #Vache + } + } + } + } + + # age au velage de la mere + PROD$agevel <- round(time_length(interval(PROD$danaismere, PROD$danais), + unit="months"), 1) + + # IVV : utilisation de la colonne deja presente de HBCANIM + # table IVV -> à récup + for (i in 1:nrow(PROD)) { + if (PROD$indite[i] == 'O_corr') { #embryons portés on rajoute # pour dire que c'est un embryon porté + PROD$nobovi[i] <- paste('#', PROD$nobovi[i], sep='') + } + # repro + if (PROD$anim[i] %in% czhbc$ANIM + | (!is.na(PROD$NBPRODIPG[i]) & PROD$NBPRODIPG[i] > 0) + | (!is.na(PROD$nbdescendants[i]) & as.numeric(PROD$nbdescendants[i]) > 0)) { + PROD$repro[i] <- 'O' + } else { + PROD$repro[i] <- NA + PROD$nobovi[i] <- PROD$nobovi[i] %>% str_to_lower() # <- nom en minuscule pour qu'on sache par repro + } + # mortalite + # à scinder entre morti natalité (mort <= 2 jours) et mortalité avant sevrage (entre 3 et 210jours) + if (!is.na(PROD$dasort[i]) & !is.na(PROD$casort[i]) & PROD$casort[i] == 'M'# cause sorties : e elevage, b boucherie c autoconsomation, m mort, p ou h pour pension + & time_length(interval(PROD$danais[i], PROD$dasort[i]), unit="days") < 211){ + PROD$mortsev[i] <- 'O' + PROD$nobovi[i]=paste(PROD$nobovi[i], ' (MavS)', sep='') # ajouter code Mort à naissance au momlent affichage liste des veaux + } else { + PROD$mortsev[i] <- NA + } + # IVV -> pas besoin calc normalement, revenir vers Lauréna pour voir quel IVV utiliser + # faire test pour voir à quel point classement décalé + if (i > 1) { + # cas normaux + if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1]) + & PROD$ravelamere[i] != 1 + & PROD$ravelamere[i] == PROD$ravelamere[i-1] + 1 + #& !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] != '2' + & !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) { + PROD$ivv[i] <- time_length(interval(PROD$danais[i-1], PROD$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1]) + & PROD$ravelamere[i] != 1 + & PROD$ravelamere[i] == PROD$ravelamere[i-1] + & !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] == '2' + & !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) { + PROD$ivv[i] <- PROD$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1]) + & PROD$ravelamere[i] != 1 + & !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] != '2' + & !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) { + PROD$ivv[i] <- round(time_length(interval(PROD$danais[i-1], + PROD$danais[i]), + unit="days") + / (PROD$ravelamere[i] - PROD$ravelamere[i-1]), 0) + } else { + PROD$ivv[i] <- NA + } + } + } + + # calcul des effets du cheptel : rang de velage et sexe du veau -> voir si on peut utiliser poids naissance corrigé de l'infocentre + effet <- PROD %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) + effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] + effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' # idem infocentre pour val corrigée + & effet$typemere == 'V')$m_p120[1] + effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' # idem infocentre pour val corrigée + & effet$typemere == 'V')$m_p210[1] + + # calcul des effets du cheptel : sexe sur la repro -> à faire !!!!! Calcule la diff moyen nb prod vache et nb prod taureau + # voir pour corriger ces effets en prenant tous les veaux en compte pour vache actives, taureaux et lignées femelles + effetsexe <- PROD %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + + # report des effets sur les produits -> phase de correction des effets donc pas besoin + # + + for (i in 1:nrow(PROD)) { + if (PROD$sexbov[i] == '2') { #_______________________________________ FEMELLES + PROD$nbpp_corr[i] <- PROD$NBPRODIPG[i] * rapport_MF # LC A récupérer !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + if (!is.na(PROD$typemere[i]) & PROD$typemere[i] == 'G') { #_________genisses + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } else { #________________________________________________ vaches ou inconnu + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PROD$nbpp_corr[i] <- PROD$NBPRODIPG[i] + if (!is.na(PROD$typemere[i]) & PROD$typemere[i] == 'G') { #____________________________________genisses + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } else { #________________________________________________ vaches ou inconnu + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } + } + } + + # calcul des données élaborées par vache active + + for (i in 1:nrow(vaches)) { + # _______________________________________________rappel des produits par vache + veaux <- PROD %>% filter(mere == vaches$anim[i]) + + # ___________________________________________calcul des infos utiles par vache + + # calcul du poids adulte estimé et synthese pointage vache ___________________ + if (!is.na(vaches$dmC[i])) { # si y a un pointage adulte + vaches$ptgV[i] <- round(0.6 * vaches$dmC[i] + 0.15 * vaches$ds[i] + + 0.25 * vaches$af[i], 1) # principe à garder mais pondération doit être paramétrable + # est ce qu'on corrige par effet campagne / pointeur ? -> si oui infocentre + } else { + vaches$ptgV[i] <- NA + } + + if (nrow(veaux) > 3){ # formule de brody ? estimation poids adulte + vaches$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2) # à voir pour changer la formule de précocité avec LJ + alpha <- 1.62 - 0.01 * vaches$precocite[i] + } else { + vaches$precocite[i] <- NA + alpha <- 1.62 # à MAJ + } + if (!is.na(vaches$pat24m[i])) { # rajouter paramètre cohérence des données, créer max et min + vaches$pad[i] <- round((vaches$pat24m[i] - 50 * exp(-720 * alpha * 10**(-3))) + / (1 - exp(-720 * alpha * 10**(-3))), 1) + } else if (!is.na(vaches$pat18m[i])) { + vaches$pad[i] <- round((vaches$pat18m[i] - 50 * exp(-540 * alpha * 10**(-3))) + / (1 - exp(-540 * alpha * 10**(-3))), 1) + } else if (!is.na(vaches$pat12m[i])) { + vaches$pad[i] <- round((vaches$pat12m[i] - 50 * exp(-360 * alpha * 10**(-3))) + / (1-exp(-360 * alpha * 10**(-3))), 1) + } else { + vaches$pad[i] <- NA + } + + # calcul des perfs de repro et du temps productif ____________________________ + + vaches$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1) # parce que certaines vaches sautent une année + + # normalement dans la table IVV donc pas besoin + if (1 %in% veaux$ravelamere) { + vaches$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1] + } else { + vaches$agevel1[i] <- NA + } + + if (2 %in% veaux$ravelamere) { + vaches$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1] + } else { + vaches$ivv1[i] <- NA + } + if (3 %in% veaux$ravelamere) { + vaches$ivv2p[i] <- round(mean(subset(veaux, + veaux$ravelamere > 2)$ivv, na.rm=T), 1) + } + + if (is.na(vaches$ivv1[i]) | (!is.na(vaches$ivv1[i]) & vaches$ivv1[i] < 390) ){ + e2 <- 0 # pas improductive entre 1er et 2ème velage, IVV correct + } else if (!is.na(vaches$ivv1[i]) & vaches$ivv1[i] >= 390) { + e2 <- vaches$ivv1[i] - 390 # si non on calcule le temps improductif + } + if (is.na(vaches$ivv2p[i]) | (!is.na(vaches$ivv2p[i]) & vaches$ivv2p[i] < 365) ){ + e3 <- 0 + } else if (!is.na(vaches$ivv2p[i]) & vaches$ivv2p[i] >= 365) { + e3 <- vaches$ivv1[i] - 365 + } + if (time_length(interval(max(veaux$danais, na.rm=T), # ne pas utiliser les veaux, mais la ligne de bofige pour gérer les avortements en plus + Sys.Date()), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") - 365 + } + + ## infocentre, juste à appeler animal_productivité + vaches$tempsprod[i] <- round( (vaches$age_days[i] + - ( vaches$agevel1[i] * 30.4 # ramène à un nb jours + + e2 + + e3 * (vaches$nbcampvel[i] - 2) + + e4 + )) / vaches$age_days[i] * 100, 1) + + # calcul des donn?es synth?tiques sur les produits ___________________________ + + vaches$prol[i] <- round(nrow(veaux) / (vaches$nbcampvel[i]) * 100, 1) + vaches$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O')) # prendre aussi morti natalité + / nrow(veaux)* 100, 1) + vaches$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O')) + / nrow(veaux)* 100, 1) + vaches$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T) + vaches$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T) + vaches$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux)* 100, 1) + vaches$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') )) # changer, à diviser par nb de veaux pour lesquels la condition est entre 1 et 5 + / nrow(veaux)* 100, 1) + vaches$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE) # récupérer pondération pointage sevrage + rajouter af et calcule des versions corrigées de ces indicateurs campagne / pointeur / cheptel + + 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1) + vaches$pn_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$ponais, na.rm=T), 1) + vaches$p120_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat04m, na.rm=T), 1) + vaches$p210_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat07m, na.rm=T), 1) + vaches$pn_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$ponais, na.rm=T), 1) + vaches$p120_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat04m, na.rm=T), 1) + vaches$p210_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat07m, na.rm=T), 1) + vaches$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1) + vaches$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1) + vaches$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1) + + ### convertion des NaN en NA + L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr', + 'p210_m','p210_f','p210_corr') + for (j in L){ + if (is.nan(vaches[i,j]) == TRUE){ + vaches[i,j] <- NA + } + } + } + + # calcul des stats, valeurs extremes et references pour la normalisation + + stats_chep <- create_df(0,c('var', 'cond', 'min', 'q1', 'med', + 'moy', 'q3', 'max', 'nbval', 'nas')) + + #fnction get_stat définie plus haut, à remplacer + stats_chep <- rbind(stats_chep, + get_stats(vaches, "vaches", "indisu"), + get_stats(vaches, "vaches", "agevel1"), + get_stats(vaches, "vaches", "ivv1"), + get_stats(vaches, "vaches", "ivv2p"), + get_stats(vaches, "vaches", "prol"), + get_stats(vaches, "vaches", "mort"), + get_stats(vaches, "vaches", "txrepros"), + get_stats(vaches, "vaches", "nbpp_corr"), + get_stats(vaches, "vaches", "txvf"), + get_stats(vaches, "vaches", "txmales"), + get_stats(vaches, "vaches", "ptgP"), + get_stats(vaches, "vaches", "pn_corr"), + get_stats(vaches, "vaches", "p120_corr"), + get_stats(vaches, "vaches", "p210_corr"), + get_stats(vaches, "vaches", "pad"), + get_stats(vaches, "vaches", "ptgV"), + get_stats(vaches, "vaches", "age_years"), + get_stats(vaches, "vaches", "tempsprod"), + get_stats(vaches, "vaches", "pn_m"), + get_stats(vaches, "vaches", "pn_f"), + get_stats(vaches, "vaches", "p120_m"), + get_stats(vaches, "vaches", "p120_f"), + get_stats(vaches, "vaches", "p210_m"), + get_stats(vaches, "vaches", "p210_f"), + get_stats(vaches, "vaches", "nbpp")) + + #_______________________________calcul des valeurs normalis?es par vache -> on veut que toutes les valeurs soient 0 et 1, soit ref cheptel soit ref nationnale + + for (i in 1:nrow(vaches)) { + # ____________________________________________ perfs individuelles normalis?es + if (!is.na(vaches$agevel1[i])){ + if (vaches$agevel1[i] > 48) { # à voir si on passe les ref nationnales en paramétrable + vaches$agevel1_n[i] <- 0 + } else if (vaches$agevel1[i] <= 48) { + vaches$agevel1_n[i] <- round(-2 * (10**-6) # formule Excel bidouillée par LJ, à garder telle quelle + * (vaches$agevel1[i] * 30.4) ** 2 + + 0.0027 * (vaches$agevel1[i] * 30.4) + + 8 * (10 ** -15), 3) + + } else { + vaches$agevel1_n[i] <- NA + } + } else { + vaches$agevel1_n[i] <- NA + } + + if (is.na(vaches$ivv1[i])) { + vaches$ivv1_n[i] <- NA + } else if (vaches$ivv1[i] > 460) { + vaches$ivv1_n[i] <- 0 + } else if (vaches$ivv1[i] < 390) { + vaches$ivv1_n[i] <- 1 + } else { + vaches$ivv1_n[i] <- round(1 - abs(390 - vaches$ivv1[i]) / abs(390 - 460), 3) + } + + if (is.na(vaches$ivv2p[i]) | is.nan(vaches$ivv2p[i])) { + vaches$ivv2p_n[i] <- NA + } else if (vaches$ivv2p[i] > 435) { + vaches$ivv2p_n[i] <- 0 + } else if (vaches$ivv2p[i] < 365) { + vaches$ivv2p_n[i] <- 1 + } else { + vaches$ivv2p_n[i] <- round(1 - abs(365 - vaches$ivv2p[i]) / abs(365 - 435), 3) + } + + if (is.na(vaches$pad[i])) { + vaches$pad_n[i] <- NA + } else { + vaches$pad_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$pad')[,'max'] # ref chep 1 = max + - vaches$pad[i]) + / abs(subset(stats_chep, var == 'vaches$pad')[,'max'] + - subset(stats_chep, var == 'vaches$pad')[,'min'])), 3) + } + + if (is.na(vaches$ptgV[i])) { + vaches$ptgv_n[i] <- NA + } else { + vaches$ptgv_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$ptgV')[,'max'] # ref chep 1 = max + - vaches$ptgV[i]) + / abs(subset(stats_chep, var == 'vaches$ptgV')[,'max'] + - subset(stats_chep, var == 'vaches$ptgV')[,'min'])), 3) + } + + if (vaches$prol[i] >= 100) { + vaches$prol_n[i] <- 1 + } else if (vaches$prol[i] < 50){ + vaches$prol_n[i] <- 0 + } else { + vaches$prol_n[i] <- round(1 - (abs(100 - vaches$prol[i]) / abs(100 - 50)), 3) + } + + if (is.na(vaches$pn_corr[i])) { # à voir pour adapter les valeurs selon la distribution de l'éleveur + vaches$pn_n[i] <- NA + } else if (40 < vaches$pn_corr[i] & vaches$pn_corr[i] < 50) { + vaches$pn_n[i] <- 1 + } else if (22 > vaches$pn_corr[i] | vaches$pn_corr[i] > 68) { + vaches$pn_n[i] <- 0 + } else if (22 < vaches$pn_corr[i] & vaches$pn_corr[i] < 40) { + vaches$pn_n[i] <- round(0.056 * (vaches$pn_corr[i] - 22), 3) + } else { + vaches$pn_n[i] <- round(1 - 0.056 * (vaches$pn_corr[i] - 50), 3) + } + + vaches$txvf_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txvf')[,'max'] # ref eleveur 1 = max + - vaches$txvf[i]) / + abs(subset(stats_chep, var == 'vaches$txvf')[,'max'] + - subset(stats_chep, var == 'vaches$txvf')[,'min'])), 3) + vaches$txm_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txmales')[,'max'] + - vaches$txmales[i]) + / abs(subset(stats_chep, var == 'vaches$txmales')[,'max'] + - subset(stats_chep, var == 'vaches$txmales')[,'min'])), 3) + vaches$mort_n[i] <- round(1.0 * exp(-0.031 * vaches$mort[i]), 3) # garder cette formule + # tout le reste cheptel où 1 = max + vaches$txrepros_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txrepros')[,'max'] + - vaches$txrepros[i]) + / abs(subset(stats_chep, var == 'vaches$txrepros')[,'max'] + - subset(stats_chep, var == 'vaches$txrepros')[,'min'])), 3) + vaches$nbpp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$nbpp_corr')[,'max'] + - vaches$nbpp_c[i]) + / abs(subset(stats_chep, var == 'vaches$nbpp_corr')[,'max'] + - subset(stats_chep, var == 'vaches$nbpp_corr')[,'min'])), 3) + vaches$ptgp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$ptgP')[,'max'] + - vaches$ptgP[i]) + / abs(subset(stats_chep, var == 'vaches$ptgP')[,'max'] + - subset(stats_chep, var == 'vaches$ptgP')[,'min'])), 3) + vaches$p120_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$p120_corr')[,'max'] + - vaches$p120_c[i]) + / abs(subset(stats_chep, var == 'vaches$p120_corr')[,'max'] + - subset(stats_chep, var == 'vaches$p120_corr')[,'min'])), 3) + vaches$p210_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$p210_corr')[,'max'] + - vaches$p210_c[i]) + / abs(subset(stats_chep, var == 'vaches$p210_corr')[,'max'] + - subset(stats_chep, var == 'vaches$p210_corr')[,'min'])), 3) + # __________________________________________________ calcul des notes carriere + somme <- 0 + pond <- sum(Pcar[,c(2:16)]) + for (j in c(190:204)){ # attention a la correspondance des numeros de colonnes !!! + # modif du 29/04/2024 : passage de 189:203 à 190:204 + if (is.na(vaches[i,j])){ + valperf <- 0 + #mt_col <- mt_col + 1 # nb de colonnes sans valeur + pond <- pond - Pcar[1, (j - 189 + 1)] + } else { + valperf <- vaches[i, j] * Pcar[1, (j - 189 + 1)] # critere normalise X ponderation + } + somme <- somme + valperf # somme sur une ligne + } + SOMME_tot <- somme / pond * 10 # rapport en prenant que les criteres ayant une valeur + # si on a pas assez d'infos sur les veaux, on exclue la vache du classement en supprimant la valeur calculées + # a voir si on fait évoluer -> rajouter un param si cheptel VA4 on fait la vérif si non on la saute, + ne pas afficher colonnes vides si pas VA4 + # Si pas VA4, passer les pondérations à 0 ? + if (is.na(vaches$ptgp_n[i]) & is.na(vaches$p120_n[i]) & is.na(vaches$p210_n[i])){ + vaches$ecowcarr[i] <- NA + } else { + vaches$ecowcarr[i] <- round(SOMME_tot * 100, 0) + } + } + vaches$rg_carr <- rank(1 / vaches$ecowcarr, na.last="keep") + + + ##################################################### calcul des notes campagnes + + campagnes <- PROD %>% distinct(mere, campn, ravelamere) # à voir pour modifier prendre juste date de naissance car possible 2nais/camp donc plus simple + + for (i in 1:nrow(campagnes)){ + #y <- subset(VA,VA$ANIM==C$mereref[i]) # ligne de la mere dans VA + veaux <- subset(PROD, PROD$campn == campagnes$campn[i] + & PROD$mere == campagnes$mere[i]) # ligne(s) du ou des veaux dans PR + + campagnes$pn_c[i] <- round(mean(veaux$pn_corr, na.rm=TRUE), 1) + campagnes$txvf[i] <- round(nrow(subset(veaux, + veaux$conais %in% c('1','2'))) + / nrow(veaux) * 100, 1) + campagnes$txm[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux) * 100, 1) + campagnes$ptgp[i] <- round(mean((0.75 * veaux$devmus + + 0.25 * veaux$devsqe), na.rm=TRUE) ,1) + campagnes$p120_c[i] <- round(mean(veaux$p120_corr, na.rm=TRUE), 1) + campagnes$p210_c[i] <- round(mean(veaux$p210_corr, na.rm=TRUE), 1) + campagnes$prol[i] <- nrow(veaux) * 100 + campagnes$ivv[i] <- veaux$ivv[1] + campagnes$mort[i] <- round(nrow(subset(veaux,veaux$mortsev == 'O')) # ajouter mort natalité + / nrow(veaux) * 100, 1) + + L <- c('ptgp','pn_c','p120_c','p210_c') + for (j in L){ # On rajoute les colonnes si besoin + if (is.nan(campagnes[i,j])){ + campagnes[i,j] <- NA + } + } + + if (nrow(veaux) == 1){ # à voir, récupère numéro et nom du v pour passer en jsoneau + nv <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + } else if (nrow(veaux) == 2){ + nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_') + nv <- paste(nv1, nv2, sep=', ') + } else if (nrow(veaux) == 3){ + nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_') + nv3 <- paste(str_sub(veaux$anim[3], -4), trim_str(veaux$nobovi[3]), sep='_') + nv <- paste(nv1, nv2, nv3, sep=', ') + } else if (nrow(veaux) == 4){ + nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_') + nv3 <- paste(str_sub(veaux$anim[3], -4), trim_str(veaux$nobovi[3]), sep='_') + nv4 <- paste(str_sub(veaux$anim[4], -4), trim_str(veaux$nobovi[4]), sep='_') + nv <- paste(nv1, nv2, nv3, nv4, sep=', ') + } + if(is.na(veaux$nompere[1])){ + if (is.na(veaux$pere[1])){ + pere <- '' + } else { + pere <- str_sub(trim_str(veaux$pere[1]), -4) + } + } else { + pere <- trim_str(veaux$nompere[1]) + } + campagnes$noms[i] <- paste(nv, pere, sep=' / ') + } + + stats_chep <- rbind(stats_chep, + get_stats(campagnes,'campagnes','ivv'), + get_stats(campagnes,'campagnes','prol'), + get_stats(campagnes,'campagnes','mort'), + get_stats(campagnes,'campagnes','txvf'), + get_stats(campagnes,'campagnes','txm'), + get_stats(campagnes,'campagnes','ptgp'), + get_stats(campagnes,'campagnes','pn_c'), + get_stats(campagnes,'campagnes','p120_c'), + get_stats(campagnes,'campagnes','p210_c')) + + for (i in 1:nrow(campagnes)){ + # _____________________________________ calcul des perfs campagnes normalis?es + #pn + if (is.na(campagnes$pn_c[i])) { + campagnes$pn_n[i] <- NA + } else if (campagnes$pn_c[i] >= 40 & campagnes$pn_c[i] <= 50) { + campagnes$pn_n[i] <- 1 + } else if (22 >= campagnes$pn_c[i] | campagnes$pn_c[i] >= 68) { + campagnes$pn_n[i] <- 0 + } else if (22 < campagnes$pn_c[i] & campagnes$pn_c[i] < 40) { + campagnes$pn_n[i] <- round(0.056 * (campagnes$pn_c[i] - 22), 3) + } else { + campagnes$pn_n[i] <- round(1 - 0.056 * (campagnes$pn_c[i] - 50), 3) + } + + campagnes$txvf_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$txvf')[,'max'] + - campagnes$txvf[i]) + / abs(subset(stats_chep, var == 'campagnes$txvf')[,'max'] + - subset(stats_chep, var == 'campagnes$txvf')[,'min'])), 3) + campagnes$txm_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$txm')[,'max'] + - campagnes$txm[i]) + / abs(subset(stats_chep, var == 'campagnes$txm')[,'max'] + - subset(stats_chep, var == 'campagnes$txm')[,'min'])), 3) + campagnes$ptgp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$ptgp')[,'max'] + - campagnes$ptgp[i]) + / abs(subset(stats_chep, var == 'campagnes$ptgp')[,'max'] + - subset(stats_chep, var == 'campagnes$ptgp')[,'min'])), 3) + campagnes$p120_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$p120_c')[,'max'] + - campagnes$p120_c[i]) + / abs(subset(stats_chep, var == 'campagnes$p120_c')[,'max'] + - subset(stats_chep, var == 'campagnes$p120_c')[,'min'])), 3) + campagnes$p210_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$p210_c')[,'max'] + - campagnes$p210_c[i]) + / abs(subset(stats_chep, var == 'campagnes$p210_c')[,'max'] + - subset(stats_chep, var == 'campagnes$p210_c')[,'min'])), 3) + + #prol + if (is.na(campagnes$prol[i])) { + campagnes$prol_n[i] <- NA + } else if (campagnes$prol[i] == 100) { + campagnes$prol_n[i] <- 0.8 + } else { + campagnes$prol_n[i] <- 1 + } + + campagnes$mort_n[i] <- round(1.0 * exp(-0.031 * campagnes$mort[i]), 3) + + #ivv mettre les limites dans le paramétrable, même que partie carrière + if (is.na(campagnes$ravelamere[i]) | campagnes$ravelamere[i] == 1 + | is.na(campagnes$ivv[i])) { + campagnes$ivv_n[i] <- NA + } else if (campagnes$ravelamere[i] == 2) { + if (!is.na(campagnes$ivv[i])){ + if (campagnes$ivv[i] > 460) { + campagnes$ivv_n[i] <- 0 + } else if (campagnes$ivv[i] < 390) { + campagnes$ivv_n[i] <- 1 + } else { + campagnes$ivv_n[i] <- round(1 - abs(390 - campagnes$ivv[i]) / abs(390 - 460), 3) + } + } + } else { + if (!is.na(campagnes$ivv[i])) { + if (campagnes$ivv[i] > 435) { + campagnes$ivv_n[i] <- 0 + } else if (campagnes$ivv[i] < 365) { + campagnes$ivv_n[i] <- 1 + } else { + campagnes$ivv_n[i] <- round(1 - abs(365 - campagnes$ivv[i]) / abs(365 - 435), 3) + } + } + } + + # _________________________________________________ calcul des notes campagnes + somme <- 0 + pond <- sum(Pcamp[2,c(2:10)]) + for (j in c(14:22)){ # attention a la correspondance des num?ros de colonnes !!! + if (is.na(campagnes[i,j])){ + valperf <- 0 + #mt_col <- mt_col + 1 # nb de colonnes sans valeur + pond <- pond - Pcamp[1, (j - 13 + 1)] + } else { + valperf <- campagnes[i, j] * Pcamp[1, (j - 13 + 1)] # critere normalise X ponderation + } + somme <- somme + valperf # somme sur une ligne + } + SOMME_tot <- somme / pond * 10 # rapport en prenant que les criteres ayant une valeur + if (is.na(campagnes$ptgp_n[i]) & is.na(campagnes$p120_n[i]) & is.na(campagnes$p210_n[i])){ + campagnes$ecowcamp[i] <- round(SOMME_tot, 1) # à voir si on remplace par NC + } else { + campagnes$ecowcamp[i] <- round(SOMME_tot * 10, 0) + } + + } + + # remplissage de la table vaches avec les notes campagnes + + for (i in 1:nrow(vaches)){ + # moyenne notes campagnes -> plus besoin + subcamp <- subset(campagnes, campagnes$mere == vaches$anim[i] + & campagnes$ecowcamp > 10) + if (nrow(subcamp)>0){ + vaches$moyecowcamp[i] <- round(mean(subcamp$ecowcamp, na.rm=TRUE), 1) + } else { + vaches$moyecowcamp[i] <- NA + } + # vaches non class?es en minuscules -> pas besoin + if (is.na(vaches$ecowcarr[i])) { + vaches$nobovi[i] <- vaches$nobovi[i] %>% str_to_lower() + } + # donneuses soulignees par un # -> à voir selon gestion de l'affichage + embr <- subset(PROD, PROD$mere == vaches$anim[i] & PROD$indite == 'O') + if (nrow(embr) > 0) { + vaches$nobovi[i] <- paste('#', vaches$nobovi[i], sep=' ') + } + } + vaches$rg_camp <- rank(1 / vaches$moyecowcamp, na.last='keep') # -> plus besoin + + # creation du tableau CAMPAGNES -> pas besoin si json + + nbcol <- max(campagnes$ravelamere, na.rm = TRUE) # nombre de colonnes de rangs de vélage à créer + CAMP <- cbind('anim'=vaches$anim, create_df(nrow(vaches), c(1:nbcol))) + for (i in 1:nrow(CAMP)){ + subcamp <- subset(campagnes, campagnes$mere == CAMP$anim[i]) + for (j in 2:ncol(CAMP)){ + veaux <- subset(subcamp, subcamp$ravelamere == j-1) + if (nrow(veaux) > 0) { + CAMP[i,j] <- paste(veaux$noms[1], veaux$ecowcamp[1], sep=' : ') # attention veau pas issu de produits mais de campagnes + } + } + } + + # merge c + vaches <- merge(vaches, CAMP, by.x='anim', by.y='anim', all.x=T, all.y=T) # LC a priori sert à rien car refait pour le tableau final, à voir si utile dans la table vaches + + # à voir ce double merge bizarre ? + # selection des colonnes d'interet pour la table finale + tabfinal <- merge(vaches[,c('chepdet', 'anim', 'nobovi', 'nompere', 'indisu', + 'tempsprod', 'age_years', 'ecowcarr', 'rg_carr', + 'ptgV', 'agevel1', 'ivv1', 'ivv2p', + 'prol', 'mort', 'txrepros', 'nbpp', + 'txvf', 'pn_m', 'pn_f', + 'p120_m', 'p120_f', 'p210_m', 'p210_f', + 'ptgP', + 'moyecowcamp', 'rg_camp')], + CAMP, by.x='anim', by.y='anim', all.x=T, all.y=T) + + tabfinal <- tabfinal[order(tabfinal$rg_carr),] + tabfinal <- tabfinal %>% select(chepdet, everything()) # ?? + + colnames(tabfinal)=c("CHEPTEL", "NUM_VACHE", "NOM_VACHE", "PERE", "ISU", + "% VIE PRODUCTIVE", "AGE (annees)", + "note eCow CARRIERE (/1000)", "rang CARRIERE", + "pointage VACHE *m", "age 1er velage (m)", "IVV1 (j)", + "IVV2+ (j)", "prolificite (%)", "mortalite av.sevr (%)", + "% produits repros", "nb petits-produits", + "% velages tranquilles", "PN males (kg)", + "PN femelles (kg)", "P120 males (kg)", "P120 femelles (kg)", + "P210 males (kg)","P210 femelles (kg)", + "pointage PRODUITS *m", "Moyenne notes eCow CAMPAGNE (/100)", + "rang CAMPAGNE", c(1:nbcol)) + + write.table(tabfinal, + file = paste(rep, '/', CHEP, '_classement_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + + new <- Sys.time() - old + print(paste('Calcul du classement ?Cow :', new, sep = '')) + + + + # a revoir pour les petits cheptels + #render_vn(CHEP, TECH) + + ################################################################################ + ### calcul du resume cheptel ################################################### + ################################################################################ + + # lecture du fichier des stats des adherents + detail_stats_chep <- read_delim(paste("C:/Users/LéaCIMETIERE/OneDrive - HERD BOOK CHAROLAIS/Documents/eCow/Fichiers de Lauréna JEANNOT - eCow5/EXPORTS_2/detail_stats_chep.csv"), + ";", escape_double = FALSE, + locale = locale(decimal_mark = ",", + grouping_mark = ""), trim_ws = TRUE) + # LC a changer par un appel à la table stat_chep qui centralise les stats par cheptel de tous les cheptels des adhérents + + + # detail_stats_chep$date_calc <- '2020-09-06' + # perfs dont l'unit? de calcul est la vache : ie toutes les vaches actives + # isu, age, temps prod, ptg adulte, agevel1, ivv1 et 2+ + # perfs dont l'unit? de calcul est le produit : ie tous les produits issus de vaches actives + # prol, mort, tx de repros, nb de PP, tx de VF, PN, P120 et 210, ptg sevrage + + + ## stats du cheptel a inserer dans la liste des adherents pour comparaison -> dashboard + + # LC : à voir pour réutiliser la variable stats_chep et la compléter + + stats_chep_bis <- detail_stats_chep[1,] + stats_chep_bis[1,] <- NA + + stats_chep_bis$ADHHBC <- CHEP + + stats_chep_bis$isu[1] <- round( mean(vaches$indisu, na.rm=T), 1) + stats_chep_bis$tps_prod[1] <- round( mean(vaches$tempsprod, na.rm=T), 1) + stats_chep_bis$age[1] <- round( mean(vaches$age_years, na.rm=T), 1) + stats_chep_bis$ptgv[1] <- round( mean(vaches$ptgV, na.rm=T), 1) + stats_chep_bis$agevel1[1] <- round( mean(vaches$agevel1, na.rm=T), 1) + stats_chep_bis$ivv1[1] <- round( mean(vaches$ivv1, na.rm=T), 1) + stats_chep_bis$ivv2p[1] <- round( mean(vaches$ivv2p, na.rm=T), 1) + + stats_chep_bis$prol[1] <- round( nrow(PROD) / nrow(campagnes) * 100, 1) + stats_chep_bis$mort[1] <- round( nrow(subset(PROD, PROD$mortsev == 'O')) + / nrow(PROD) * 100, 1) + stats_chep_bis$txvf[1] <- round( nrow(subset(PROD, PROD$conais %in% c('1','2'))) + / nrow(PROD) * 100, 1) + stats_chep_bis$tx_repros[1] <- round( nrow(subset(PROD, PROD$NBPRODIPG > 0)) + / nrow(PROD) * 100, 1) + stats_chep_bis$nbpp[1] <- sum(PROD$NBPRODIPG, na.rm=TRUE) + stats_chep_bis$ptgp[1] <- round( mean(0.75 * PROD$devmus + 0.25 * PROD$devsqe, + na.rm=TRUE), 1) + stats_chep_bis$pnm[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$ponais, + na.rm=TRUE), 1) + stats_chep_bis$pnf[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$ponais, + na.rm=TRUE), 1) + stats_chep_bis$p120m[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$pat04m, + na.rm=TRUE), 1) + stats_chep_bis$p120f[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$pat04m, + na.rm=TRUE), 1) + stats_chep_bis$p210m[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$pat07m, + na.rm=TRUE), 1) + stats_chep_bis$p210f[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$pat07m, + na.rm=TRUE), 1) + stats_chep_bis$date_calc[1] <- as.character(Sys.Date()) + + # on met a jour le fichier des stats des adh + #____________________________ prevoir une ?tape de verif de VALEURS ABERRENTES ! + + detail_stats_chep <- subset(detail_stats_chep, detail_stats_chep$ADHHBC != CHEP) # on enlève les anciennes données du cheptel + + detail_stats_chep <- rbind(detail_stats_chep, stats_chep_bis) # on ajoute les nouvelles stats + + write.table(detail_stats_chep, + file = paste(rep_exp, "detail_stats_chep.csv", sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"),na = "") + + + ## stats du cheptel avec distribution des adh?rents et des vaches + rownames(stats_chep) <- stats_chep$var + + res_chep <- stats_chep[c('vaches$indisu', 'vaches$tempsprod', 'vaches$age_years', + 'vaches$ptgV','vaches$agevel1', 'vaches$ivv1', + 'vaches$ivv2p', 'vaches$prol', 'vaches$mort', + 'vaches$txrepros', 'vaches$nbpp', 'vaches$txvf', + 'vaches$pn_m', 'vaches$pn_f', 'vaches$p120_m', + 'vaches$p120_f', 'vaches$p210_m', 'vaches$p210_f', + 'vaches$ptgP'), + c('moy', 'min', 'q1', 'med', 'q3', 'max')] + + # creation d'un table contenant la distribution des cheptels pour chaque variable + stats_adh <- data.frame(matrix(NA, ncol = 7,nrow = 19)) + colnames(stats_adh) <- c("var", "moy_c", "min_c", "Q1_c", "med_c", "Q3_c", "max_c" ) + stats_adh[,1] <- c('isu','tps_prod','age','ptgv','agevel1','ivv1','ivv2p', + 'prol','mort','tx_repros','nbpp','txvf', + 'pnm','pnf','p120m','p120f','p210m','p210f','ptgp') + + # remplissage de la table + for (i in 1:nrow(stats_adh)){ + stats_adh$moy_c[i] <- round(mean(unlist(detail_stats_chep[,i + 1]), + na.rm = TRUE), 1) + stats_adh$min_c[i] <- round(min(detail_stats_chep[,i + 1], na.rm = TRUE), 1) + stats_adh$Q1_c[i] <- round(quantile(detail_stats_chep[,i + 1], + probs = 0.25, na.rm = TRUE), 1) + stats_adh$med_c[i] <- round(quantile(detail_stats_chep[,i + 1], + probs = 0.50, na.rm = TRUE), 1) + stats_adh$Q3_c[i] <- round(quantile(detail_stats_chep[,i + 1], + probs = 0.75,na.rm = TRUE), 1) + stats_adh$max_c[i] <- round(max(detail_stats_chep[,i + 1], na.rm = TRUE), 1) + } + + # on fusionne distribution des adherents et des vaches du cheptel d'?tude + STATS <- cbind(stats_adh, t(stats_chep_bis[, c(2 : (ncol(stats_chep_bis) - 1))])) + + STATS <- cbind(STATS, res_chep) + + STATS$var <- c("ISU", "% vie productive", "age (annees)", + "pointage VACHE *m", "age 1er velage (m)", "IVV1 (j)", "IVV2+ (j)", + "prolificite (%)", "mortalite av.sevr (%)", "% produits repros", + "nb petits-produits", "% velages tranquilles", "PN males (kg)", + "PN femelles (kg)", "P120 males (kg)", "P120 femelles (kg)", + "P210 males (kg)", "P210 femelles (kg)", "pointage PRODUITS *m") + colnames(STATS) <- c('Variable', 'Moyenne_ADH', 'Min_ADH', 'Q1_ADH', + 'Mediane_ADH', 'Q3_ADH', 'Max_ADH', 'Moyenne_cheptel', + 'Moyenne_vaches', 'Min_vaches', 'Q1_vaches', + 'Mediane_vaches', 'Q3_vaches', 'Max_vaches') + + write.table(STATS, + file = paste(rep, '/', CHEP, '_ResChep_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + + + + + ################################################################################ + ### remont?e des perfs des taureaux marquants ################################## + ################################################################################ + + # on r?cupere les peres des animaux actifs + # on regarde s'ils ont un nombre raisonnable de produits, ie moins de 275 + # si c'est la cas, on r?cupere tous les produits puis on trie ceux n?s dans le cheptel + + ## update du 13dec2021 apres mise en prod du WS sur la production d'un animal dans un cheptel particulier + # a changer : on prend les pères des 20 dernières campagnes de naissances et on garde que ceux qui ont eu au moins 5 produits sur cette période + peres <- inventaire %>% + filter(trim_str(chna) == CHEP & !is.na(pere)) %>% + distinct(pere, nompere) %>% add_column('naisseur' = NA) + + + if (nrow(peres) > 0) { + #récupère leurs infos dans hbcanim + #attention il faudra récupérer les naisseurs, mais il y a eu un pb de gestion des détennteurs ou naisseurs qui fait que ça s'affichait mal -> pb à résoudre + # voir table chepco cf soprano chez parents Lauréna + for (i in 1:nrow(peres)) { + li_anim <- chgt_infos(trim_str(peres$pere[i])) + if (is.data.frame(li_anim)) { + peres$naisseur[i] <- li_anim$nomnais[1] + } + } + + # crée table vide avec format pour produits et petits produits + prod_peres <- inventaire[0,] + pp_peres <- inventaire[0,] + + for (i in 1 : nrow(peres)) { + animal <- peres$pere[i] + cat("\n", animal, peres$nompere[i]) + try({ + produits <- get_produits_in_chep(animal, CHEP) # loc update + if (is.data.frame(produits) == TRUE) { #__________________________________ + produits <- produits %>% filter(trim_str(chna) == CHEP) #normalement plus utile car webservice récupère que les prod + prod_peres <- rbind(prod_peres, produits) + for (j in 1:nrow(produits)) { + if (produits$sexbov[j] == '2' & as.numeric(produits$nbdescendants[j]) > 0) { + pp <- get_produits_vache(trim_str(produits$anim[j])) + if (is.data.frame(pp) == TRUE) { #______________________________ + pp <- pp %>% filter(trim_str(chna) == CHEP) + pp_peres <- rbind(pp_peres, pp) + } + } + } + } else { #________________________________________________________________ + cat("\n", "Aucune donn?e charg?e") + } + }) + } + + # mise en forme des données + if (nrow(prod_peres) > 0) { + if (!is.na(prod_peres$danais[1]) & nchar(as.character(prod_peres$danais[1])) > 10) { + prod_peres$danais <- as.Date(substr(as.POSIXct(prod_peres$danais / 1000, + origin = "1970-01-01"), 1, 10), + format = "%Y-%m-%d", + origin = "1970-01-01") + } else { + prod_peres$danais <- as.Date(prod_peres$danais, + format = "%Y-%m-%d") + } + sortis <- subset(prod_peres, !is.na(prod_peres$dasort)) + if (nrow(sortis) > 0 && nchar(as.character(sortis$dasort[1])) > 10) { + prod_peres$dasort <- as.Date(substr(as.POSIXct(prod_peres$dasort / 1000, + origin = "1970-01-01"), 1, 10), + format = "%Y-%m-%d", + origin = "1970-01-01") + } else { + prod_peres$dasort <- as.Date(prod_peres$dasort, + format = "%Y-%m-%d") + } + if (!is.na(prod_peres$danaismere[1]) & nchar(as.character(prod_peres$danaismere[1])) > 10) { + prod_peres$danaismere <- as.Date(substr(as.POSIXct(prod_peres$danaismere / 1000, + origin = "1970-01-01"), 1, 10), + format = "%Y-%m-%d", + origin = "1970-01-01") + } else { + prod_peres$danaismere <- as.Date(prod_peres$danaismere, + format = "%Y-%m-%d") + } + + prod_peres$mere <- trim_str(prod_peres$mere) + prod_peres$pere <- trim_str(prod_peres$pere) + prod_peres$anim <- trim_str(prod_peres$anim) + prod_peres$ds <- as.numeric(prod_peres$ds) + prod_peres$af <- as.numeric(prod_peres$af) + prod_peres$dmC <- as.numeric(prod_peres$dmC) + + # liste de tous leurs produitsdir + produitsdir <- prod_peres #%>% filter(chna == CHEP) # _________________________ filtre a reflechir ????? -> normalement déjà filtré + + # vachestot ayant produit + vachestot <- subset(prod_peres, + prod_peres$sexbov == '2' & prod_peres$nbdescendants > 0 ) + + # les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant -> comme pour les vaches + if (nrow(porteuses) > 0) { + for (i in 1:nrow(porteuses)) { + if (!(porteuses$ANIM[i] %in% trim_str(produitsdir$anim))) { + + temp <- appel_infos(porteuses$ANIM[i], hbcanim) + li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i]) + + if ( is.data.frame(temp) && nrow(temp) > 0 ) { + temp$mere[1] <- porteuses$MEREIPG[i] + temp[1, c(60:67, 86:103)] <- NA + if ( nrow(li_mere) > 0){ + temp$danaismere[1] <- as.character(li_mere$danais[1]) + } + temp$indite[1] <- 'O_corr' + + tryCatch({ + produitsdir <- rbind(produitsdir, temp[,colnames(produitsdir)]) #-------------------------------- tryCatch à supp + }, + error = function(e) e) + } + } + } + } + + # modifs des types de donn?es, pour calcul par la suite + produitsdir$danais <- as.Date(produitsdir$danais, format = "%Y-%m-%d") + produitsdir$dasort <- as.Date(produitsdir$dasort, format = "%Y-%m-%d") + + produitsdir$mere <- trim_str(produitsdir$mere) + produitsdir$pere <- trim_str(produitsdir$pere) + produitsdir$anim <- trim_str(produitsdir$anim) + + produitsdir$ravelamere <- as.numeric(produitsdir$ravelamere) + produitsdir$ivv <- as.numeric(produitsdir$ivv) + produitsdir$campn <- as.numeric(produitsdir$campn) + produitsdir$nbdescendants <- as.numeric(produitsdir$nbdescendants) + + produitsdir$ponais <- as.numeric(produitsdir$ponais) + produitsdir$pat04m <- as.numeric(produitsdir$pat04m) + produitsdir$pat07m <- as.numeric(produitsdir$pat07m) + + produitsdir$devsqe <- as.numeric(produitsdir$devsqe) + produitsdir$devmus <- as.numeric(produitsdir$devmus) + produitsdir$aptfon <- as.numeric(produitsdir$aptfon) + + # on ne garde que les TE port?s par une vache active du cheptel + PRODDIR <- subset(produitsdir, produitsdir$indite != 'O') + + # ajout des produitsdir IPG + PRODDIR <- merge(PRODDIR, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + PRODDIR <- PRODDIR[order(PRODDIR$danais, decreasing = F),] + PRODDIR <- PRODDIR[order(PRODDIR$mere, decreasing = T),] + + # correction des ravelamere des TE si possible + for (i in 1:nrow(PRODDIR)) { + if (is.na(PRODDIR$ravelamere[i])) { + if (!is.na(PRODDIR$ravelamere[i+1]) & PRODDIR$ravelamere[i+1] %in% c(1, 2)) { + PRODDIR$ravelamere[i] <- 1 + PRODDIR$typemere[i] <- 'G' + } else if (!is.na(PRODDIR$ravelamere[i+1]) & PRODDIR$ravelamere[i+1] > 1) { + PRODDIR$ravelamere[i] <- PRODDIR$ravelamere[i+1] - 1 + PRODDIR$typemere[i] <- 'V' + } + } + } + + # age au velage de la mere + PRODDIR$agevel <- round(time_length(interval(PRODDIR$danaismere, PRODDIR$danais), + unit="months"), 1) + + # IVV : utilisation de la colonne deja pr?sente de HBCANIM + # Nouvelle table IVV, même logique que partie Vache + + for (i in 1:nrow(PRODDIR)) { + if (PRODDIR$indite[i] == 'O_corr') { + PRODDIR$nobovi[i] <- paste('#', PRODDIR$nobovi[i], sep='') + } + # repro + if (PRODDIR$anim[i] %in% czhbc$ANIM + | (!is.na(PRODDIR$NBPRODIPG[i]) & PRODDIR$NBPRODIPG[i] > 0) + | (!is.na(PRODDIR$nbdescendants[i]) + & as.numeric(PRODDIR$nbdescendants[i]) > 0)) { + PRODDIR$repro[i] <- 'O' + } else { + PRODDIR$repro[i] <- NA + PRODDIR$nobovi[i] <- PRODDIR$nobovi[i] %>% str_to_lower() + } + # mortalite + if (!is.na(PRODDIR$dasort[i]) & !is.na(PRODDIR$casort[i]) + & PRODDIR$casort[i] == 'M' + & time_length(interval(PRODDIR$danais[i], PRODDIR$dasort[i]), + unit="days") < 211){ + PRODDIR$mortsev[i] <- 'O' + PRODDIR$nobovi[i]=paste(PRODDIR$nobovi[i], ' (MavS)', sep='') + } else { + PRODDIR$mortsev[i] <- NA + } + # IVV -> cf table + if (i > 1) { + # cas normaux + if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1]) + & PRODDIR$ravelamere[i] != 1 + & PRODDIR$ravelamere[i] == PRODDIR$ravelamere[i-1] + 1 + #& !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] != '2' + & !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) { + PRODDIR$ivv[i] <- time_length(interval(PRODDIR$danais[i-1], PRODDIR$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1]) + & PRODDIR$ravelamere[i] != 1 + & PRODDIR$ravelamere[i] == PRODDIR$ravelamere[i-1] + & !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] == '2' + & !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) { + PRODDIR$ivv[i] <- PRODDIR$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1]) + & PRODDIR$ravelamere[i] != 1 + & !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] != '2' + & !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) { + PRODDIR$ivv[i] <- round(time_length(interval(PRODDIR$danais[i-1], + PRODDIR$danais[i]), + unit="days") + / (PRODDIR$ravelamere[i] + - PRODDIR$ravelamere[i-1]), 0) + } else { + PRODDIR$ivv[i] <- NA + } + } + } + + # calcul des effets du cheptel : rang de velage et sexe du veau -> infocentre + effet <- PRODDIR %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) + effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] + effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p120[1] + effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p210[1] + + # calcul des effets du cheptel : sexe sur la repro # voir pour corriger ces effets en prenant tous les veaux en compte cf vache + effetsexe <- PRODDIR %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + + # report des effets sur les produitsdir + # applique les effets, poids infocentre, petits produit cf au dessus + for (i in 1:nrow(PRODDIR)) { + if (PRODDIR$sexbov[i] == '2') { #____________________________________ FEMELLES + PRODDIR$nbpp_corr[i] <- PRODDIR$NBPRODIPG[i] * rapport_MF + if (!is.na(PRODDIR$typemere[i]) & PRODDIR$typemere[i] == 'G') { #____genisses + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PRODDIR$nbpp_corr[i] <- PRODDIR$NBPRODIPG[i] + if (!is.na(PRODDIR$typemere[i]) & PRODDIR$typemere[i] == 'G') { #_________________________________genisses + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } + } + } + } + + if (nrow(vachestot) > 0) { + # recherche des meres dans les porteuses pour aller chercher + # les produitstot s'ils existent dans HBCANIM + + porteuses <- subset(indite, !is.na(indite$MEREIPG) + & indite$MEREIPG %in% trim_str(vachestot$anim)) + donneuses <- subset(indite, !is.na(indite$MERECPB) + & indite$MERECPB %in% trim_str(vachestot$anim)) + # l'indicateur de donneuse d'embryon est renseign? apr?s dans --> vachestot$ACINAC + + # calcul age à la sortie si sortie + for (i in 1:nrow(vachestot)) { + if (is.na(vachestot$dasort[i])){ + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], Sys.Date()), unit="days") + } else { + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], vachestot$dasort[i]), unit="days") + } + } + + vachestot$age_years <- round(vachestot$age_days / 365, 1) + + # liste de tous leurs produitstot -> petits produits des pères, produits des filles + produitstot <- pp_peres #%>% filter(chna == CHEP) # ___________________________ filtre a reflechir ????? + + # les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant # idem traitement vache + if (nrow(porteuses) > 0) { + for (i in 1:nrow(porteuses)) { + if (!(porteuses$ANIM[i] %in% trim_str(produitstot$anim))) { + + temp <- appel_infos(porteuses$ANIM[i], hbcanim) + li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i]) + + if ( is.data.frame(temp) && nrow(temp) > 0 ) { + temp$mere[1] <- porteuses$MEREIPG[i] + temp[1, c(60:67, 86:103)] <- NA + if ( nrow(li_mere) > 0){ + temp$danaismere[1] <- as.character(li_mere$danais[1]) + } + temp$indite[1] <- 'O_corr' + + produitstot <- rbind(produitstot, temp[,colnames(produitstot)]) + } + } + } + } + + # modifs des types de donn?es, pour calcul par la suite + produitstot$danais <- as.Date(produitstot$danais, format = "%Y-%m-%d") + produitstot$dasort <- as.Date(produitstot$dasort, format = "%Y-%m-%d") + + produitstot$mere <- trim_str(produitstot$mere) + produitstot$pere <- trim_str(produitstot$pere) + produitstot$anim <- trim_str(produitstot$anim) + + produitstot$ravelamere <- as.numeric(produitstot$ravelamere) + produitstot$ivv <- as.numeric(produitstot$ivv) + produitstot$campn <- as.numeric(produitstot$campn) + produitstot$nbdescendants <- as.numeric(produitstot$nbdescendants) + + produitstot$ponais <- as.numeric(produitstot$ponais) + produitstot$pat04m <- as.numeric(produitstot$pat04m) + produitstot$pat07m <- as.numeric(produitstot$pat07m) + + produitstot$devsqe <- as.numeric(produitstot$devsqe) + produitstot$devmus <- as.numeric(produitstot$devmus) + produitstot$aptfon <- as.numeric(produitstot$aptfon) + + # on ne garde que les TE port?s par une vache active du cheptel + PRODTOT <- subset(produitstot, produitstot$indite != 'O') + + # ajout des produitstot IPG + PRODTOT <- merge(PRODTOT, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + PRODTOT <- PRODTOT[order(PRODTOT$danais, decreasing = F),] + PRODTOT <- PRODTOT[order(PRODTOT$mere, decreasing = T),] + + # correction des ravelamere des TE si possible + for (i in 1:nrow(PRODTOT)) { + if (is.na(PRODTOT$ravelamere[i])) { + if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] %in% c(1, 2)) { + PRODTOT$ravelamere[i] <- 1 + PRODTOT$typemere[i] <- 'G' + } else if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] > 1) { + PRODTOT$ravelamere[i] <- PRODTOT$ravelamere[i+1] - 1 + PRODTOT$typemere[i] <- 'V' + } + } + } + + # age au velage de la mere + PRODTOT$agevel <- round(time_length(interval(PRODTOT$danaismere, PRODTOT$danais), + unit="months"), 1) + + # IVV : utilisation de la colonne deja presente de HBCANIM + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$indite[i] == 'O_corr') { + PRODTOT$nobovi[i] <- paste('#', PRODTOT$nobovi[i], sep='') + } + # repro + if (PRODTOT$anim[i] %in% czhbc$ANIM + | (!is.na(PRODTOT$NBPRODIPG[i]) & PRODTOT$NBPRODIPG[i] > 0) + | (!is.na(PRODTOT$nbdescendants[i]) + & as.numeric(PRODTOT$nbdescendants[i]) > 0)) { + PRODTOT$repro[i] <- 'O' + } else { + PRODTOT$repro[i] <- NA + PRODTOT$nobovi[i] <- PRODTOT$nobovi[i] %>% str_to_lower() + } + # mortalite + if (!is.na(PRODTOT$dasort[i]) & !is.na(PRODTOT$casort[i]) + & PRODTOT$casort[i] == 'M' + & time_length(interval(PRODTOT$danais[i], PRODTOT$dasort[i]), + unit="days") < 211){ + PRODTOT$mortsev[i] <- 'O' + PRODTOT$nobovi[i]=paste(PRODTOT$nobovi[i], ' (MavS)', sep='') + } else { + PRODTOT$mortsev[i] <- NA + } + # IVV + if (i > 1) { + # cas normaux + if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + 1 + #& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] == '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- PRODTOT$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- round(time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + / (PRODTOT$ravelamere[i] + - PRODTOT$ravelamere[i-1]), 0) + } else { + PRODTOT$ivv[i] <- NA + } + } + } + + # calcul des effets du cheptel : rang de velage et sexe du veau + effet <- PRODTOT %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) + effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] + effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p120[1] + effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p210[1] + + # calcul des effets du cheptel : sexe sur la repro + effetsexe <- PRODTOT %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + + # report des effets sur les produitstot + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$sexbov[i] == '2') { #___________________________________ FEMELLES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] * rapport_MF + if (!is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #___genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #________________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] + if ( !is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #_________________________________genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } + } + + # calcul des donn?es ?labor?es par fille des taureaux + + for (i in 1:nrow(vachestot)) { + # ___________________________________________rappel des produitstot par vache + veaux <- PRODTOT %>% filter(mere == vachestot$anim[i]) + + # ___________________________________________calcul des infos utiles par vache + + # calcul du poids adulte estim? et synth?se pointage vache ___________________ + # même logique que classement carrière -> pondération doit être paramétrable + if (!is.na(vachestot$dmC[i])) { + vachestot$ptgV[i] <- round(0.6 * vachestot$dmC[i] + 0.15 * vachestot$ds[i] + + 0.25 * vachestot$af[i], 1) + } else { + vachestot$ptgV[i] <- NA + } + + if (nrow(veaux) > 3){ + vachestot$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2) + alpha <- 1.62 - 0.01 * vachestot$precocite[i] + } else { + vachestot$precocite[i] <- NA + alpha <- 1.62 + } + if (!is.na(vachestot$pat24m[i])) { + vachestot$pad[i] <- round((vachestot$pat24m[i] - 50 * exp(-720 * alpha * 10**(-3))) + / (1 - exp(-720 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat18m[i])) { + vachestot$pad[i] <- round((vachestot$pat18m[i] - 50 * exp(-540 * alpha * 10**(-3))) + / (1 - exp(-540 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat12m[i])) { + vachestot$pad[i] <- round((vachestot$pat12m[i] - 50 * exp(-360 * alpha * 10**(-3))) + / (1-exp(-360 * alpha * 10**(-3))), 1) + } else { + vachestot$pad[i] <- NA + } + + # calcul des perfs de repro et du temps productif ____________________________ + + vachestot$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1) + + if (1 %in% veaux$ravelamere) { + vachestot$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1] + } else { + vachestot$agevel1[i] <- NA + } + + if (2 %in% veaux$ravelamere) { + vachestot$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1] + } else { + vachestot$ivv1[i] <- NA + } + if (3 %in% veaux$ravelamere) { + vachestot$ivv2p[i] <- round(mean(subset(veaux, + veaux$ravelamere > 2)$ivv, na.rm=T), 1) + } + + if (is.na(vachestot$ivv1[i]) | (!is.na(vachestot$ivv1[i]) + & vachestot$ivv1[i] < 390) ){ + e2 <- 0 + } else if (!is.na(vachestot$ivv1[i]) & vachestot$ivv1[i] >= 390) { + e2 <- vachestot$ivv1[i] - 390 + } + if (is.na(vachestot$ivv2p[i]) | (!is.na(vachestot$ivv2p[i]) + & vachestot$ivv2p[i] < 365) ){ + e3 <- 0 + } else if (!is.na(vachestot$ivv2p[i]) & vachestot$ivv2p[i] >= 365) { + e3 <- vachestot$ivv1[i] - 365 + } + if (is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") - 365 + } + } else if (!is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") - 365 + } + } + + vachestot$tempsprod[i] <- round( (vachestot$age_days[i] + - ( vachestot$agevel1[i] * 30.4 + + e2 + + e3 * (vachestot$nbcampvel[i] - 2) + + e4 + )) / vachestot$age_days[i] * 100, 1) + + # calcul des donn?es synthetiques sur les produitstot ___________________________ + + vachestot$prol[i] <- round(nrow(veaux) / (vachestot$nbcampvel[i]) * 100, 1) + vachestot$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O')) + / nrow(veaux)* 100, 1) + vachestot$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O')) + / nrow(veaux)* 100, 1) + vachestot$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T) + vachestot$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T) + vachestot$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux)* 100, 1) + vachestot$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') )) + / nrow(veaux)* 100, 1) + vachestot$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE) + + 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1) + vachestot$pn_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$ponais, na.rm=T), 1) + vachestot$p120_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat04m, na.rm=T), 1) + vachestot$p210_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat07m, na.rm=T), 1) + vachestot$pn_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$ponais, na.rm=T), 1) + vachestot$p120_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat04m, na.rm=T), 1) + vachestot$p210_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat07m, na.rm=T), 1) + vachestot$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1) + vachestot$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1) + vachestot$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1) + + ### convertion des NaN en NA + L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr', + 'p210_m','p210_f','p210_corr') + for (j in L){ + if (is.nan(vachestot[i,j]) == TRUE){ + vachestot[i,j] <- NA + } + } + } + } + } + # calcul des stats par pere ____________________________________________________ + + stats_peres <- PRODDIR %>% group_by(pere) %>% + summarise(nb_prod_in_chep = n()) %>% filter(nb_prod_in_chep >=5) + + stats_peres <- stats_peres %>% + add_column(utilgen = NA, prol = NA, mort = NA, txrepros = NA, nbpp = NA, + txvf = NA, pnm = NA, pnf = NA, p120m = NA, p120f = NA, p210m = NA, + p210f = NA, dmsev = NA, dssev = NA, + nbfilles_avecprod = NA, pctfilles_avecprod = NA, + isu_fillestot = NA, age_sort_fillestot = NA, + agevel1_fillestot = NA, ivv1_fillestot = NA, ivv2p_fillestot = NA, + vieprod_fillestot = NA, dmad_fillestot = NA, dsad_fillestot = NA, + afad_fillestot = NA, nbprod_fillestot = NA, txrepros_fillestot = NA, + nbpp_fillestot = NA, prol_fillestot = NA, mort_fillestot = NA, + txvf_fillestot = NA, + nbfillesact_avecprod = NA, pctfillesact_avecprod = NA, + isu_fillesact = NA, age_sort_fillesact = NA, + agevel1_fillesact = NA, ivv1_fillesact = NA, ivv2p_fillesact = NA, + vieprod_fillesact = NA, dmad_fillesact = NA, dsad_fillesact = NA, + afad_fillesact = NA, nbprod_fillesact = NA, txrepros_fillesact = NA, + nbpp_fillesact = NA, prol_fillesact = NA, mort_fillesact = NA, + txvf_fillesact = NA, nbfilles_renouv = NA) + + for (i in 1:nrow(stats_peres)) { + # stats sur la prod directe __________________________________________________ + li_prod <- subset(PRODDIR, PRODDIR$pere == stats_peres$pere[i]) + + stats_peres$utilgen[i] <- round(nrow(subset(li_prod, + li_prod$ravelamere == 1)) + / nrow(li_prod) * 100, 1) + stats_peres$prol[i] <- round(nrow(li_prod) + / nrow(li_prod %>% distinct(danais, mere)) + * 100, 1) + stats_peres$mort[i] <- round(nrow(subset(li_prod, li_prod$mortsev == 'O')) + / nrow(li_prod) * 100, 1) + stats_peres$txrepros[i] <- round(nrow(subset(li_prod, li_prod$repro == 'O')) + / nrow(subset(li_prod, + is.na(li_prod$mortsev))) * 100, 1) + stats_peres$nbpp[i] <- sum(li_prod$nbdescendants) + stats_peres$txvf[i] <- round(nrow(subset(li_prod, li_prod$conais %in% c('1','2'))) + / nrow(li_prod) * 100, 1) + stats_peres$pnm[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$ponais, na.rm=T),1) + stats_peres$pnf[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$ponais, na.rm=T),1) + stats_peres$p120m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat04m, na.rm=T),1) + stats_peres$p120f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat04m, na.rm=T),1) + stats_peres$p210m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat07m, na.rm=T),1) + stats_peres$p210f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat07m, na.rm=T),1) + stats_peres$dmsev[i] <- round(mean(subset(li_prod, # -------------------------------A voir avec Lauréna si normal qu'on prenne dm pour male et ds pour femelles + li_prod$sexbov == '1')$devmus, na.rm=T),1) + stats_peres$dssev[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$devsqe, na.rm=T),1) + + # stats sur la prod par les filles ___________________________________________ + li_filles <- subset(vachestot, vachestot$pere == stats_peres$pere[i]) # on garde que les filles du père s'il a suffisament produit + + # modif du 30/04/2024 + if (nrow(li_filles) > 0){ + stats_peres$nbfilles_avecprod[i] <- nrow(li_filles) + stats_peres$pctfilles_avecprod[i] <- round(nrow(li_filles) #pct = pourcentage + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_filles) >= 3) { # si non pas assez pour stat, a voir si on garde la limite de 3 + stats_peres$isu_fillestot[i] <- round(mean(li_filles$indisu, na.rm=T),1) + stats_peres$age_sort_fillestot[i] <- round(mean(li_filles$age_years, na.rm=T),1) + stats_peres$agevel1_fillestot[i] <- round(mean(li_filles$agevel1, na.rm=T),1) + stats_peres$vieprod_fillestot[i] <- round(mean(li_filles$tempsprod, na.rm=T),1) + stats_peres$ivv1_fillestot[i] <- round(mean(li_filles$ivv1, na.rm=T),1) + stats_peres$ivv2p_fillestot[i] <- round(mean(li_filles$ivv2p, na.rm=T),1) + + stats_peres$dmad_fillestot[i] <- round(mean(li_filles$dmC, na.rm=T),1) + stats_peres$dsad_fillestot[i] <- round(mean(li_filles$ds, na.rm=T),1) + stats_peres$afad_fillestot[i] <- round(mean(li_filles$af, na.rm=T),1) + + stats_peres$prol_fillestot[i] <- round(mean(li_filles$prol, na.rm=T),1) + stats_peres$mort_fillestot[i] <- round(mean(li_filles$mort, na.rm=T),1) + stats_peres$txvf_fillestot[i] <- round(mean(li_filles$txvf, na.rm=T),1) + + stats_peres$nbprod_fillestot[i] <- round(sum(li_filles$nbdescendants),1) + stats_peres$txrepros_fillestot[i] <- round(mean(li_filles$txrepros, na.rm=T),1) + stats_peres$nbpp_fillestot[i] <- round(sum(li_filles$nbpp),1) + } + + # stats sur la prod par les filles actives ___________________________________ pertinent à garder ? + li_filles_act <- subset(vachestot, vachestot$pere == stats_peres$pere[i] + & is.na(vachestot$dasort)) + + # modif du 30/04/2024 + if (nrow(li_filles_act) > 0) { + stats_peres$nbfillesact_avecprod[i] <- nrow(li_filles_act) + stats_peres$pctfillesact_avecprod[i] <- round(nrow(li_filles_act) + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_filles_act) >= 3) { + stats_peres$isu_fillesact[i] <- round(mean(li_filles_act$indisu, na.rm=T),1) + stats_peres$age_sort_fillesact[i] <- round(mean(li_filles_act$age_years, na.rm=T),1) + stats_peres$agevel1_fillesact[i] <- round(mean(li_filles_act$agevel1, na.rm=T),1) + stats_peres$vieprod_fillesact[i] <- round(mean(li_filles_act$tempsprod, na.rm=T),1) + stats_peres$ivv1_fillesact[i] <- round(mean(li_filles_act$ivv1, na.rm=T),1) + stats_peres$ivv2p_fillesact[i] <- round(mean(li_filles_act$ivv2p, na.rm=T),1) + + stats_peres$dmad_fillesact[i] <- round(mean(li_filles_act$dmC, na.rm=T),1) + stats_peres$dsad_fillesact[i] <- round(mean(li_filles_act$ds, na.rm=T),1) + stats_peres$afad_fillesact[i] <- round(mean(li_filles_act$af, na.rm=T),1) + + stats_peres$prol_fillesact[i] <- round(mean(li_filles_act$prol, na.rm=T),1) + stats_peres$mort_fillesact[i] <- round(mean(li_filles_act$mort, na.rm=T),1) + stats_peres$txvf_fillesact[i] <- round(mean(li_filles_act$txvf, na.rm=T),1) + + stats_peres$nbprod_fillesact[i] <- round(sum(li_filles_act$nbdescendants),1) + stats_peres$txrepros_fillesact[i] <- round(mean(li_filles_act$txrepros, na.rm=T),1) + stats_peres$nbpp_fillesact[i] <- round(sum(li_filles_act$nbpp),1) + } + #filles a venir + nbfr <- nrow(subset(inventaire, + inventaire$pere == stats_peres$pere[i] + & inventaire$nbdescendants == 0 + & inventaire$sexbov == '2')) + if (nbfr > 0 ){ + stats_peres$nbfilles_renouv[i] <- nbfr + } + } + + stats_peres <- merge(peres, stats_peres, all.x=F, all.y=T) + + write.table(stats_peres, + file = paste(rep, '/', CHEP, '_ResTaureaux_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + + + ################################################################################ + ### remontee des lignees femelles ############################################## + ################################################################################ + + hbcgene_coltypes <- cols(anim = col_character(), nobovi = col_character(), + nomnais = col_character(), qualifco = col_character(), + pere = col_character(), mere = col_character(), + dcre = col_character(), danais = col_character(), + ifnais = col_integer(), crsevs = col_integer(), + dmsevs = col_integer(), dssevs = col_integer(), + alaits = col_integer(), isevre = col_integer(), + ivmate = col_integer(), iqmqms = col_integer(), + iabjbs = col_integer(), avelag = col_integer(), + indisu = col_integer(), + cdisev = col_number()) + + ## on remonte vers les fondatrices + + femelles <- inventaire %>% filter(sexbov == '2') + femelles[] <- lapply(femelles, function(x) if(is.logical(x)) as.character(x) else x) + + old <- Sys.time() + + t_travail <- femelles + t_temp = t_final <- inventaire[0,] + + line_mere <- inventaire[0,] + #line_mere$iqmqms = line_mere$iabjbs <- NA + + # mise en commentaire : 07/03/2023 + # t_travail[] <- lapply(t_travail, function(x) if(is.Date(x)) as.character(x) else x) + # t_final[] <- lapply(t_final, function(x) if(is.Date(x)) as.character(x) else x) + # t_temp[] <- lapply(t_temp, function(x) if(is.Date(x)) as.character(x) else x) + + t_travail[] <- lapply(t_travail, function(x) if(is.logical(x)) as.character(x) else x) + t_final[] <- lapply(t_final, function(x) if(is.logical(x)) as.character(x) else x) + t_temp[] <- lapply(t_temp, function(x) if(is.logical(x)) as.character(x) else x) + + nbl <- nrow(t_travail) + nb_tours <- 0 + + while (nbl > 0) { + for (i in 1:nrow(t_travail)) { + if (!is.na(t_travail$mere[i])) { + if ((trim_str(t_travail$mere[i]) %in% trim_str(t_final$anim)) + | (trim_str(t_travail$mere[i]) %in% trim_str(t_travail$anim)) + | (trim_str(t_travail$mere[i]) %in% trim_str(t_temp$anim))) { + #print(paste0(as.character(i), "D?ja list?e")) + } else { + #print(t_travail$mere[i]) + line_mere <- chgt_infos(trim_str(t_travail$mere[i])) + if (is.data.frame(line_mere)) { + if (nrow(line_mere) > 0 ) { + + # ajout du 07/03/2023 + line_mere <- line_mere[, intersect(names(line_mere), names(femelles))] + line_mere[] <- lapply(line_mere, function(x) if(is.logical(x)) as.character(x) else x) + for ( x in colnames(line_mere) ) { + line_mere[,x] <- eval(call( paste0("as.", class(femelles[,x])), line_mere[,x]) ) + } + + if (ncol(line_mere) > 22) { + # attribution a line_mere les memes types de col que inventaire + # afin de permettre la jointure sans erreur de type + + # modif : mise en commentaire 07/03/2023 + # line_mere$iqmqms = line_mere$iabjbs <- NA + # line_mere <- line_mere[, colnames(t_final)] + # line_mere[] <- mapply(FUN = as, line_mere, sapply(t_final, class), SIMPLIFY = FALSE) + + if ( !is.na(line_mere$chna) & trim_str(line_mere$chna) == CHEP) { + t_temp <- bind_rows(t_temp, line_mere) + } else { + #print("N?e ailleurs") + t_final <- bind_rows(t_final, line_mere) + } + } else { + #print("Ligne de Hbcgene") + # attribution a line_mere les types de col definis plus haut + # afin de permettre la jointure sans erreur de type + + # modif : mise en commentaire 07/03/2023 + # line_mere <- type.convert(line_mere, col_types = hbcgene_coltypes) + # line_mere$nobovi <- as.character(line_mere$nobovi) + + #cat(i, class(line_mere$indite), class(t_final$indite)) # pb de types + t_final <- bind_rows(t_final, line_mere) + } + } + } else { + #print("Retour vide du WS") + } + } + } else { + #print("Pas de mere") + } + } # for + t_final <- bind_rows(t_final, t_travail) + t_travail <- t_temp + t_temp <- t_temp[0,] + nbl <- nrow(t_travail) + nb_tours <- nb_tours+1 + print(paste("Nombre de g?n?rations depuis les animaux actifs : ", nb_tours, sep='')) + } # while + + inv_asc <- t_final + + fondatrices <- subset(inv_asc, is.na(t_final$mere) + | trim_str(t_final$chna) != CHEP + | is.na(t_final$chna) + | !(trim_str(inv_asc$mere) %in% trim_str(inv_asc$anim)) ) # modif du 27/03/2023 + + new <- Sys.time()-old + cat("Remont?e des lign?es :", round(new, 1) , "sec") + + # on redescendant vers tous les animaux n?s dans le cheptel issus des fondatrices + # on met de c?t? les vaches ayant produits a leur tour dans le cheptel + # ainsi que les males ayant produit (peu importe ou) + + old <- Sys.time() + + t_travail <- fondatrices + t_travail$fondatrice <- t_travail$anim + t_temp = t_final <- inventaire[0,] + t_final <- t_final %>% add_column(fondatrice = NA, iqmqms = NA, iabjbs = NA) + t_temp <- t_temp %>% add_column(fondatrice = NA, iqmqms = NA, iabjbs = NA) + + t_travail[] <- lapply(t_travail, function(x) if(is.logical(x)) as.character(x) else x) + t_final[] <- lapply(t_final, function(x) if(is.logical(x)) as.character(x) else x) + t_temp[] <- lapply(t_temp, function(x) if(is.logical(x)) as.character(x) else x) + # mise en commentaire : 07/03/2023 + # t_travail[] <- lapply(t_travail, function(x) if(is.Date(x)) as.character(x) else x) + # t_final[] <- lapply(t_final, function(x) if(is.Date(x)) as.character(x) else x) + # t_temp[] <- lapply(t_temp, function(x) if(is.Date(x)) as.character(x) else x) + + nbl <- nrow(t_travail) + nb_tours <- 0 + + while (nbl > 0) { + for (i in 1:nrow(t_travail)) { + cat(nbl, i, t_travail$anim[i], t_travail$nobovi[i], '\n') + produits <- try(appel_infos(trim_str(t_travail$anim[i]), reqMere)) + if (!is.null(produits)) { + + # MAJ du 07/03/2023 + produits <- produits[, intersect(names(produits), names(femelles))] + produits[] <- lapply(produits, function(x) if(is.logical(x)) as.character(x) else x) + for ( x in colnames(produits) ) { + produits[,x] <- eval(call( paste0("as.", class(femelles[,x])), produits[,x]) ) + } + + # modif : mise en commentaire 07/03/2023 + # produits$iqmqms = produits$iabjbs = produits$fondatrice <- NA + # produits <- produits[,colnames(t_final)] + # produits[] <- mapply(FUN = as, produits, sapply(t_final, class), SIMPLIFY = FALSE) + # produits[] <- lapply(produits, function(x) if(is.logical(x)) as.character(x) else x) + # produits[] <- lapply(produits, function(x) if(is.Date(x)) as.character(x) else x) + + produits <- subset(produits, trim_str(produits$chna) == CHEP) + if (length(produits) > 0 & nrow(produits) > 0){ + produits$fondatrice <- t_travail$fondatrice[i] + t_final <- bind_rows(t_final, produits) + repros <- subset(produits, produits$nbdescendants > 0 + & produits$sexbov == '2') + if (nrow(repros) > 0) { + t_temp <- bind_rows(t_temp, repros) + } + } + } + } # for + t_final <- bind_rows(t_final, t_travail) + t_travail <- t_temp + t_temp <- t_temp[0,] + nbl <- nrow(t_travail) + nb_tours <- nb_tours+1 + print(paste("Nombre de g?n?rations apras les fondatrices : ", nb_tours, sep='')) + } # while + + inv_desc <- t_final + + # doublons ??? + inv_desc <- inv_desc[-which(duplicated(inv_desc$anim)),] + if (nrow(inv_desc) == 0 ){ + inv_desc <- t_final + } + + # modif du 07/03/2023 + # pb du nombre de produits non ramenés par WS en appellant la mère + # inv_asc_not_in_desc <- inv_asc %>% filter( !(trim_str(anim) %in% trim_str(inv_desc$anim)) ) + # if ( nrow(inv_asc_not_in_desc) > 0) { + # inv_desc <- bind_rows(inv_desc, inv_asc_not_in_desc) + # } + + new <- Sys.time()-old + cat("Remont?e des lign?es :", round(new, 1)) + + # vaches tot + vachestot <- inv_desc %>% filter(sexbov == '2' & nbdescendants > 0) + produitstot <- subset(inv_desc, trim_str(inv_desc$mere) %in% trim_str(vachestot$anim)) + + if (nrow(vachestot) > 0) { + # recherche des meres dans les porteuses pour aller chercher + # les produitstot s'ils existent dans HBCANIM + + porteuses <- subset(indite, !is.na(indite$MEREIPG) + & indite$MEREIPG %in% trim_str(vachestot$anim)) + donneuses <- subset(indite, !is.na(indite$MERECPB) + & indite$MERECPB %in% trim_str(vachestot$anim)) + # l'indicateur de donneuse d'embryon est renseign? apres dans --> vachestot$ACINAC + + if ( is.numeric(vachestot$danais[1]) & vachestot$danais[1] > 1*(10**8) ) { + vachestot$danais <- as.Date(as.POSIXct(vachestot$danais / 1000, origin="1970-01-01")) + vachestot$dasort <- as.Date(as.POSIXct(vachestot$dasort / 1000, origin="1970-01-01")) + } + + for (i in 1:nrow(vachestot)) { + if (is.na(vachestot$dasort[i])){ + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], Sys.Date()), unit="days") + } else { + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], vachestot$dasort[i]), unit="days") + } + } + + vachestot$age_years <- round(vachestot$age_days / 365, 1) + + # les veaux port?s sont rajout?s aux produitstot si non r?cup?r?s avant ________ non appliqu? car raisonnement sur lign?es + # if (nrow(porteuses) > 0) { + # for (i in 1:nrow(porteuses)) { + # if (!(porteuses$ANIM[i] %in% trim_str(produitstot$anim))) { + # + # temp <- appel_infos(porteuses$ANIM[i], hbcanim) # a voir : gerer les retours vides !!!! + # li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i]) + # + # temp$mere[1] <- porteuses$MEREIPG[i] + # temp[1, c(60:67, 86:103)] <- NA + # temp$danaismere[1] <- as.character(li_mere$danais[1]) + # temp$indite[1] <- 'O_corr' + # + # produitstot <- rbind(produitstot, temp) + # } + # } + # } + + # modifs des types de donn?es, pour calcul par la suite + if ( is.numeric(produitstot$danais[1]) & produitstot$danais[1] > 1*(10**8) ) { + produitstot$danais <- as.Date(as.POSIXct(produitstot$danais / 1000, origin="1970-01-01")) + produitstot$dasort <- as.Date(as.POSIXct(produitstot$dasort / 1000, origin="1970-01-01")) + produitstot$danaismere <- as.Date(as.POSIXct(produitstot$danaismere / 1000, origin="1970-01-01")) + } + + test_date <- produitstot %>% filter( !is.na(danaismere) ) + if (nrow(test_date) > 0){ + if ( is.numeric(test_date$danaismere[1]) & test_date$danaismere[1] > 1*(10**8) ) { + produitstot$danaismere <- as.Date(as.POSIXct(produitstot$danaismere / 1000, origin="1970-01-01")) + } + } + + produitstot$danais <- as.Date(produitstot$danais, format = "%Y-%m-%d") + produitstot$dasort <- as.Date(produitstot$dasort, format = "%Y-%m-%d") + + produitstot$mere <- trim_str(produitstot$mere) + produitstot$pere <- trim_str(produitstot$pere) + produitstot$anim <- trim_str(produitstot$anim) + + produitstot$ravelamere <- as.numeric(produitstot$ravelamere) + produitstot$ivv <- as.numeric(produitstot$ivv) + produitstot$campn <- as.numeric(produitstot$campn) + produitstot$nbdescendants <- as.numeric(produitstot$nbdescendants) + + produitstot$ponais <- as.numeric(produitstot$ponais) + produitstot$pat04m <- as.numeric(produitstot$pat04m) + produitstot$pat07m <- as.numeric(produitstot$pat07m) + + produitstot$devsqe <- as.numeric(produitstot$devsqe) + produitstot$devmus <- as.numeric(produitstot$devmus) + produitstot$aptfon <- as.numeric(produitstot$aptfon) + + # on ne garde que les TE port?s par une vache active du cheptel + PRODTOT <- subset(produitstot, produitstot$indite != 'O') + + # ajout des produitstot IPG + PRODTOT <- merge(PRODTOT, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + PRODTOT <- PRODTOT[order(PRODTOT$danais, decreasing = F),] + PRODTOT <- PRODTOT[order(PRODTOT$mere, decreasing = T),] + + # correction des ravelamere des TE si possible + for (i in 1:nrow(PRODTOT)) { + if (is.na(PRODTOT$ravelamere[i])) { + if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] %in% c(1, 2)) { + PRODTOT$ravelamere[i] <- 1 + PRODTOT$typemere[i] <- 'G' + } else if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] > 1) { + PRODTOT$ravelamere[i] <- PRODTOT$ravelamere[i+1] - 1 + PRODTOT$typemere[i] <- 'V' + } + } + } + + # age au velage de la mere + PRODTOT$agevel <- round(time_length(interval(PRODTOT$danaismere, PRODTOT$danais), + unit="months"), 1) + + # IVV : utilisation de la colonne deja pr?sente de HBCANIM + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$indite[i] == 'O_corr') { + PRODTOT$nobovi[i] <- paste('#', PRODTOT$nobovi[i], sep='') + } + # repro + if (PRODTOT$anim[i] %in% czhbc$ANIM + | (!is.na(PRODTOT$NBPRODIPG[i]) & PRODTOT$NBPRODIPG[i] > 0) + | (!is.na(PRODTOT$nbdescendants[i]) + & as.numeric(PRODTOT$nbdescendants[i]) > 0)) { + PRODTOT$repro[i] <- 'O' + } else { + PRODTOT$repro[i] <- NA + PRODTOT$nobovi[i] <- PRODTOT$nobovi[i] %>% str_to_lower() + } + # mortalite + if (!is.na(PRODTOT$dasort[i]) & !is.na(PRODTOT$casort[i]) + & PRODTOT$casort[i] == 'M' + & time_length(interval(PRODTOT$danais[i], PRODTOT$dasort[i]), + unit="days") < 211){ + PRODTOT$mortsev[i] <- 'O' + PRODTOT$nobovi[i]=paste(PRODTOT$nobovi[i], ' (MavS)', sep='') + } else { + PRODTOT$mortsev[i] <- NA + } + # IVV + if (i > 1) { + # cas normaux + if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + 1 + #& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] == '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- PRODTOT$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- round(time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + / (PRODTOT$ravelamere[i] + - PRODTOT$ravelamere[i-1]), 0) + } else { + PRODTOT$ivv[i] <- NA + } + if (!is.na(PRODTOT$ivv[i]) & PRODTOT$ivv[i] < 280) { + PRODTOT$ivv[i] <- NA + } + } + } + + # calcul des effets du cheptel : rang de velage et sexe du veau + effet <- PRODTOT %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) + effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] + effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p120[1] + effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p210[1] + + # calcul des effets du cheptel : sexe sur la repro + effetsexe <- PRODTOT %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + + # report des effets sur les produitstot + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$sexbov[i] == '2') { #___________________________________ FEMELLES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] * rapport_MF + if (!is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #___genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #________________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] + if ( !is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #_________________________________genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } + } + + # calcul des donn?es ?labor?es par vache active + + for (i in 1:nrow(vachestot)) { + # ___________________________________________rappel des produitstot par vache + veaux <- PRODTOT %>% filter(mere == trim_str(vachestot$anim[i])) + + # ___________________________________________calcul des infos utiles par vache + + # calcul du poids adulte estim? et synthese pointage vache ___________________ + if (!is.na(vachestot$dmC[i])) { + vachestot$ptgV[i] <- round(0.6 * vachestot$dmC[i] + 0.15 * vachestot$ds[i] + + 0.25 * vachestot$af[i], 1) + } else { + vachestot$ptgV[i] <- NA + } + + if (nrow(veaux) > 3){ + vachestot$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2) + alpha <- 1.62 - 0.01 * vachestot$precocite[i] + } else { + vachestot$precocite[i] <- NA + alpha <- 1.62 + } + if (!is.na(vachestot$pat24m[i])) { + vachestot$pad[i] <- round((as.numeric(vachestot$pat24m[i]) - 50 * exp(-720 * alpha * 10**(-3))) + / (1 - exp(-720 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat18m[i])) { + vachestot$pad[i] <- round((as.numeric(vachestot$pat18m[i]) - 50 * exp(-540 * alpha * 10**(-3))) + / (1 - exp(-540 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat12m[i])) { + vachestot$pad[i] <- round((as.numeric(vachestot$pat12m[i]) - 50 * exp(-360 * alpha * 10**(-3))) + / (1-exp(-360 * alpha * 10**(-3))), 1) + } else { + vachestot$pad[i] <- NA + } + + # calcul des perfs de repro et du temps productif ____________________________ + + vachestot$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1) + + if (1 %in% veaux$ravelamere) { + vachestot$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1] + } else { + vachestot$agevel1[i] <- NA + } + + if (2 %in% veaux$ravelamere) { + vachestot$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1] + } else { + vachestot$ivv1[i] <- NA + } + if (3 %in% veaux$ravelamere) { + vachestot$ivv2p[i] <- round(mean(subset(veaux, + veaux$ravelamere > 2)$ivv, na.rm=T), 1) + } + + if (is.na(vachestot$ivv1[i]) | (!is.na(vachestot$ivv1[i]) + & vachestot$ivv1[i] < 390) ){ + e2 <- 0 + } else if (!is.na(vachestot$ivv1[i]) & vachestot$ivv1[i] >= 390) { + e2 <- vachestot$ivv1[i] - 390 + } + if (is.na(vachestot$ivv2p[i]) | (!is.na(vachestot$ivv2p[i]) + & vachestot$ivv2p[i] < 365) ){ + e3 <- 0 + } else if (!is.na(vachestot$ivv2p[i]) & vachestot$ivv2p[i] >= 365) { + e3 <- vachestot$ivv1[i] - 365 + } + if (is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") - 365 + } + } else if (!is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") - 365 + } + } + + vachestot$tempsprod[i] <- round( (vachestot$age_days[i] + - ( vachestot$agevel1[i] * 30.4 + + e2 + + e3 * (vachestot$nbcampvel[i] - 2) + + e4 + )) / vachestot$age_days[i] * 100, 1) + + # calcul des donn?es synthetiques sur les produitstot ___________________________ + + vachestot$prol[i] <- round(nrow(veaux) / (vachestot$nbcampvel[i]) * 100, 1) + vachestot$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O')) + / nrow(veaux)* 100, 1) + vachestot$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O')) + / nrow(veaux)* 100, 1) + vachestot$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T) + vachestot$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T) + vachestot$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux)* 100, 1) + vachestot$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') )) + / nrow(veaux)* 100, 1) + vachestot$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE) + + 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1) + vachestot$pn_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$ponais, na.rm=T), 1) + vachestot$p120_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat04m, na.rm=T), 1) + vachestot$p210_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat07m, na.rm=T), 1) + vachestot$pn_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$ponais, na.rm=T), 1) + vachestot$p120_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat04m, na.rm=T), 1) + vachestot$p210_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat07m, na.rm=T), 1) + vachestot$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1) + vachestot$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1) + vachestot$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1) + + ### convertion des NaN en NA + L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr', + 'p210_m','p210_f','p210_corr') + for (j in L){ + if (is.nan(vachestot[i,j]) == TRUE){ + vachestot[i,j] <- NA + } + } + } + } + + # calcul des stats par fondatrice ______________________________________________ + + stats_lignees <- PRODTOT %>% group_by(fondatrice) %>% + summarise(nb_desc_in_chep = n()) %>% filter(nb_desc_in_chep >=5) + + stats_lignees <- stats_lignees %>% + add_column(utilgen = NA, prol = NA, mort = NA, txrepros = NA, nbpp = NA, + txvf = NA, pnm = NA, pnf = NA, p120m = NA, p120f = NA, p210m = NA, + p210f = NA, dmsev = NA, dssev = NA, + nbfem_avecprod = NA, pctfem_avecprod = NA, + isu_femtot = NA, age_sort_femtot = NA, + agevel1_femtot = NA, ivv1_femtot = NA, ivv2p_femtot = NA, + vieprod_femtot = NA, dmad_femtot = NA, dsad_femtot = NA, + afad_femtot = NA, nbprod_femtot = NA, txrepros_femtot = NA, + nbpp_femtot = NA, prol_femtot = NA, mort_femtot = NA, + txvf_femtot = NA, + nbfemact_avecprod = NA, pctfemact_avecprod = NA, + isu_femact = NA, age_sort_femact = NA, + agevel1_femact = NA, ivv1_femact = NA, ivv2p_femact = NA, + vieprod_femact = NA, dmad_femact = NA, dsad_femact = NA, + afad_femact = NA, nbprod_femact = NA, txrepros_femact = NA, + nbpp_femact = NA, prol_femact = NA, mort_femact = NA, + txvf_femact = NA, nbfem_renouv = NA) + + for (i in 1:nrow(stats_lignees)) { + # stats sur la prod directe __________________________________________________ + li_prod <- subset(PRODTOT, PRODTOT$fondatrice == stats_lignees$fondatrice[i]) + + stats_lignees$utilgen[i] <- round(nrow(subset(li_prod, + li_prod$ravelamere == 1)) + / nrow(li_prod) * 100, 1) + stats_lignees$prol[i] <- round(nrow(li_prod) + / nrow(li_prod %>% distinct(danais, mere)) + * 100, 1) + stats_lignees$mort[i] <- round(nrow(subset(li_prod, li_prod$mortsev == 'O')) + / nrow(li_prod) * 100, 1) + stats_lignees$txrepros[i] <- round(nrow(subset(li_prod, li_prod$repro == 'O')) + / nrow(subset(li_prod, + is.na(li_prod$mortsev))) * 100, 1) + stats_lignees$nbpp[i] <- sum(li_prod$nbdescendants) + stats_lignees$txvf[i] <- round(nrow(subset(li_prod, li_prod$conais %in% c('1','2'))) + / nrow(li_prod) * 100, 1) + stats_lignees$pnm[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$ponais, na.rm=T),1) + stats_lignees$pnf[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$ponais, na.rm=T),1) + stats_lignees$p120m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat04m, na.rm=T),1) + stats_lignees$p120f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat04m, na.rm=T),1) + stats_lignees$p210m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat07m, na.rm=T),1) + stats_lignees$p210f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat07m, na.rm=T),1) + stats_lignees$dmsev[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$devmus, na.rm=T),1) + stats_lignees$dssev[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$devsqe, na.rm=T),1) + + # stats sur la prod par les fem ___________________________________________ + li_fem <- subset(vachestot, vachestot$fondatrice == stats_lignees$fondatrice[i]) + + # modif du 30/04/2024 + if (nrow(li_fem) > 0) { + stats_lignees$nbfem_avecprod[i] <- nrow(li_fem) + stats_lignees$pctfem_avecprod[i] <- round(nrow(li_fem) + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_fem) >= 3) { + stats_lignees$isu_femtot[i] <- round(mean(li_fem$indisu, na.rm=T),1) + stats_lignees$age_sort_femtot[i] <- round(mean(li_fem$age_years, na.rm=T),1) + stats_lignees$agevel1_femtot[i] <- round(mean(li_fem$agevel1, na.rm=T),1) + stats_lignees$vieprod_femtot[i] <- round(mean(li_fem$tempsprod, na.rm=T),1) + stats_lignees$ivv1_femtot[i] <- round(mean(li_fem$ivv1, na.rm=T),1) + stats_lignees$ivv2p_femtot[i] <- round(mean(as.numeric(li_fem$ivv2p), na.rm=T),1) + + stats_lignees$dmad_femtot[i] <- round(mean(li_fem$dmC, na.rm=T),1) + stats_lignees$dsad_femtot[i] <- round(mean(li_fem$ds, na.rm=T),1) + stats_lignees$afad_femtot[i] <- round(mean(li_fem$af, na.rm=T),1) + + stats_lignees$prol_femtot[i] <- round(mean(li_fem$prol, na.rm=T),1) + stats_lignees$mort_femtot[i] <- round(mean(li_fem$mort, na.rm=T),1) + stats_lignees$txvf_femtot[i] <- round(mean(li_fem$txvf, na.rm=T),1) + + stats_lignees$nbprod_femtot[i] <- round(sum(li_fem$nbdescendants),1) + stats_lignees$txrepros_femtot[i] <- round(mean(li_fem$txrepros, na.rm=T),1) + stats_lignees$nbpp_femtot[i] <- round(sum(li_fem$nbpp),1) + } + + # stats sur la prod par les fem actives ___________________________________ + li_fem_act <- subset(vachestot, vachestot$fondatrice == stats_lignees$fondatrice[i] + & is.na(vachestot$dasort)) + + # modif du 30/04/2024 + if (nrow(li_fem_act) > 0) { + stats_lignees$nbfemact_avecprod[i] <- nrow(li_fem_act) + stats_lignees$pctfemact_avecprod[i] <- round(nrow(li_fem_act) + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_fem_act) >= 3) { + stats_lignees$isu_femact[i] <- round(mean(li_fem_act$indisu, na.rm=T),1) + stats_lignees$age_sort_femact[i] <- round(mean(li_fem_act$age_years, na.rm=T),1) + stats_lignees$agevel1_femact[i] <- round(mean(li_fem_act$agevel1, na.rm=T),1) + stats_lignees$vieprod_femact[i] <- round(mean(li_fem_act$tempsprod, na.rm=T),1) + stats_lignees$ivv1_femact[i] <- round(mean(li_fem_act$ivv1, na.rm=T),1) + stats_lignees$ivv2p_femact[i] <- round(mean(as.numeric(li_fem_act$ivv2p), na.rm=T),1) + + stats_lignees$dmad_femact[i] <- round(mean(li_fem_act$dmC, na.rm=T),1) + stats_lignees$dsad_femact[i] <- round(mean(li_fem_act$ds, na.rm=T),1) + stats_lignees$afad_femact[i] <- round(mean(li_fem_act$af, na.rm=T),1) + + stats_lignees$prol_femact[i] <- round(mean(li_fem_act$prol, na.rm=T),1) + stats_lignees$mort_femact[i] <- round(mean(li_fem_act$mort, na.rm=T),1) + stats_lignees$txvf_femact[i] <- round(mean(li_fem_act$txvf, na.rm=T),1) + + stats_lignees$nbprod_femact[i] <- round(sum(li_fem_act$nbdescendants),1) + stats_lignees$txrepros_femact[i] <- round(mean(li_fem_act$txrepros, na.rm=T),1) + stats_lignees$nbpp_femact[i] <- round(sum(li_fem_act$nbpp),1) + } + # filles a venir + nbfr <- nrow(subset(inv_desc, + inv_desc$fondatrice == stats_lignees$fondatrice[i] + & inv_desc$nbdescendants == 0 + & inv_desc$sexbov == '2' + & inv_desc$actif == '1')) + if (nbfr > 0) { + stats_lignees$nbfem_renouv[i] <- nbfr + } + } + + fondatrices$anim <- trim_str(fondatrices$anim) + stats_lignees$fondatrice <- trim_str(stats_lignees$fondatrice) + stats_lignees <- merge(fondatrices[,c('anim', 'nobovi', 'danais', 'nomnais')], + stats_lignees, by.x='anim', by.y='fondatrice', all.x=F, all.y=T) + + write.table(stats_lignees, + file = paste(rep, '/', CHEP, '_ResLigneesF_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + + ################################################################################ + ### tracé des lignées sur PDF __________________________________________________ + ################################################################################ + + # modif 27/03/2023 : + # déduction campagne en cours pour garder les femelles de renouvellement + # sans les laitonnes de la campagne en cours + camp_actuelle = ifelse(month(Sys.Date()) %in% c('08','09','10','11','12'), + year(Sys.Date()) + 1, + year(Sys.Date())) + + fem_tot <- inv_desc %>% filter(sexbov == '2' & campn < camp_actuelle & (nbdescendants > 0 | actif == '1')) + + # modif 27/03/2023 : + # modif de la valeur "actif" pour mettre en rouge les vaches actives ailleurs + fem_tot$actif <- ifelse(fem_tot$actif == '1' & trim_str(fem_tot$chepdet) == CHEP, '1', '0') + + fem_tot$anim <- trim_str(fem_tot$anim) + fem_tot$mere <- trim_str(fem_tot$mere) + fem_tot$pere <- trim_str(fem_tot$pere) + for (i in 1:nrow(fem_tot)) { + if (fem_tot$indite[i] == 'O') { + fem_tot$nobovi[i] <- paste(fem_tot$nobovi[i], ' (TE)', sep='') + } + if (fem_tot$nbdescendants[i] == 0) { + fem_tot$nobovi[i] <- fem_tot$nobovi[i] %>% tolower() + } + if (fem_tot$corabo[i] == '38'){ + fem_tot$corabo[i] <- 'CHAROLAISE' + } else { + fem_tot$corabo[i] <- 'CROISEE' + } + if (fem_tot$sexbov[i] == '2') { + fem_tot$sexbov[i] <- 'female' + } else if (fem_tot$sexbov[i] == '1'){ + fem_tot$sexbov[i] <- 'male'} + if (is.na(fem_tot$nobovi[i])){ + fem_tot$nobovi[i] <- paste(str_sub(fem_tot$anim[i], -4), + subset(LETTRES, LETTRES$ANNEE == fem_tot$campn[i])[1,'LETTRE'], sep='_') + } + } + + cla_rg <- tabfinal[,c('NUM_VACHE', 'rang CARRIERE')] + nbvcla <- nrow(subset(cla_rg, !is.na(cla_rg$`rang CARRIERE`))) + for(i in 1:nrow(cla_rg)) { + if (!is.na(cla_rg$`rang CARRIERE`[i])){ + cla_rg$`rang CARRIERE`[i] <- paste('eCow : ', cla_rg$`rang CARRIERE`[i], ' / ', nbvcla, sep='') + } else { + cla_rg$`rang CARRIERE`[i] <- 'eCow : NC' + } + } + + sub_ped <- fem_tot[,c('anim', 'pere', 'mere', 'sexbov', 'corabo', 'campn', 'actif', 'nobovi')] + sub_ped <- merge(sub_ped, cla_rg, by.x='anim', by.y='NUM_VACHE', all.x=T, all.y=T) + colnames(sub_ped)=c('Indiv','Sire','Dam','Sex','Breed','Born','Affected','Nom','ecowcarr') + + Pedig <- prePed(sub_ped) + for(i in 1:nrow(Pedig)) { + if (is.na(Pedig$ecowcarr[i])){ + Pedig$ecowcarr[i] <- '' + } + if (!is.na(Pedig$Sex[i]) & Pedig$Sex[i] == 'male'){ + toro <- subset(inv_desc, trim_str(inv_desc$pere) == Pedig$Indiv[i]) + Pedig$Nom[i] <- toro$nompere[1] + } + if (!is.na(Pedig$Sex[i]) & Pedig$Sex[i] == 'female' & is.na(Pedig$Nom[i]) ){ + mom <- subset(inv_desc, trim_str(inv_desc$mere) == Pedig$Indiv[i]) + Pedig$Nom[i] <- mom$nommere[1] + } + } + + img=readPNG("C:/Users/LJeannot/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/IMPORTS_R/HBC-Logo.png") + + dir.create(path=paste(rep, "/", CHEP, '_pdf_ligneesF', sep='')) + sousrep=paste(rep, "/" ,CHEP, '_pdf_ligneesF', sep='') + + fondatrices$anim <- trim_str(fondatrices$anim) + fondatrices <- subset(fondatrices, (fondatrices$nbdescendants > 0 | is.na(fondatrices$nbdescendants)) + & fondatrices$anim %in% trim_str(fem_tot$fondatrice)) + + if (nrow(fondatrices) > 0) { + for (i in 1:nrow(fondatrices)) { + print(fondatrices$anim[i]) + sPed <- subPed(Pedig, keep=fondatrices$anim[i], prevGen=0, succGen=10) + taille <- nrow(sPed) + print(taille) + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100, 1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)) { + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n') + } + tryCatch( + expr = { + if (nrow(sPed) > 1 & nbt > 0) { + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], '.pdf', sep='') + pdf(file = paste(sousrep, "/", nom, sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? a droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2, 2, 2, 5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == '1', "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 15, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette lignee representent ',tx2,"% des vaches en production du cheptel.",sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 20, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ',tx,"% des vaches actives de cette lignee appartiennent a la moitie superieure classee du cheptel.",sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + } + + if (taille >= 80){ + z <- subset(fem_tot, fem_tot$mere == fondatrices$anim[i]) + if (nrow(z) > 1){ + for (k in 1:nrow(z)){ + sPed <- subPed(Pedig, keep=z$anim[k], prevGen=0, succGen=10) + taille <- nrow(sPed) + + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100,1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)){ + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n') + } + + if (nrow(sPed) > 1 & nbt > 0){ + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], '_sl_', z$anim[k], '.pdf', sep='') + pdf(file = paste(sousrep, "/", nom, sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? a droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2,2,2,5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0, + paste('Sous-lignee : fille', z$nobovi[k], str_sub(z$anim[k], -4), sep=' '), + srt=270, cex=0.6, col='dark red', font=1) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette sous-lignee representent ', + tx2, "% des vaches en production du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ', tx, + "% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + + + if (taille >= 80){ + a <- subset(fem_tot, fem_tot$mere == z$anim[k]) + if (nrow(a) > 1){ + for (n in 1:nrow(a)){ + sPed <- subPed(Pedig, keep=a$anim[n], prevGen=0, succGen=10) + taille <- nrow(sPed) + + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100, 1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)){ + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j],-4), sPed$Nom[j], sep='\n') + } + + if (nrow(sPed) > 1 & nbt > 0){ + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], + '_ssl_', z$anim[k], '_', a$anim[n], '.pdf',sep='') + pdf(file = paste(sousrep,"/",nom,sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? ? droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2,2,2,5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0, + paste('Sous-lignee : petite-fille',a$nobovi[n], str_sub(a$anim[n],-4),sep=' '), + srt=270, cex=0.6, col='dark red', font=1) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette sous-lignee representent ', + tx2, "% des vaches en production du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ', tx, + "% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + } + } + } + } + + } + } + } else { + w <- subset(fem_tot, fem_tot$mere == z$anim[1]) + if (nrow(w) > 1){ + for (m in 1:nrow(w)){ + sPed <- subPed(Pedig, keep=w$anim[m], prevGen=0, succGen=10) + taille <- nrow(sPed) + + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100, 1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)){ + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n') + } + + if (nrow(sPed) > 1 & nbt > 0){ + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], + '_ssl_', w$anim[m], '.pdf', sep='') + pdf(file = paste(sousrep, "/", nom, sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? ? droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2,2,2,5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lign?e :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0, + paste('Sous-lignee : petite-fille', w$nobovi[m], str_sub(w$anim[m], -4), sep=' '), + srt=270, cex=0.6, col='dark red', font=1) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette sous-lignee representent ', + tx2, "% des vaches en production du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ', tx, + "% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + } + } + } + + } + } + }, + error = function(erreur) { + print("Erreur") + } + ) + } + } + + contenu <- as.data.frame(list.files(paste0(rep, "/", CHEP, '_pdf_ligneesF'))) + + if (nrow(contenu) > 0) { + staple_pdf(input_directory = sousrep, + input_files = NULL, + output_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''), + overwrite = TRUE) + + rotate_pdf(page_rotation = 270, + input_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''), + output_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''), + overwrite = TRUE) + } + + unlink(paste(rep, '/', CHEP, '_pdf_ligneesF', sep=''), recursive=TRUE) + + new=Sys.time()-old + print(paste('Trac? des lign?es femelles :',new,sep='')) + + + ### g?n?ration du rapport HTML ################################################ + + # a revoir pour les petits cheptels + render_report(CHEP, TECH, date_imp) + + render_synthese(CHEP, TECH, date_imp) + + # temps total + NEW <- Sys.time() - OLD + print(paste("Temps total d'execution :", NEW, sep='')) + } else { + print("inventaire vide") + } +} + + +################################################################################ +### saisie des cheptels ? sortir ############################################### +################################################################################ + +# CHEP <- 'FR63119077' # avec le FR +# TECH <- 'GADES' +# +# render_all_fic(CHEP, TECH) +# +# +# render_report(CHEP, TECH, date_imp) +# render_synthese(CHEP, TECH, date_imp) + + +################################################################################ +### requete sur les cheptels ? rechercher pr?vus en tourn?e #################### +################################################################################ + +# dept_tech <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/IMPORTS_R/dept_tech.csv", +# ";", escape_double = FALSE, locale = locale(encoding = "ISO-8859-1"), +# trim_ws = TRUE) +# +# +# itic <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcitic/finddatefieldbynamedquery/Hbcitic.findByPrevejo/" +# date_req <- Sys.Date() +# li_dates <- seq(as.Date(Sys.Date()), as.Date(Sys.Date()+21), by="days") +# +# itineraires <- fromJSON(paste(itic, "2021-06-11", sep=''))[0,] +# +# for (i in 1:length(li_dates)){ +# it <- fromJSON(paste(itic, li_dates[i], sep='')) +# itineraires <- bind_rows(itineraires, it) +# } +# +# li_erreurs <- c() +# for (i in 1:nrow(itineraires)) { +# CHEP <- paste('FR', substr(itineraires$nuchep[i],1,8) , sep='') +# if (itineraires$codoper[i] %in% c('ERLAM', 'STBIL', 'FRROB', 'JEAUC', 'GADES', 'ETJON', 'LOCDG', 'ANHUV')) { +# TECH <- itineraires$codoper[i] +# } else { +# li_tech <- subset(dept_tech, dept_tech$num == substr(itineraires$nuchep[i], 1, 2)) +# TECH <- li_tech$tech1[1] +# } +# cat(CHEP, TECH, '\n') +# if (dir.exists(path=paste(rep_exp, TECH, '/', CHEP, sep='')) == FALSE +# | file.exists(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), +# '/', CHEP, '_synthese_eCow5.html', sep = "")) == FALSE) { +# # tryCatch( +# # expr = { +# render_all_fic(CHEP, TECH) +# # }, +# # error = function(e) { +# # cat('ERREUR CALCUL', CHEP, '\n') +# # append(li_erreurs, CHEP) +# # }) +# #render_all_fic(CHEP, TECH) +# } +# } +# print(li_erreurs) + + +################################################################################ +### requete sur les cheptels d'une liste d?finie ############################### +################################################################################ +options(timeout = 1200) + +li_chep <- c( + "FR63118167" +) + +TECH <- 'VN2025' + +li_erreurs <- c() +for (i in 1:length(li_chep)) { + CHEP <- li_chep[i] + cat(CHEP, TECH, '\n') + if (dir.exists(path=paste(rep_exp, TECH, '/', CHEP, sep='')) == FALSE + | file.exists(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), + '/', CHEP, '_synthese_eCow5.html', sep = "")) == FALSE) { + tryCatch( + expr = { + render_all_fic(CHEP, TECH) + }, + error = function(e) { + cat('ERREUR CALCUL', CHEP) + li_erreurs[[(length(li_erreurs) + 1)]] <- CHEP + }) + render_all_fic(CHEP, TECH) + } +} + + +adh_avril2024 <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/Bureau/adhhbc_20240429.csv", + delim = ";", escape_double = FALSE, trim_ws = TRUE) +adh_avril2024$export <- NA + +for (i in 1:nrow(adh_avril2024)){ + + CHEP <- adh_avril2024$CHEP[i] + TECH <- adh_avril2024$TECH[i] + cat(CHEP, TECH, '\n') + + tryCatch( + expr = { + render_all_fic(CHEP, TECH) + }, + error = function(e){ + cat('ERREUR CALCUL', CHEP, "\n") + adh_avril2024$export[i] <- "ERREUR" + } + ) + +} + + +################################################################################ +### requete ? partir d'un fichier de cheptels et techs ######################## +################################################################################ + +# +# li_spec <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/Bureau/pre_engagement_VN2023_14juin.csv", +# ";", escape_double = FALSE, trim_ws = TRUE) +# +# li_erreurs <- c() +# +# for (i in 1:nrow(li_spec)) { +# CHEP <- li_spec$cheptel[i] +# TECH <- li_spec$tech[i] +# cat(CHEP, TECH, '\n') +# tryCatch( +# expr = { +# render_all_fic(CHEP, TECH) +# }, +# error = function(e) { +# cat('ERREUR CALCUL', CHEP) +# li_erreurs[[(length(li_erreurs) + 1)]] <- CHEP +# }) +# #render_all_fic(CHEP, TECH) +# } + + +################################################################################ +### SCRIPT d'ARCHIVAGE des VIEUX FICHIERS/DOSSIERS ############################# +################################################################################ + + +# # contenu du dossier EXPORT +# li_doc_rep <- as.data.frame(list.files(path = rep_exp)) +# +# #contenu des dossiers TECH +# li_doc_sousrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[2,1], sep = ''))) +# #contenu des dossiers CHEPTEL +# li_doc_ssrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[2,1], '/', li_doc_sousrep[1,1], sep = ''))) +# +# auj <- Sys.time() +# +# nb_fic_supp <- 0 +# nb_fic_archive <- 0 +# +# for (i in 2:nrow(li_doc_rep)) { +# # contenu des dossiers TECH +# li_doc_sousrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[i,1], sep = ''))) +# for (j in 1:nrow(li_doc_sousrep)) { +# # contenu des dossiers CHEPTEL +# li_doc_ssrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''))) +# +# dc <- file.info(paste(rep_exp, li_doc_rep[i,1], '/',li_doc_sousrep[j,1], '/',li_doc_ssrep[1,1], sep = ''))$ctime +# #cat(dc, '\n') +# +# if (is.na(dc)) { # si dossier vide, on le supprime +# print('VIDE') +# print(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = '')) +# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''), recursive = TRUE) +# nb_fic_supp <- nb_fic_supp + 1 +# +# } else if (time_length(interval(dc, auj), "days") > 180) { # sinon on l'archive +# print('VIEUX') +# print(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = '')) +# nb_fic_archive <- nb_fic_archive + 1 +# +# # on supprime les fichiers html et pdf (car volumineux) +# if (file.exists(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_ArbreLigneesF_eCow5.pdf', sep = ''))) { +# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_ArbreLigneesF_eCow5.pdf', sep = ''), recursive = TRUE) +# } +# if (file.exists(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_rapport_eCow5.html', sep = ''))) { +# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_rapport_eCow5.html', sep = ''), recursive = TRUE) +# } +# if (file.exists(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_synthese_eCow5.html', sep = ''))) { +# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_synthese_eCow5.html', sep = ''), recursive = TRUE) +# } +# +# # on archive les fichiers csv en dehors du fichier export ------------------------------------- date à modifier !!!!!!!!!!!!!!! +# dir.create(paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/archives_EXPORTS_R/20231205/", li_doc_sousrep[j,1], sep='')) +# li_doc_ssrep2 <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''))) +# for (k in 1:nrow(li_doc_ssrep2)) { +# filesstrings::file.move(paste(rep_exp, li_doc_rep[i,1], '/',li_doc_sousrep[j,1], '/',li_doc_ssrep2[k,1], sep = ''), +# paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/archives_EXPORTS_R/20231205/", li_doc_sousrep[j,1], sep='')) +# } +# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''), recursive = TRUE) +# +# } +# } +# print(paste("NB fichiers supprimes : ", nb_fic_supp, sep='')) +# print(paste("NB fichiers archives : ", nb_fic_archive)) +# } + + +################################################################################ +### Fonction de recuperation des classements eCow pour la Vente Nationale 2022 ### +################################################################################ + + +li_vn <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/VN/VN2025_liste_meres.csv", delim = ";") + +li_vn$NOM_MERE = li_vn$AGE = li_vn$nb_VA_tot = li_vn$nb_VA_cla = li_vn$rg <- NA +# clsst = data.frame(matrix(NA, ncol = 6, nrow = 1)) +# colnames(clsst) = c('ANIM', 'NOBOVI', 'AGE', 'nb_VA_tot', 'nb_VA_cla', 'rg') + +for(i in 1:nrow(li_vn)){ + print(i) + CHEP = li_vn$CHEPDET[i] + #TECH = li_vn$TECH[i] + ANIM = li_vn$MERE[i] + ## si le fichier existe + pathVN = "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/EXPORTS_2/VN2025" #paste(rep_exp, TECH, '/', CHEP, sep='') + if (dir.exists(path = pathVN) == TRUE + & file.exists(paste(pathVN, '/', CHEP,'/', CHEP, '_classement_eCow5.csv', sep = "")) == TRUE) { + ## si il est assez recent : < 3 mois + if( file.info(paste(pathVN, '/', CHEP,'/', CHEP, '_classement_eCow5.csv', sep = ""))$ctime > "2022-03-27") { + # on va chercher les infos + recup <- read_delim( paste(pathVN, '/', CHEP, '/', CHEP, '_classement_eCow5.csv', sep = ""), + delim = ";", escape_double = FALSE, + locale = locale(decimal_mark = ","), + trim_ws = TRUE) + li_vn$nb_VA_tot[i] = nrow(recup) + x = subset(recup, recup$NUM_VACHE == ANIM) + cla = subset(recup, !is.na(recup$`rang CARRIERE`)) + if(nrow(x) > 0){ + li_vn$NOM_MERE[i] = x$NOM_VACHE[1] + li_vn$AGE[i] = x$`AGE (annees)`[1] + li_vn$rg[i] = x$`rang CARRIERE`[1] + li_vn$nb_VA_cla[i] = nrow(cla) + } else { + li_vn$rg[i] = 'abs' + } + } else { + print("else0") + ## sinon on le genere + # tryCatch( + # expr = { + # render_all_fic(CHEP, TECH) + # }, + # error = function(e) { + # cat('ERREUR CALCUL', CHEP, '\n') + # }) + # ## puis on va chercher le fichier + # recup <- read_delim( paste( paste(rep_exp, TECH, '/' ,CHEP, sep=''), + # '/', CHEP, '_classement_eCow5.csv', sep = ""), + # delim = ";", escape_double = FALSE, + # locale = locale(decimal_mark = ","), + # trim_ws = TRUE) + # li_vn$nb_VA_tot[i] = nrow(recup) + # x = subset(recup, recup$NUM_VACHE == ANIM) + # cla = subset(recup, !is.na(recup$`rang CARRIERE`)) + # if(nrow(x) > 0){ + # li_vn$NOBOVI[i] = x$NOM_VACHE[1] + # li_vn$AGE[i] = x$`AGE (annees)`[1] + # li_vn$rg[i] = x$`rang CARRIERE`[1] + # li_vn$nb_VA_cla[i] = nrow(cla) + # } else { + # li_vn$rg[i] = 'abs' + # } + } + + } else { + print("else1") + ## sinon on genere le fichier + # tryCatch( + # expr = { + # render_all_fic(CHEP, TECH) + # }, + # error = function(e) { + # cat('ERREUR CALCUL', CHEP, '\n') + # }) + # ## puis on va chercher le fichier + # recup <- read_delim( paste( paste(rep_exp, TECH, '/' ,CHEP, sep=''), + # '/', CHEP, '_classement_eCow5.csv', sep = ""), + # delim = ";", escape_double = FALSE, + # locale = locale(decimal_mark = ","), + # trim_ws = TRUE) + # li_vn$nb_VA_tot[i] = nrow(recup) + # x = subset(recup, recup$NUM_VACHE == ANIM) + # cla = subset(recup, !is.na(recup$`rang CARRIERE`)) + # if(nrow(x) > 0){ + # li_vn$NOBOVI[i] = x$NOM_VACHE[1] + # li_vn$AGE[i] = x$`AGE (annees)`[1] + # li_vn$rg[i] = x$`rang CARRIERE`[1] + # li_vn$nb_VA_cla[i] = nrow(cla) + # } else { + # li_vn$rg[i] = 'abs' + # } + } +} + +write.table(li_vn, + file = "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/VN/VN2025_eCow_MERES.csv", + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") diff --git a/R/project/old_ecow_general.R b/R/project/old_ecow_general.R new file mode 100755 index 0000000..5701443 --- /dev/null +++ b/R/project/old_ecow_general.R @@ -0,0 +1,3705 @@ + +# version finale eCow - 5eme calcul +# LJ - 01/07/2021 + +################################################################################ +### chgt des libraries ######################################################### +################################################################################ + +library(tidyverse) +library(lubridate) +library(jsonlite) + +library(optiSel) +library(staplr) +library(png) +library(grid) + +options(scipen = 999) #permet d'?crire les nombres en entier quand ils sont au format scientifique +# necessaire pour la convertion des dates au format unix + +################################################################################ +### chgt des fichiers et donn?es utiles ######################################## +################################################################################ + +rep_exp <- "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/EXPORTS_2/" + +rep_imp <- "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/IMPORTS_R/" + +date_imp <- as.Date("2025-06-18") + +adhhbc <- read_delim(paste(rep_imp, "adhhbc_20250618.csv", sep=''), # ok 20230327 + ";", escape_double = FALSE, trim_ws = TRUE) + +czhbc <- read_csv(paste(rep_imp, "cz_20250618.csv", sep='')) # ok 20230327 + +LETTRES <- read_delim(paste(rep_imp, "LETTRES.csv", sep=''), + ";", escape_double = FALSE, trim_ws = TRUE) + +indite <- read_csv(paste(rep_imp, "indite_20250618.csv", sep=''), # ok 20230327 + col_types = cols(DANAIS = col_date(format = "%Y-%m-%d"))) +indite <- indite[-which(duplicated(indite$ANIM)),] +#$indite <- subset(indite, !is.na(indite$MEREIPG)) + +meresIPG <- read_csv(paste(rep_imp, "nbprodIPG_byMERE_20250618.csv", sep='')) # ok 20230327 +colnames(meresIPG) <- c('ANIM','NBPRODIPG') + +peresIPG <- read_csv(paste(rep_imp, "nbprodIPG_byPERE_20250618.csv", sep='')) # ok 20230327 +colnames(peresIPG) <- c('ANIM','NBPRODIPG') + +parentsIPG <- rbind(meresIPG, peresIPG) + +### liste des webservices ###################################################### + +# appel du listing d'un cheptel +webappli <- "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/findbyactivecheptel/" + +# appel de l'IC pour un animal +hbcanim <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/" + +# appel de hbcgene pour un animal +hbcgene <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcgene/" + +# liste des produits d'une vache +reqMere <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/findstringfieldbynamedquery/Hbcanim.findByMere/" + +# liste des produits d'un taureau +reqPere <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/findstringfieldbynamedquery/Hbcanim.findByPere/" + +# liste des produits d'un animal n?s dans un cheptel cible +reqProdNaiss <- "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/findProductByAnimAndChna/" +# ? completer par anim/chna, ex : FR7121831530/FR71499477 + +#_______________________________________________________________PONDERATIONS AHP +## Ponderations Carriere #### +Pcar=data.frame(type='final', agevel1_n=3, ivv1_n=6, ivv2p_n=12, + ptgv_n=4, pad_n=2, prol_n=2, mort_n=12, + txrepros_n=8, nbpp_n=10, txm_n=1, txvf_n=10, + ptgp_n=6, pn_n=4, p120_n=10, p210_n=10) + +### Ponderations Campagne #### +Pcamp=rbind(data.frame(type='AHPtech', pn_n=5.3, txvf_n=14.9, txm_n=4.5, + ptgp_n=8.2, p120_n=15.1, p210_n=12.6, + prol_n=3.2, mort_n=19.9, ivv_n=16.2), + data.frame(type='final', pn_n=6, txvf_n=15, txm_n=1, + ptgp_n=9, p120_n=15, p210_n=15, + prol_n=3, mort_n=18, ivv_n=18)) +# pond?rations finales ajustees ? partir de l'enquete +# peut etre pas judicieux + +################################################################################ +### fonctions utiles ########################################################### +################################################################################ + +# suppression des espaces superflus +trim_str = function (string) { + gsub("\\s+", " ", gsub("^\\s+|\\s+$", "", string)) +} + +# recuperation de l'inventaire des animaux actifs du cheptel +get_inventaire <- function(cheptel) { + old <- Sys.time() + # liste des animaux du cheptel + lichep <- fromJSON(paste(webappli, cheptel, sep='')) + inventaire <- lichep$hbcanim + # calcul du temps de chargement + new <- Sys.time()-old + cat("Chargement de l'inventaire :", round(new, 1) , "sec \n") + # resultat + return(inventaire) +} + +# mise en forme d'un retour de WS sous forme de dataframe +# necessaire quand l'appel ne concerne qu'un animal car le retour est une liste nomm?e +appel_infos <- function(animal, url_ws, cheptel = NA) { + animal <- trim_str(animal) + if (!is.na(cheptel)) { + li_anim <- try(fromJSON(paste(url_ws, animal, '/', cheptel, sep = '')), silent = TRUE) + } else { + li_anim <- try(fromJSON(paste(url_ws, animal, sep = '')), silent = TRUE) + } + if (inherits(li_anim, "try-error")) { + return(NA) + } else { + if (class(li_anim) == "list" & length(li_anim) > 0) { + li_anim[sapply(li_anim, function(x) length(x) == 0L)] <- NA + df_anim <- as.data.frame(t(unlist(li_anim))) + return(df_anim) + } else if (class(li_anim) == "data.frame") { + return(li_anim) + } + } +} + +# appel des donnees anim en fonction de leur existance +# si animal absent de hbcanim, on va voir dans hbcgene +chgt_infos <- function(animal) { + # on va chercher la ligne animal dans hbcanim + line_anim <- try(appel_infos(animal, hbcanim), silent = TRUE) + # Si erreur, on va chercher dans hbcgene + if (!is.data.frame(line_anim) | inherits(line_anim, "try-error")) { + line_anim <- appel_infos(animal, hbcgene) + } + return(line_anim) +} + +# fonction de cr?ation d'un dataframe vide +create_df <- function(nbl, liste_nomcol){ + new <- data.frame(matrix(NA, ncol=length(liste_nomcol), nrow=nbl)) + colnames(new) <- liste_nomcol + return(new) +} + +get_stats <- function(tab, nom_tab, col,conditions, nom_cond) { + if (missing(conditions) & missing(nom_cond)) { + x <- tab + nom_cond <- NA + } else { + x <- subset(tab, conditions) + } + min <- round(min(x[,col], na.rm=TRUE), 1) + q1 <- round(quantile(x[[col]], probs=0.25, na.rm=TRUE), 1) + med <- round(median(x[[col]], na.rm=TRUE), 1) + moy <- round(mean(x[[col]], na.rm=TRUE), 1) + q3 <- round(quantile(x[[col]], probs=0.75, na.rm=TRUE), 1) + max <- round(max(x[,col], na.rm=TRUE), 1) + nbval <- nrow(subset(x, is.na(x[,col]) == FALSE)) + nas <- nrow(subset(x, is.na(x[,col]) == TRUE)) + tab_col <- as.character(paste(nom_tab, col, sep='$')) + sc <- data.frame('var'=tab_col, 'cond'=nom_cond, 'min'=min, 'q1'=q1, + 'med'=med, 'moy'=moy, 'q3'=q3, 'max'=max, 'nbval'=nbval, 'nas'=nas) + rownames(sc) <- '' + return(sc) +} + +# fonction de recuperation des produits d'un taureau +# recup annul?e si taureau d'IA avec bcp de produits ie >275 +get_produits_taureau <- function(animal) { + old <- Sys.time() + anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ### + if (!is.na(anim) & (class(anim) == "try-error") == FALSE) { # _______________________________ + if (anim$sexbov[1] == '1') { + if (as.numeric(anim$nbdescendants[1]) >= 275 & anim$taureauia[1] == '1') { + produits <- NA + cat("\n", "Produits non charg?s car taureau d'IA avec production superieure ? 275") + } else if ( (as.numeric(anim$nbdescendants[1]) > 0 + & anim$taureauia[1] == '0') | + (as.numeric(anim$nbdescendants[1]) < 275 + & anim$taureauia[1] == '1') ) { + produits <- try(appel_infos(animal, reqPere), silent=TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + cat("\n", "Produits non charg?s car non disponibles") + produits <- NA + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } else { + produits <- NA + cat("\n", "???") + } + } else { + produits <- NA + cat("\n", "L'animal n'est pas un m?le") + } + } else if ((class(anim) == "try-error") == TRUE) { # _________________________ + cat("\n", "P?re sans ligne individuelle dans HBCANIM") + produits <- try(appel_infos(animal, reqPere), silent = TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + produits <- NA + cat("\n", "Produits non charg?s car non disponibles") + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } + return(produits) +} + +# fonction de recuperation des produits d'une vache +get_produits_vache <- function(animal) { + old <- Sys.time() + anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ### + if ((class(anim) == "try-error") == FALSE) { # _______________________________ + if (anim$sexbov[1] == '2') { + produits <- try(appel_infos(animal, reqMere), silent=TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + cat("\n", "Produits non charg?s car non disponibles") + produits <- NA + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } else { + produits <- NA + cat("\n", "L'animal n'est pas une femelle") + } + } else if ((class(anim) == "try-error") == TRUE) { # _________________________ + produits <- try(appel_infos(animal, reqMere), silent = TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + produits <- NA + cat("\n", "Produits non charg?s car non disponibles") + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } + return(produits) +} + +# fonction de recuperation des produits d'un animal dans un cheptel naisseur +get_produits_in_chep <- function(animal, cheptel) { + old <- Sys.time() + anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ### + if ((class(anim) == "try-error") == FALSE) { # _______________________________ + produits <- try(appel_infos(animal, reqProdNaiss, cheptel), silent=TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + cat("\n", "Produits non charg?s car non disponibles") + produits <- NA + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } else if ((class(anim) == "try-error") == TRUE) { # _________________________ + produits <- try(appel_infos(animal, reqMere), silent = TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + produits <- NA + cat("\n", "Produits non charg?s car non disponibles") + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } + return(produits) +} + +# fonction de modif des formats dates à partir du retour d'un WS +change_format_date_unix <- function(dataframe) { + if (is.data.frame(dataframe)){ + # recup des indices de colonnes de dates : commencent par 'da' ou 'DA' + li_ix_dates <- c(grep("^da", colnames(dataframe))) + if (length(li_ix_dates) == 0){ + li_ix_dates <- c(grep("^DA", colnames(dataframe))) + } + # si existance de colonnes de dates : + if (length(li_ix_dates) > 0) { + for(j in li_ix_dates) { + # on recupere les valeurs non nulles + not_na <- c(which(!is.na(dataframe[,j]))) + if(length(not_na) > 0) { + # on verifie que c'est bien un format UNIX + if ( dataframe[not_na[1],j] > 1*(10**8) ) { + # puis on modifie le format + tryCatch({ + dataframe[,j] <- as.Date(as.POSIXct(dataframe[,j] / 1000, origin = "1970-01-01")) + }, + error = function(e){ + next + }) + } else { + #print("Dates pas au format UNIX") + } + } else { + #print("Aucune date non nulle dans cette colonne") + } + } + return(dataframe) + } else { + print("Pas de colonne commençant par 'da'/'DA'") + } + } else { + print("l'objet n'est pas un dataframe") + } +} +### génération du rapport HTML ################################################ + +render_report = function(CHEP, TECH, date_imp) { + print(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), + '/', CHEP, '_rapport_eCow5.html', sep = "")) + rmarkdown::render( + paste(substr(rep_exp, 1, nchar(rep_exp)-10), "eCow5_rapport_v3.Rmd", sep=''), params = list( + CHEP = CHEP, + TECH = TECH, + date_imp = date_imp + ), + output_file = paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), + '/', CHEP, '_rapport_eCow5.html', sep = "") + ) +} + +render_synthese = function(CHEP, TECH, date_imp) { + print(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), + '/', CHEP, '_synthese_eCow5.html', sep = "")) + rmarkdown::render( + paste(substr(rep_exp, 1, nchar(rep_exp)-10), "eCow5_synthese.Rmd", sep=''), params = list( + CHEP = CHEP, + TECH = TECH, + date_imp = date_imp + ), + output_file = paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), + '/', CHEP, '_synthese_eCow5.html', sep = "") + ) +} + +# fonction de création du rapport pour la VN 2021 #### + +# render_vn = function(CHEP, TECH) { +# rmarkdown::render( +# paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/", "test_VN.Rmd", sep=''), +# params = list( +# CHEP = CHEP, +# TECH = TECH +# ), +# output_file = paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/", +# CHEP, '_VN.html', sep = "") +# ) +# } + + +################################################################################ +### fonction du calcul total ################################################### +################################################################################ + + +render_all_fic <- function(cheptel, tech, VN = FALSE) { # cheptel avec le FR, tech = abrev 5 lettres + CHEP <- cheptel # avec le FR + TECH <- tech + + # creation du repertoire d'export + dir.create(path=paste(rep_exp, TECH, '/', CHEP, sep='')) + rep <- paste(rep_exp, TECH, '/' ,CHEP, sep='') + + + ################################################################################ + ### calcul du classement vaches ################################################ + ################################################################################ + + OLD=Sys.time() + ## r?cup des animaux de l'inventaire + old <- Sys.time() + + inventaire <- get_inventaire(CHEP) + + if (is.data.frame(inventaire) && nrow(inventaire) > 0 ) { + + # modif du 28/03/2023 : ajout de la verif chepdet = CHEP + inventaire <- inventaire %>% filter(trim_str(chepdet) == CHEP) + + # if ( inventaire$danais[1] > 1*(10**8) ) { + # inventaire$danais <- as.Date(as.POSIXct(inventaire$danais / 1000, origin="1970-01-01")) + # } + #inventaire <- change_format_date_unix(inventaire) + + inventaire$danais <- as.Date(inventaire$danais, format = "%Y-%m-%d") + inventaire$mere <- trim_str(inventaire$mere) + inventaire$pere <- trim_str(inventaire$pere) + inventaire$anim <- trim_str(inventaire$anim) + + inventaire$ds <- as.numeric(inventaire$ds) + inventaire$af <- as.numeric(inventaire$af) + inventaire$dmC <- as.numeric(inventaire$dmC) + + # vaches actives + vaches <- subset(inventaire, + inventaire$sexbov == 2 & inventaire$nbdescendants > 0) + + # recherche des meres dans les porteuses pour aller chercher + # les produits s'ils existent dans HBCANIM + + porteuses <- subset(indite, !is.na(indite$MEREIPG) + & indite$MEREIPG %in% trim_str(vaches$anim)) + donneuses <- subset(indite, !is.na(indite$MERECPB) + & indite$MERECPB %in% trim_str(vaches$anim)) + # l'indicateur de donneuse d'embryon est renseign? apres dans --> vaches$ACINAC + + vaches$age_days <- time_length(interval(vaches$danais, Sys.Date()), unit="days") + vaches$age_years <- round(vaches$age_days / 365, 1) + vaches$acinac <- NA + + # liste de tous leurs produits + produits <- vaches[0,] + + if (nrow(vaches) > 0 ) { + for (i in 1:nrow(vaches)){ + # r?cup des produits dans HBCANIM + temp <- try(fromJSON(paste(reqMere, trim_str(vaches$anim[i]), sep='')), silent = TRUE) + if (inherits(temp, "try-error")) { + temp <- vaches[0,] + } else { + #temp <- fromJSON(paste(reqMere, trim_str(vaches$anim[i]), sep='')) # a voir : gerer les retours vides !!!! + produits <- rbind(produits, temp) + # on annote les donneuses + if( is.data.frame(subset(temp, temp$indite == 'O')) ) { + if (nrow(subset(temp, temp$indite == 'O')) > 0){ + vaches$acinac[i] <- 'DONNEUSE' + } + } + # ajout d'un nom ? la vache si null + if (is.na(vaches$nobovi[i])) { + lettre <- subset(LETTRES, LETTRES$ANNEE == vaches$campn[i]) + vaches$nobovi[i] <- paste(lettre$LETTRE[1], vaches$nutrav[i], sep='_') + } + } + } + } else { + print("AUCUNE VACHE ACTIVE DANS LE CHEPTEL") + } + + + # les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant + if (nrow(porteuses) > 0) { + for (i in 1:nrow(porteuses)) { + if (!(porteuses$ANIM[i] %in% trim_str(produits$anim))) { + + temp <- appel_infos(porteuses$ANIM[i], hbcanim) + li_mere <- subset(vaches, vaches$anim == porteuses$MEREIPG[i]) + + if ( is.data.frame(temp) && nrow(temp) > 0 ) { + temp$mere[1] <- porteuses$MEREIPG[i] + temp[1, c(60:67, 86:103)] <- NA + if ( nrow(li_mere) > 0){ + temp$danaismere[1] <- as.character(li_mere$danais[1]) + } + temp$indite[1] <- 'O_corr' + + produits <- rbind(produits, temp) + } + } + } + } + + # modifs des types de donn?es, pour calcul par la suite + produits$danais <- as.Date(produits$danais, format = "%Y-%m-%d") + produits$dasort <- as.Date(produits$dasort, format = "%Y-%m-%d") + + produits$mere <- trim_str(produits$mere) + produits$pere <- trim_str(produits$pere) + produits$anim <- trim_str(produits$anim) + + produits$ravelamere <- as.numeric(produits$ravelamere) + produits$ivv <- as.numeric(produits$ivv) + produits$campn <- as.numeric(produits$campn) + + produits$ponais <- as.numeric(produits$ponais) + produits$pat04m <- as.numeric(produits$pat04m) + produits$pat07m <- as.numeric(produits$pat07m) + + produits$devsqe <- as.numeric(produits$devsqe) + produits$devmus <- as.numeric(produits$devmus) + produits$aptfon <- as.numeric(produits$aptfon) + + # on ne garde que les TE port?s par une vache active du cheptel + PROD <- subset(produits, produits$indite != 'O') + + # ajout des produits IPG + PROD <- merge(PROD, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + PROD <- PROD[order(PROD$danais, decreasing = F),] + PROD <- PROD[order(PROD$mere, decreasing = T),] + + # correction des ravelamere des TE si possible + if (nrow(PROD) >0){ + for (i in 1:nrow(PROD)) { + if (is.na(PROD$ravelamere[i])) { + if (!is.na(PROD$ravelamere[i+1]) & PROD$ravelamere[i+1] %in% c(1, 2)) { + PROD$ravelamere[i] <- 1 + PROD$typemere[i] <- 'G' + } else if (!is.na(PROD$ravelamere[i+1]) & PROD$ravelamere[i+1] > 1) { + PROD$ravelamere[i] <- PROD$ravelamere[i+1] - 1 + PROD$typemere[i] <- 'V' + } + } + } + } + + # age au velage de la mere + PROD$agevel <- round(time_length(interval(PROD$danaismere, PROD$danais), + unit="months"), 1) + + # IVV : utilisation de la colonne deja presente de HBCANIM + + for (i in 1:nrow(PROD)) { + if (PROD$indite[i] == 'O_corr') { + PROD$nobovi[i] <- paste('#', PROD$nobovi[i], sep='') + } + # repro + if (PROD$anim[i] %in% czhbc$ANIM + | (!is.na(PROD$NBPRODIPG[i]) & PROD$NBPRODIPG[i] > 0) + | (!is.na(PROD$nbdescendants[i]) & as.numeric(PROD$nbdescendants[i]) > 0)) { + PROD$repro[i] <- 'O' + } else { + PROD$repro[i] <- NA + PROD$nobovi[i] <- PROD$nobovi[i] %>% str_to_lower() + } + # mortalite + if (!is.na(PROD$dasort[i]) & !is.na(PROD$casort[i]) & PROD$casort[i] == 'M' + & time_length(interval(PROD$danais[i], PROD$dasort[i]), unit="days") < 211){ + PROD$mortsev[i] <- 'O' + PROD$nobovi[i]=paste(PROD$nobovi[i], ' (MavS)', sep='') + } else { + PROD$mortsev[i] <- NA + } + # IVV + if (i > 1) { + # cas normaux + if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1]) + & PROD$ravelamere[i] != 1 + & PROD$ravelamere[i] == PROD$ravelamere[i-1] + 1 + #& !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] != '2' + & !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) { + PROD$ivv[i] <- time_length(interval(PROD$danais[i-1], PROD$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1]) + & PROD$ravelamere[i] != 1 + & PROD$ravelamere[i] == PROD$ravelamere[i-1] + & !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] == '2' + & !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) { + PROD$ivv[i] <- PROD$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1]) + & PROD$ravelamere[i] != 1 + & !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] != '2' + & !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) { + PROD$ivv[i] <- round(time_length(interval(PROD$danais[i-1], + PROD$danais[i]), + unit="days") + / (PROD$ravelamere[i] - PROD$ravelamere[i-1]), 0) + } else { + PROD$ivv[i] <- NA + } + } + } + + # calcul des effets du cheptel : rang de velage et sexe du veau + effet <- PROD %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) + effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] + effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p120[1] + effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p210[1] + + # calcul des effets du cheptel : sexe sur la repro + effetsexe <- PROD %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + + # report des effets sur les produits + + for (i in 1:nrow(PROD)) { + if (PROD$sexbov[i] == '2') { #_______________________________________ FEMELLES + PROD$nbpp_corr[i] <- PROD$NBPRODIPG[i] * rapport_MF + if (!is.na(PROD$typemere[i]) & PROD$typemere[i] == 'G') { #_________genisses + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } else { #________________________________________________ vaches ou inconnu + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PROD$nbpp_corr[i] <- PROD$NBPRODIPG[i] + if (!is.na(PROD$typemere[i]) & PROD$typemere[i] == 'G') { #____________________________________genisses + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } else { #________________________________________________ vaches ou inconnu + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } + } + } + + # calcul des donn?es ?labor?es par vache active + + for (i in 1:nrow(vaches)) { + # _______________________________________________rappel des produits par vache + veaux <- PROD %>% filter(mere == vaches$anim[i]) + + # ___________________________________________calcul des infos utiles par vache + + # calcul du poids adulte estim? et synthese pointage vache ___________________ + if (!is.na(vaches$dmC[i])) { + vaches$ptgV[i] <- round(0.6 * vaches$dmC[i] + 0.15 * vaches$ds[i] + + 0.25 * vaches$af[i], 1) + } else { + vaches$ptgV[i] <- NA + } + + if (nrow(veaux) > 3){ + vaches$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2) + alpha <- 1.62 - 0.01 * vaches$precocite[i] + } else { + vaches$precocite[i] <- NA + alpha <- 1.62 + } + if (!is.na(vaches$pat24m[i])) { + vaches$pad[i] <- round((vaches$pat24m[i] - 50 * exp(-720 * alpha * 10**(-3))) + / (1 - exp(-720 * alpha * 10**(-3))), 1) + } else if (!is.na(vaches$pat18m[i])) { + vaches$pad[i] <- round((vaches$pat18m[i] - 50 * exp(-540 * alpha * 10**(-3))) + / (1 - exp(-540 * alpha * 10**(-3))), 1) + } else if (!is.na(vaches$pat12m[i])) { + vaches$pad[i] <- round((vaches$pat12m[i] - 50 * exp(-360 * alpha * 10**(-3))) + / (1-exp(-360 * alpha * 10**(-3))), 1) + } else { + vaches$pad[i] <- NA + } + + # calcul des perfs de repro et du temps productif ____________________________ + + vaches$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1) + + if (1 %in% veaux$ravelamere) { + vaches$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1] + } else { + vaches$agevel1[i] <- NA + } + + if (2 %in% veaux$ravelamere) { + vaches$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1] + } else { + vaches$ivv1[i] <- NA + } + if (3 %in% veaux$ravelamere) { + vaches$ivv2p[i] <- round(mean(subset(veaux, + veaux$ravelamere > 2)$ivv, na.rm=T), 1) + } + + if (is.na(vaches$ivv1[i]) | (!is.na(vaches$ivv1[i]) & vaches$ivv1[i] < 390) ){ + e2 <- 0 + } else if (!is.na(vaches$ivv1[i]) & vaches$ivv1[i] >= 390) { + e2 <- vaches$ivv1[i] - 390 + } + if (is.na(vaches$ivv2p[i]) | (!is.na(vaches$ivv2p[i]) & vaches$ivv2p[i] < 365) ){ + e3 <- 0 + } else if (!is.na(vaches$ivv2p[i]) & vaches$ivv2p[i] >= 365) { + e3 <- vaches$ivv1[i] - 365 + } + if (time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") - 365 + } + + vaches$tempsprod[i] <- round( (vaches$age_days[i] + - ( vaches$agevel1[i] * 30.4 + + e2 + + e3 * (vaches$nbcampvel[i] - 2) + + e4 + )) / vaches$age_days[i] * 100, 1) + + # calcul des donn?es synth?tiques sur les produits ___________________________ + + vaches$prol[i] <- round(nrow(veaux) / (vaches$nbcampvel[i]) * 100, 1) + vaches$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O')) + / nrow(veaux)* 100, 1) + vaches$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O')) + / nrow(veaux)* 100, 1) + vaches$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T) + vaches$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T) + vaches$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux)* 100, 1) + vaches$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') )) + / nrow(veaux)* 100, 1) + vaches$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE) + + 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1) + vaches$pn_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$ponais, na.rm=T), 1) + vaches$p120_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat04m, na.rm=T), 1) + vaches$p210_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat07m, na.rm=T), 1) + vaches$pn_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$ponais, na.rm=T), 1) + vaches$p120_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat04m, na.rm=T), 1) + vaches$p210_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat07m, na.rm=T), 1) + vaches$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1) + vaches$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1) + vaches$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1) + + ### convertion des NaN en NA + L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr', + 'p210_m','p210_f','p210_corr') + for (j in L){ + if (is.nan(vaches[i,j]) == TRUE){ + vaches[i,j] <- NA + } + } + } + + # calcul des stats, valeurs extremes et references pour la normalisation + + stats_chep <- create_df(0,c('var', 'cond', 'min', 'q1', 'med', + 'moy', 'q3', 'max', 'nbval', 'nas')) + + stats_chep <- rbind(stats_chep, + get_stats(vaches, "vaches", "indisu"), + get_stats(vaches, "vaches", "agevel1"), + get_stats(vaches, "vaches", "ivv1"), + get_stats(vaches, "vaches", "ivv2p"), + get_stats(vaches, "vaches", "prol"), + get_stats(vaches, "vaches", "mort"), + get_stats(vaches, "vaches", "txrepros"), + get_stats(vaches, "vaches", "nbpp_corr"), + get_stats(vaches, "vaches", "txvf"), + get_stats(vaches, "vaches", "txmales"), + get_stats(vaches, "vaches", "ptgP"), + get_stats(vaches, "vaches", "pn_corr"), + get_stats(vaches, "vaches", "p120_corr"), + get_stats(vaches, "vaches", "p210_corr"), + get_stats(vaches, "vaches", "pad"), + get_stats(vaches, "vaches", "ptgV"), + get_stats(vaches, "vaches", "age_years"), + get_stats(vaches, "vaches", "tempsprod"), + get_stats(vaches, "vaches", "pn_m"), + get_stats(vaches, "vaches", "pn_f"), + get_stats(vaches, "vaches", "p120_m"), + get_stats(vaches, "vaches", "p120_f"), + get_stats(vaches, "vaches", "p210_m"), + get_stats(vaches, "vaches", "p210_f"), + get_stats(vaches, "vaches", "nbpp")) + + #_______________________________calcul des valeurs normalis?es par vache + + for (i in 1:nrow(vaches)) { + # ____________________________________________ perfs individuelles normalis?es + if (!is.na(vaches$agevel1[i])){ + if (vaches$agevel1[i] > 48) { + vaches$agevel1_n[i] <- 0 + } else if (vaches$agevel1[i] <= 48) { + vaches$agevel1_n[i] <- round(-2 * (10**-6) + * (vaches$agevel1[i] * 30.4) ** 2 + + 0.0027 * (vaches$agevel1[i] * 30.4) + + 8 * (10 ** -15), 3) + + } else { + vaches$agevel1_n[i] <- NA + } + } else { + vaches$agevel1_n[i] <- NA + } + + if (is.na(vaches$ivv1[i])) { + vaches$ivv1_n[i] <- NA + } else if (vaches$ivv1[i] > 460) { + vaches$ivv1_n[i] <- 0 + } else if (vaches$ivv1[i] < 390) { + vaches$ivv1_n[i] <- 1 + } else { + vaches$ivv1_n[i] <- round(1 - abs(390 - vaches$ivv1[i]) / abs(390 - 460), 3) + } + + if (is.na(vaches$ivv2p[i]) | is.nan(vaches$ivv2p[i])) { + vaches$ivv2p_n[i] <- NA + } else if (vaches$ivv2p[i] > 435) { + vaches$ivv2p_n[i] <- 0 + } else if (vaches$ivv2p[i] < 365) { + vaches$ivv2p_n[i] <- 1 + } else { + vaches$ivv2p_n[i] <- round(1 - abs(365 - vaches$ivv2p[i]) / abs(365 - 435), 3) + } + + if (is.na(vaches$pad[i])) { + vaches$pad_n[i] <- NA + } else { + vaches$pad_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$pad')[,'max'] + - vaches$pad[i]) + / abs(subset(stats_chep, var == 'vaches$pad')[,'max'] + - subset(stats_chep, var == 'vaches$pad')[,'min'])), 3) + } + + if (is.na(vaches$ptgV[i])) { + vaches$ptgv_n[i] <- NA + } else { + vaches$ptgv_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$ptgV')[,'max'] + - vaches$ptgV[i]) + / abs(subset(stats_chep, var == 'vaches$ptgV')[,'max'] + - subset(stats_chep, var == 'vaches$ptgV')[,'min'])), 3) + } + + if (vaches$prol[i] >= 100) { + vaches$prol_n[i] <- 1 + } else if (vaches$prol[i] < 50){ + vaches$prol_n[i] <- 0 + } else { + vaches$prol_n[i] <- round(1 - (abs(100 - vaches$prol[i]) / abs(100 - 50)), 3) + } + + if (is.na(vaches$pn_corr[i])) { + vaches$pn_n[i] <- NA + } else if (40 < vaches$pn_corr[i] & vaches$pn_corr[i] < 50) { + vaches$pn_n[i] <- 1 + } else if (22 > vaches$pn_corr[i] | vaches$pn_corr[i] > 68) { + vaches$pn_n[i] <- 0 + } else if (22 < vaches$pn_corr[i] & vaches$pn_corr[i] < 40) { + vaches$pn_n[i] <- round(0.056 * (vaches$pn_corr[i] - 22), 3) + } else { + vaches$pn_n[i] <- round(1 - 0.056 * (vaches$pn_corr[i] - 50), 3) + } + + vaches$txvf_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txvf')[,'max'] + - vaches$txvf[i]) / + abs(subset(stats_chep, var == 'vaches$txvf')[,'max'] + - subset(stats_chep, var == 'vaches$txvf')[,'min'])), 3) + vaches$txm_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txmales')[,'max'] + - vaches$txmales[i]) + / abs(subset(stats_chep, var == 'vaches$txmales')[,'max'] + - subset(stats_chep, var == 'vaches$txmales')[,'min'])), 3) + vaches$mort_n[i] <- round(1.0 * exp(-0.031 * vaches$mort[i]), 3) + vaches$txrepros_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txrepros')[,'max'] + - vaches$txrepros[i]) + / abs(subset(stats_chep, var == 'vaches$txrepros')[,'max'] + - subset(stats_chep, var == 'vaches$txrepros')[,'min'])), 3) + vaches$nbpp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$nbpp_corr')[,'max'] + - vaches$nbpp_c[i]) + / abs(subset(stats_chep, var == 'vaches$nbpp_corr')[,'max'] + - subset(stats_chep, var == 'vaches$nbpp_corr')[,'min'])), 3) + vaches$ptgp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$ptgP')[,'max'] + - vaches$ptgP[i]) + / abs(subset(stats_chep, var == 'vaches$ptgP')[,'max'] + - subset(stats_chep, var == 'vaches$ptgP')[,'min'])), 3) + vaches$p120_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$p120_corr')[,'max'] + - vaches$p120_c[i]) + / abs(subset(stats_chep, var == 'vaches$p120_corr')[,'max'] + - subset(stats_chep, var == 'vaches$p120_corr')[,'min'])), 3) + vaches$p210_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$p210_corr')[,'max'] + - vaches$p210_c[i]) + / abs(subset(stats_chep, var == 'vaches$p210_corr')[,'max'] + - subset(stats_chep, var == 'vaches$p210_corr')[,'min'])), 3) + # __________________________________________________ calcul des notes carriere + somme <- 0 + pond <- sum(Pcar[,c(2:16)]) + for (j in c(190:204)){ # attention a la correspondance des numeros de colonnes !!! + # modif du 29/04/2024 : passage de 189:203 à 190:204 + if (is.na(vaches[i,j])){ + valperf <- 0 + #mt_col <- mt_col + 1 # nb de colonnes sans valeur + pond <- pond - Pcar[1, (j - 189 + 1)] + } else { + valperf <- vaches[i, j] * Pcar[1, (j - 189 + 1)] # critere normalise X ponderation + } + somme <- somme + valperf # somme sur une ligne + } + SOMME_tot <- somme / pond * 10 # rapport en prenant que les criteres ayant une valeur + if (is.na(vaches$ptgp_n[i]) & is.na(vaches$p120_n[i]) & is.na(vaches$p210_n[i])){ + vaches$ecowcarr[i] <- NA + } else { + vaches$ecowcarr[i] <- round(SOMME_tot * 100, 0) + } + } + vaches$rg_carr <- rank(1 / vaches$ecowcarr, na.last="keep") + + + ##################################################### calcul des notes campagnes + + campagnes <- PROD %>% distinct(mere, campn, ravelamere) + + for (i in 1:nrow(campagnes)){ + #y <- subset(VA,VA$ANIM==C$mereref[i]) # ligne de la mere dans VA + veaux <- subset(PROD, PROD$campn == campagnes$campn[i] + & PROD$mere == campagnes$mere[i]) # ligne(s) du ou des veaux dans PR + + campagnes$pn_c[i] <- round(mean(veaux$pn_corr, na.rm=TRUE), 1) + campagnes$txvf[i] <- round(nrow(subset(veaux, + veaux$conais %in% c('1','2'))) + / nrow(veaux) * 100, 1) + campagnes$txm[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux) * 100, 1) + campagnes$ptgp[i] <- round(mean((0.75 * veaux$devmus + + 0.25 * veaux$devsqe), na.rm=TRUE) ,1) + campagnes$p120_c[i] <- round(mean(veaux$p120_corr, na.rm=TRUE), 1) + campagnes$p210_c[i] <- round(mean(veaux$p210_corr, na.rm=TRUE), 1) + campagnes$prol[i] <- nrow(veaux) * 100 + campagnes$ivv[i] <- veaux$ivv[1] + campagnes$mort[i] <- round(nrow(subset(veaux,veaux$mortsev == 'O')) + / nrow(veaux) * 100, 1) + + L <- c('ptgp','pn_c','p120_c','p210_c') + for (j in L){ + if (is.nan(campagnes[i,j])){ + campagnes[i,j] <- NA + } + } + + if (nrow(veaux) == 1){ + nv <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + } else if (nrow(veaux) == 2){ + nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_') + nv <- paste(nv1, nv2, sep=', ') + } else if (nrow(veaux) == 3){ + nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_') + nv3 <- paste(str_sub(veaux$anim[3], -4), trim_str(veaux$nobovi[3]), sep='_') + nv <- paste(nv1, nv2, nv3, sep=', ') + } else if (nrow(veaux) == 4){ + nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_') + nv3 <- paste(str_sub(veaux$anim[3], -4), trim_str(veaux$nobovi[3]), sep='_') + nv4 <- paste(str_sub(veaux$anim[4], -4), trim_str(veaux$nobovi[4]), sep='_') + nv <- paste(nv1, nv2, nv3, nv4, sep=', ') + } + if(is.na(veaux$nompere[1])){ + if (is.na(veaux$pere[1])){ + pere <- '' + } else { + pere <- str_sub(trim_str(veaux$pere[1]), -4) + } + } else { + pere <- trim_str(veaux$nompere[1]) + } + campagnes$noms[i] <- paste(nv, pere, sep=' / ') + } + + stats_chep <- rbind(stats_chep, + get_stats(campagnes,'campagnes','ivv'), + get_stats(campagnes,'campagnes','prol'), + get_stats(campagnes,'campagnes','mort'), + get_stats(campagnes,'campagnes','txvf'), + get_stats(campagnes,'campagnes','txm'), + get_stats(campagnes,'campagnes','ptgp'), + get_stats(campagnes,'campagnes','pn_c'), + get_stats(campagnes,'campagnes','p120_c'), + get_stats(campagnes,'campagnes','p210_c')) + + for (i in 1:nrow(campagnes)){ + # _____________________________________ calcul des perfs campagnes normalis?es + #pn + if (is.na(campagnes$pn_c[i])) { + campagnes$pn_n[i] <- NA + } else if (campagnes$pn_c[i] >= 40 & campagnes$pn_c[i] <= 50) { + campagnes$pn_n[i] <- 1 + } else if (22 >= campagnes$pn_c[i] | campagnes$pn_c[i] >= 68) { + campagnes$pn_n[i] <- 0 + } else if (22 < campagnes$pn_c[i] & campagnes$pn_c[i] < 40) { + campagnes$pn_n[i] <- round(0.056 * (campagnes$pn_c[i] - 22), 3) + } else { + campagnes$pn_n[i] <- round(1 - 0.056 * (campagnes$pn_c[i] - 50), 3) + } + + campagnes$txvf_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$txvf')[,'max'] + - campagnes$txvf[i]) + / abs(subset(stats_chep, var == 'campagnes$txvf')[,'max'] + - subset(stats_chep, var == 'campagnes$txvf')[,'min'])), 3) + campagnes$txm_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$txm')[,'max'] + - campagnes$txm[i]) + / abs(subset(stats_chep, var == 'campagnes$txm')[,'max'] + - subset(stats_chep, var == 'campagnes$txm')[,'min'])), 3) + campagnes$ptgp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$ptgp')[,'max'] + - campagnes$ptgp[i]) + / abs(subset(stats_chep, var == 'campagnes$ptgp')[,'max'] + - subset(stats_chep, var == 'campagnes$ptgp')[,'min'])), 3) + campagnes$p120_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$p120_c')[,'max'] + - campagnes$p120_c[i]) + / abs(subset(stats_chep, var == 'campagnes$p120_c')[,'max'] + - subset(stats_chep, var == 'campagnes$p120_c')[,'min'])), 3) + campagnes$p210_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$p210_c')[,'max'] + - campagnes$p210_c[i]) + / abs(subset(stats_chep, var == 'campagnes$p210_c')[,'max'] + - subset(stats_chep, var == 'campagnes$p210_c')[,'min'])), 3) + + #prol + if (is.na(campagnes$prol[i])) { + campagnes$prol_n[i] <- NA + } else if (campagnes$prol[i] == 100) { + campagnes$prol_n[i] <- 0.8 + } else { + campagnes$prol_n[i] <- 1 + } + + campagnes$mort_n[i] <- round(1.0 * exp(-0.031 * campagnes$mort[i]), 3) + + #ivv + if (is.na(campagnes$ravelamere[i]) | campagnes$ravelamere[i] == 1 + | is.na(campagnes$ivv[i])) { + campagnes$ivv_n[i] <- NA + } else if (campagnes$ravelamere[i] == 2) { + if (!is.na(campagnes$ivv[i])){ + if (campagnes$ivv[i] > 460) { + campagnes$ivv_n[i] <- 0 + } else if (campagnes$ivv[i] < 390) { + campagnes$ivv_n[i] <- 1 + } else { + campagnes$ivv_n[i] <- round(1 - abs(390 - campagnes$ivv[i]) / abs(390 - 460), 3) + } + } + } else { + if (!is.na(campagnes$ivv[i])) { + if (campagnes$ivv[i] > 435) { + campagnes$ivv_n[i] <- 0 + } else if (campagnes$ivv[i] < 365) { + campagnes$ivv_n[i] <- 1 + } else { + campagnes$ivv_n[i] <- round(1 - abs(365 - campagnes$ivv[i]) / abs(365 - 435), 3) + } + } + } + + # _________________________________________________ calcul des notes campagnes + somme <- 0 + pond <- sum(Pcamp[2,c(2:10)]) + for (j in c(14:22)){ # attention a la correspondance des num?ros de colonnes !!! + if (is.na(campagnes[i,j])){ + valperf <- 0 + #mt_col <- mt_col + 1 # nb de colonnes sans valeur + pond <- pond - Pcamp[1, (j - 13 + 1)] + } else { + valperf <- campagnes[i, j] * Pcamp[1, (j - 13 + 1)] # critere normalise X ponderation + } + somme <- somme + valperf # somme sur une ligne + } + SOMME_tot <- somme / pond * 10 # rapport en prenant que les criteres ayant une valeur + if (is.na(campagnes$ptgp_n[i]) & is.na(campagnes$p120_n[i]) & is.na(campagnes$p210_n[i])){ + campagnes$ecowcamp[i] <- round(SOMME_tot, 1) + } else { + campagnes$ecowcamp[i] <- round(SOMME_tot * 10, 0) + } + + } + + # remplissage de la table vaches avec les notes campagnes + + for (i in 1:nrow(vaches)){ + # moyenne notes campagnes + subcamp <- subset(campagnes, campagnes$mere == vaches$anim[i] + & campagnes$ecowcamp > 10) + if (nrow(subcamp)>0){ + vaches$moyecowcamp[i] <- round(mean(subcamp$ecowcamp, na.rm=TRUE), 1) + } else { + vaches$moyecowcamp[i] <- NA + } + # vaches non class?es en minuscules + if (is.na(vaches$ecowcarr[i])) { + vaches$nobovi[i] <- vaches$nobovi[i] %>% str_to_lower() + } + # donneuses soulignees par un # + embr <- subset(PROD, PROD$mere == vaches$anim[i] & PROD$indite == 'O') + if (nrow(embr) > 0) { + vaches$nobovi[i] <- paste('#', vaches$nobovi[i], sep=' ') + } + } + vaches$rg_camp <- rank(1 / vaches$moyecowcamp, na.last='keep') + + # creation du tableau CAMPAGNES + + nbcol <- max(campagnes$ravelamere, na.rm = TRUE) # nombre de colonnes de rangs de v?lage ? cr?er + CAMP <- cbind('anim'=vaches$anim, create_df(nrow(vaches), c(1:nbcol))) + for (i in 1:nrow(CAMP)){ + subcamp <- subset(campagnes, campagnes$mere == CAMP$anim[i]) + for (j in 2:ncol(CAMP)){ + veaux <- subset(subcamp, subcamp$ravelamere == j-1) + if (nrow(veaux) > 0) { + CAMP[i,j] <- paste(veaux$noms[1], veaux$ecowcamp[1], sep=' : ') + } + } + } + + vaches <- merge(vaches, CAMP, by.x='anim', by.y='anim', all.x=T, all.y=T) + + + # selection des colonnes d'interet pour la table finale + tabfinal <- merge(vaches[,c('chepdet', 'anim', 'nobovi', 'nompere', 'indisu', + 'tempsprod', 'age_years', 'ecowcarr', 'rg_carr', + 'ptgV', 'agevel1', 'ivv1', 'ivv2p', + 'prol', 'mort', 'txrepros', 'nbpp', + 'txvf', 'pn_m', 'pn_f', + 'p120_m', 'p120_f', 'p210_m', 'p210_f', + 'ptgP', + 'moyecowcamp', 'rg_camp')], + CAMP, by.x='anim', by.y='anim', all.x=T, all.y=T) + + tabfinal <- tabfinal[order(tabfinal$rg_carr),] + tabfinal <- tabfinal %>% select(chepdet, everything()) + + colnames(tabfinal)=c("CHEPTEL", "NUM_VACHE", "NOM_VACHE", "PERE", "ISU", + "% VIE PRODUCTIVE", "AGE (annees)", + "note eCow CARRIERE (/1000)", "rang CARRIERE", + "pointage VACHE *m", "age 1er velage (m)", "IVV1 (j)", + "IVV2+ (j)", "prolificite (%)", "mortalite av.sevr (%)", + "% produits repros", "nb petits-produits", + "% velages tranquilles", "PN males (kg)", + "PN femelles (kg)", "P120 males (kg)", "P120 femelles (kg)", + "P210 males (kg)","P210 femelles (kg)", + "pointage PRODUITS *m", "Moyenne notes eCow CAMPAGNE (/100)", + "rang CAMPAGNE", c(1:nbcol)) + + write.table(tabfinal, + file = paste(rep, '/', CHEP, '_classement_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + + new <- Sys.time() - old + print(paste('Calcul du classement ?Cow :', new, sep = '')) + + + + # a revoir pour les petits cheptels + #render_vn(CHEP, TECH) + + ################################################################################ + ### calcul du resume cheptel ################################################### + ################################################################################ + + # lecture du fichier des stats des adherents + detail_stats_chep <- read_delim(paste(rep_exp, "detail_stats_chep.csv", sep=''), + ";", escape_double = FALSE, + locale = locale(decimal_mark = ",", + grouping_mark = ""), trim_ws = TRUE) + #detail_stats_chep$date_calc <- '2020-09-06' + # perfs dont l'unit? de calcul est la vache : ie toutes les vaches actives + # isu, age, temps prod, ptg adulte, agevel1, ivv1 et 2+ + # perfs dont l'unit? de calcul est le produit : ie tous les produits issus de vaches actives + # prol, mort, tx de repros, nb de PP, tx de VF, PN, P120 et 210, ptg sevrage + + + ## stats du cheptel a inserer dans la liste des adherents pour comparaison + + stats_chep_bis <- detail_stats_chep[1,] + stats_chep_bis[1,] <- NA + + stats_chep_bis$ADHHBC <- CHEP + + stats_chep_bis$isu[1] <- round( mean(vaches$indisu, na.rm=T), 1) + stats_chep_bis$tps_prod[1] <- round( mean(vaches$tempsprod, na.rm=T), 1) + stats_chep_bis$age[1] <- round( mean(vaches$age_years, na.rm=T), 1) + stats_chep_bis$ptgv[1] <- round( mean(vaches$ptgV, na.rm=T), 1) + stats_chep_bis$agevel1[1] <- round( mean(vaches$agevel1, na.rm=T), 1) + stats_chep_bis$ivv1[1] <- round( mean(vaches$ivv1, na.rm=T), 1) + stats_chep_bis$ivv2p[1] <- round( mean(vaches$ivv2p, na.rm=T), 1) + + stats_chep_bis$prol[1] <- round( nrow(PROD) / nrow(campagnes) * 100, 1) + stats_chep_bis$mort[1] <- round( nrow(subset(PROD, PROD$mortsev == 'O')) + / nrow(PROD) * 100, 1) + stats_chep_bis$txvf[1] <- round( nrow(subset(PROD, PROD$conais %in% c('1','2'))) + / nrow(PROD) * 100, 1) + stats_chep_bis$tx_repros[1] <- round( nrow(subset(PROD, PROD$NBPRODIPG > 0)) + / nrow(PROD) * 100, 1) + stats_chep_bis$nbpp[1] <- sum(PROD$NBPRODIPG, na.rm=TRUE) + stats_chep_bis$ptgp[1] <- round( mean(0.75 * PROD$devmus + 0.25 * PROD$devsqe, + na.rm=TRUE), 1) + stats_chep_bis$pnm[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$ponais, + na.rm=TRUE), 1) + stats_chep_bis$pnf[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$ponais, + na.rm=TRUE), 1) + stats_chep_bis$p120m[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$pat04m, + na.rm=TRUE), 1) + stats_chep_bis$p120f[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$pat04m, + na.rm=TRUE), 1) + stats_chep_bis$p210m[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$pat07m, + na.rm=TRUE), 1) + stats_chep_bis$p210f[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$pat07m, + na.rm=TRUE), 1) + stats_chep_bis$date_calc[1] <- as.character(Sys.Date()) + + # on met a jour le fichier des stats des adh + #____________________________ prevoir une ?tape de verif de VALEURS ABERRENTES ! + + detail_stats_chep <- subset(detail_stats_chep, detail_stats_chep$ADHHBC != CHEP) + + detail_stats_chep <- rbind(detail_stats_chep, stats_chep_bis) + + write.table(detail_stats_chep, + file = paste(rep_exp, "detail_stats_chep.csv", sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"),na = "") + + + ## stats du cheptel avec distribution des adh?rents et des vaches + rownames(stats_chep) <- stats_chep$var + + res_chep <- stats_chep[c('vaches$indisu', 'vaches$tempsprod', 'vaches$age_years', + 'vaches$ptgV','vaches$agevel1', 'vaches$ivv1', + 'vaches$ivv2p', 'vaches$prol', 'vaches$mort', + 'vaches$txrepros', 'vaches$nbpp', 'vaches$txvf', + 'vaches$pn_m', 'vaches$pn_f', 'vaches$p120_m', + 'vaches$p120_f', 'vaches$p210_m', 'vaches$p210_f', + 'vaches$ptgP'), + c('moy', 'min', 'q1', 'med', 'q3', 'max')] + + # creation d'un table contenant la distribution des cheptels pour chaque variable + stats_adh <- data.frame(matrix(NA, ncol = 7,nrow = 19)) + colnames(stats_adh) <- c("var", "moy_c", "min_c", "Q1_c", "med_c", "Q3_c", "max_c" ) + stats_adh[,1] <- c('isu','tps_prod','age','ptgv','agevel1','ivv1','ivv2p', + 'prol','mort','tx_repros','nbpp','txvf', + 'pnm','pnf','p120m','p120f','p210m','p210f','ptgp') + + # remplissage de la table + for (i in 1:nrow(stats_adh)){ + stats_adh$moy_c[i] <- round(mean(unlist(detail_stats_chep[,i + 1]), + na.rm = TRUE), 1) + stats_adh$min_c[i] <- round(min(detail_stats_chep[,i + 1], na.rm = TRUE), 1) + stats_adh$Q1_c[i] <- round(quantile(detail_stats_chep[,i + 1], + probs = 0.25, na.rm = TRUE), 1) + stats_adh$med_c[i] <- round(quantile(detail_stats_chep[,i + 1], + probs = 0.50, na.rm = TRUE), 1) + stats_adh$Q3_c[i] <- round(quantile(detail_stats_chep[,i + 1], + probs = 0.75,na.rm = TRUE), 1) + stats_adh$max_c[i] <- round(max(detail_stats_chep[,i + 1], na.rm = TRUE), 1) + } + + # on fusionne distribution des adherents et des vaches du cheptel d'?tude + STATS <- cbind(stats_adh, t(stats_chep_bis[, c(2 : (ncol(stats_chep_bis) - 1))])) + + STATS <- cbind(STATS, res_chep) + + STATS$var <- c("ISU", "% vie productive", "age (annees)", + "pointage VACHE *m", "age 1er velage (m)", "IVV1 (j)", "IVV2+ (j)", + "prolificite (%)", "mortalite av.sevr (%)", "% produits repros", + "nb petits-produits", "% velages tranquilles", "PN males (kg)", + "PN femelles (kg)", "P120 males (kg)", "P120 femelles (kg)", + "P210 males (kg)", "P210 femelles (kg)", "pointage PRODUITS *m") + colnames(STATS) <- c('Variable', 'Moyenne_ADH', 'Min_ADH', 'Q1_ADH', + 'Mediane_ADH', 'Q3_ADH', 'Max_ADH', 'Moyenne_cheptel', + 'Moyenne_vaches', 'Min_vaches', 'Q1_vaches', + 'Mediane_vaches', 'Q3_vaches', 'Max_vaches') + + write.table(STATS, + file = paste(rep, '/', CHEP, '_ResChep_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + + ################################################################################ + ### remont?e des perfs des taureaux marquants ################################## + ################################################################################ + + # on r?cupere les peres des animaux actifs + # on regarde s'ils ont un nombre raisonnable de produits, ie moins de 275 + # si c'est la cas, on r?cupere tous les produits puis on trie ceux n?s dans le cheptel + + ## update du 13dec2021 apres mise en prod du WS sur la production d'un animal dans un cheptel particulier + + peres <- inventaire %>% + filter(trim_str(chna) == CHEP & !is.na(pere)) %>% + distinct(pere, nompere) %>% add_column('naisseur' = NA) + + if (nrow(peres) > 0) { + for (i in 1:nrow(peres)) { + li_anim <- chgt_infos(trim_str(peres$pere[i])) + if (is.data.frame(li_anim)) { + peres$naisseur[i] <- li_anim$nomnais[1] + } + } + + prod_peres <- inventaire[0,] + pp_peres <- inventaire[0,] + + for (i in 1 : nrow(peres)) { + animal <- peres$pere[i] + cat("\n", animal, peres$nompere[i]) + try({ + produits <- get_produits_in_chep(animal, CHEP) # loc update + if (is.data.frame(produits) == TRUE) { #__________________________________ + produits <- produits %>% filter(trim_str(chna) == CHEP) + prod_peres <- rbind(prod_peres, produits) + for (j in 1:nrow(produits)) { + if (produits$sexbov[j] == '2' & as.numeric(produits$nbdescendants[j]) > 0) { + pp <- get_produits_vache(trim_str(produits$anim[j])) + if (is.data.frame(pp) == TRUE) { #______________________________ + pp <- pp %>% filter(trim_str(chna) == CHEP) + pp_peres <- rbind(pp_peres, pp) + } + } + } + } else { #________________________________________________________________ + cat("\n", "Aucune donn?e charg?e") + } + }) + } + + if (nrow(prod_peres) > 0) { + if (!is.na(prod_peres$danais[1]) & nchar(as.character(prod_peres$danais[1])) > 10) { + prod_peres$danais <- as.Date(substr(as.POSIXct(prod_peres$danais / 1000, + origin = "1970-01-01"), 1, 10), + format = "%Y-%m-%d", + origin = "1970-01-01") + } else { + prod_peres$danais <- as.Date(prod_peres$danais, + format = "%Y-%m-%d") + } + sortis <- subset(prod_peres, !is.na(prod_peres$dasort)) + if (nrow(sortis) > 0 && nchar(as.character(sortis$dasort[1])) > 10) { + prod_peres$dasort <- as.Date(substr(as.POSIXct(prod_peres$dasort / 1000, + origin = "1970-01-01"), 1, 10), + format = "%Y-%m-%d", + origin = "1970-01-01") + } else { + prod_peres$dasort <- as.Date(prod_peres$dasort, + format = "%Y-%m-%d") + } + if (!is.na(prod_peres$danaismere[1]) & nchar(as.character(prod_peres$danaismere[1])) > 10) { + prod_peres$danaismere <- as.Date(substr(as.POSIXct(prod_peres$danaismere / 1000, + origin = "1970-01-01"), 1, 10), + format = "%Y-%m-%d", + origin = "1970-01-01") + } else { + prod_peres$danaismere <- as.Date(prod_peres$danaismere, + format = "%Y-%m-%d") + } + + prod_peres$mere <- trim_str(prod_peres$mere) + prod_peres$pere <- trim_str(prod_peres$pere) + prod_peres$anim <- trim_str(prod_peres$anim) + prod_peres$ds <- as.numeric(prod_peres$ds) + prod_peres$af <- as.numeric(prod_peres$af) + prod_peres$dmC <- as.numeric(prod_peres$dmC) + + # liste de tous leurs produitsdir + produitsdir <- prod_peres #%>% filter(chna == CHEP) # _________________________ filtre a reflechir ????? + + # vachestot actives + vachestot <- subset(prod_peres, + prod_peres$sexbov == '2' & prod_peres$nbdescendants > 0 ) + + # les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant + if (nrow(porteuses) > 0) { + for (i in 1:nrow(porteuses)) { + if (!(porteuses$ANIM[i] %in% trim_str(produitsdir$anim))) { + + temp <- appel_infos(porteuses$ANIM[i], hbcanim) + li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i]) + + if ( is.data.frame(temp) && nrow(temp) > 0 ) { + temp$mere[1] <- porteuses$MEREIPG[i] + temp[1, c(60:67, 86:103)] <- NA + if ( nrow(li_mere) > 0){ + temp$danaismere[1] <- as.character(li_mere$danais[1]) + } + temp$indite[1] <- 'O_corr' + + tryCatch({ + produitsdir <- rbind(produitsdir, temp[,colnames(produitsdir)]) #-------------------------------- tryCatch à supp + }, + error = function(e) e) + } + } + } + } + + # modifs des types de donn?es, pour calcul par la suite + produitsdir$danais <- as.Date(produitsdir$danais, format = "%Y-%m-%d") + produitsdir$dasort <- as.Date(produitsdir$dasort, format = "%Y-%m-%d") + + produitsdir$mere <- trim_str(produitsdir$mere) + produitsdir$pere <- trim_str(produitsdir$pere) + produitsdir$anim <- trim_str(produitsdir$anim) + + produitsdir$ravelamere <- as.numeric(produitsdir$ravelamere) + produitsdir$ivv <- as.numeric(produitsdir$ivv) + produitsdir$campn <- as.numeric(produitsdir$campn) + produitsdir$nbdescendants <- as.numeric(produitsdir$nbdescendants) + + produitsdir$ponais <- as.numeric(produitsdir$ponais) + produitsdir$pat04m <- as.numeric(produitsdir$pat04m) + produitsdir$pat07m <- as.numeric(produitsdir$pat07m) + + produitsdir$devsqe <- as.numeric(produitsdir$devsqe) + produitsdir$devmus <- as.numeric(produitsdir$devmus) + produitsdir$aptfon <- as.numeric(produitsdir$aptfon) + + # on ne garde que les TE port?s par une vache active du cheptel + PRODDIR <- subset(produitsdir, produitsdir$indite != 'O') + + # ajout des produitsdir IPG + PRODDIR <- merge(PRODDIR, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + PRODDIR <- PRODDIR[order(PRODDIR$danais, decreasing = F),] + PRODDIR <- PRODDIR[order(PRODDIR$mere, decreasing = T),] + + # correction des ravelamere des TE si possible + for (i in 1:nrow(PRODDIR)) { + if (is.na(PRODDIR$ravelamere[i])) { + if (!is.na(PRODDIR$ravelamere[i+1]) & PRODDIR$ravelamere[i+1] %in% c(1, 2)) { + PRODDIR$ravelamere[i] <- 1 + PRODDIR$typemere[i] <- 'G' + } else if (!is.na(PRODDIR$ravelamere[i+1]) & PRODDIR$ravelamere[i+1] > 1) { + PRODDIR$ravelamere[i] <- PRODDIR$ravelamere[i+1] - 1 + PRODDIR$typemere[i] <- 'V' + } + } + } + + # age au velage de la mere + PRODDIR$agevel <- round(time_length(interval(PRODDIR$danaismere, PRODDIR$danais), + unit="months"), 1) + + # IVV : utilisation de la colonne deja pr?sente de HBCANIM + + for (i in 1:nrow(PRODDIR)) { + if (PRODDIR$indite[i] == 'O_corr') { + PRODDIR$nobovi[i] <- paste('#', PRODDIR$nobovi[i], sep='') + } + # repro + if (PRODDIR$anim[i] %in% czhbc$ANIM + | (!is.na(PRODDIR$NBPRODIPG[i]) & PRODDIR$NBPRODIPG[i] > 0) + | (!is.na(PRODDIR$nbdescendants[i]) + & as.numeric(PRODDIR$nbdescendants[i]) > 0)) { + PRODDIR$repro[i] <- 'O' + } else { + PRODDIR$repro[i] <- NA + PRODDIR$nobovi[i] <- PRODDIR$nobovi[i] %>% str_to_lower() + } + # mortalite + if (!is.na(PRODDIR$dasort[i]) & !is.na(PRODDIR$casort[i]) + & PRODDIR$casort[i] == 'M' + & time_length(interval(PRODDIR$danais[i], PRODDIR$dasort[i]), + unit="days") < 211){ + PRODDIR$mortsev[i] <- 'O' + PRODDIR$nobovi[i]=paste(PRODDIR$nobovi[i], ' (MavS)', sep='') + } else { + PRODDIR$mortsev[i] <- NA + } + # IVV + if (i > 1) { + # cas normaux + if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1]) + & PRODDIR$ravelamere[i] != 1 + & PRODDIR$ravelamere[i] == PRODDIR$ravelamere[i-1] + 1 + #& !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] != '2' + & !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) { + PRODDIR$ivv[i] <- time_length(interval(PRODDIR$danais[i-1], PRODDIR$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1]) + & PRODDIR$ravelamere[i] != 1 + & PRODDIR$ravelamere[i] == PRODDIR$ravelamere[i-1] + & !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] == '2' + & !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) { + PRODDIR$ivv[i] <- PRODDIR$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1]) + & PRODDIR$ravelamere[i] != 1 + & !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] != '2' + & !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) { + PRODDIR$ivv[i] <- round(time_length(interval(PRODDIR$danais[i-1], + PRODDIR$danais[i]), + unit="days") + / (PRODDIR$ravelamere[i] + - PRODDIR$ravelamere[i-1]), 0) + } else { + PRODDIR$ivv[i] <- NA + } + } + } + + # calcul des effets du cheptel : rang de velage et sexe du veau + effet <- PRODDIR %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) + effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] + effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p120[1] + effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p210[1] + + # calcul des effets du cheptel : sexe sur la repro + effetsexe <- PRODDIR %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + + # report des effets sur les produitsdir + + for (i in 1:nrow(PRODDIR)) { + if (PRODDIR$sexbov[i] == '2') { #____________________________________ FEMELLES + PRODDIR$nbpp_corr[i] <- PRODDIR$NBPRODIPG[i] * rapport_MF + if (!is.na(PRODDIR$typemere[i]) & PRODDIR$typemere[i] == 'G') { #____genisses + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PRODDIR$nbpp_corr[i] <- PRODDIR$NBPRODIPG[i] + if (!is.na(PRODDIR$typemere[i]) & PRODDIR$typemere[i] == 'G') { #_________________________________genisses + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } + } + } + } + + if (nrow(vachestot) > 0) { + # recherche des meres dans les porteuses pour aller chercher + # les produitstot s'ils existent dans HBCANIM + + porteuses <- subset(indite, !is.na(indite$MEREIPG) + & indite$MEREIPG %in% trim_str(vachestot$anim)) + donneuses <- subset(indite, !is.na(indite$MERECPB) + & indite$MERECPB %in% trim_str(vachestot$anim)) + # l'indicateur de donneuse d'embryon est renseign? apr?s dans --> vachestot$ACINAC + + for (i in 1:nrow(vachestot)) { + if (is.na(vachestot$dasort[i])){ + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], Sys.Date()), unit="days") + } else { + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], vachestot$dasort[i]), unit="days") + } + } + + vachestot$age_years <- round(vachestot$age_days / 365, 1) + + # liste de tous leurs produitstot + produitstot <- pp_peres #%>% filter(chna == CHEP) # ___________________________ filtre a reflechir ????? + + # les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant + if (nrow(porteuses) > 0) { + for (i in 1:nrow(porteuses)) { + if (!(porteuses$ANIM[i] %in% trim_str(produitstot$anim))) { + + temp <- appel_infos(porteuses$ANIM[i], hbcanim) + li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i]) + + if ( is.data.frame(temp) && nrow(temp) > 0 ) { + temp$mere[1] <- porteuses$MEREIPG[i] + temp[1, c(60:67, 86:103)] <- NA + if ( nrow(li_mere) > 0){ + temp$danaismere[1] <- as.character(li_mere$danais[1]) + } + temp$indite[1] <- 'O_corr' + + produitstot <- rbind(produitstot, temp[,colnames(produitstot)]) + } + } + } + } + + # modifs des types de donn?es, pour calcul par la suite + produitstot$danais <- as.Date(produitstot$danais, format = "%Y-%m-%d") + produitstot$dasort <- as.Date(produitstot$dasort, format = "%Y-%m-%d") + + produitstot$mere <- trim_str(produitstot$mere) + produitstot$pere <- trim_str(produitstot$pere) + produitstot$anim <- trim_str(produitstot$anim) + + produitstot$ravelamere <- as.numeric(produitstot$ravelamere) + produitstot$ivv <- as.numeric(produitstot$ivv) + produitstot$campn <- as.numeric(produitstot$campn) + produitstot$nbdescendants <- as.numeric(produitstot$nbdescendants) + + produitstot$ponais <- as.numeric(produitstot$ponais) + produitstot$pat04m <- as.numeric(produitstot$pat04m) + produitstot$pat07m <- as.numeric(produitstot$pat07m) + + produitstot$devsqe <- as.numeric(produitstot$devsqe) + produitstot$devmus <- as.numeric(produitstot$devmus) + produitstot$aptfon <- as.numeric(produitstot$aptfon) + + # on ne garde que les TE port?s par une vache active du cheptel + PRODTOT <- subset(produitstot, produitstot$indite != 'O') + + # ajout des produitstot IPG + PRODTOT <- merge(PRODTOT, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + PRODTOT <- PRODTOT[order(PRODTOT$danais, decreasing = F),] + PRODTOT <- PRODTOT[order(PRODTOT$mere, decreasing = T),] + + # correction des ravelamere des TE si possible + for (i in 1:nrow(PRODTOT)) { + if (is.na(PRODTOT$ravelamere[i])) { + if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] %in% c(1, 2)) { + PRODTOT$ravelamere[i] <- 1 + PRODTOT$typemere[i] <- 'G' + } else if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] > 1) { + PRODTOT$ravelamere[i] <- PRODTOT$ravelamere[i+1] - 1 + PRODTOT$typemere[i] <- 'V' + } + } + } + + # age au velage de la mere + PRODTOT$agevel <- round(time_length(interval(PRODTOT$danaismere, PRODTOT$danais), + unit="months"), 1) + + # IVV : utilisation de la colonne deja presente de HBCANIM + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$indite[i] == 'O_corr') { + PRODTOT$nobovi[i] <- paste('#', PRODTOT$nobovi[i], sep='') + } + # repro + if (PRODTOT$anim[i] %in% czhbc$ANIM + | (!is.na(PRODTOT$NBPRODIPG[i]) & PRODTOT$NBPRODIPG[i] > 0) + | (!is.na(PRODTOT$nbdescendants[i]) + & as.numeric(PRODTOT$nbdescendants[i]) > 0)) { + PRODTOT$repro[i] <- 'O' + } else { + PRODTOT$repro[i] <- NA + PRODTOT$nobovi[i] <- PRODTOT$nobovi[i] %>% str_to_lower() + } + # mortalite + if (!is.na(PRODTOT$dasort[i]) & !is.na(PRODTOT$casort[i]) + & PRODTOT$casort[i] == 'M' + & time_length(interval(PRODTOT$danais[i], PRODTOT$dasort[i]), + unit="days") < 211){ + PRODTOT$mortsev[i] <- 'O' + PRODTOT$nobovi[i]=paste(PRODTOT$nobovi[i], ' (MavS)', sep='') + } else { + PRODTOT$mortsev[i] <- NA + } + # IVV + if (i > 1) { + # cas normaux + if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + 1 + #& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] == '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- PRODTOT$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- round(time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + / (PRODTOT$ravelamere[i] + - PRODTOT$ravelamere[i-1]), 0) + } else { + PRODTOT$ivv[i] <- NA + } + } + } + + # calcul des effets du cheptel : rang de velage et sexe du veau + effet <- PRODTOT %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) + effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] + effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p120[1] + effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p210[1] + + # calcul des effets du cheptel : sexe sur la repro + effetsexe <- PRODTOT %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + + # report des effets sur les produitstot + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$sexbov[i] == '2') { #___________________________________ FEMELLES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] * rapport_MF + if (!is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #___genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #________________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] + if ( !is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #_________________________________genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } + } + + # calcul des donn?es ?labor?es par vache active + + for (i in 1:nrow(vachestot)) { + # ___________________________________________rappel des produitstot par vache + veaux <- PRODTOT %>% filter(mere == vachestot$anim[i]) + + # ___________________________________________calcul des infos utiles par vache + + # calcul du poids adulte estim? et synth?se pointage vache ___________________ + if (!is.na(vachestot$dmC[i])) { + vachestot$ptgV[i] <- round(0.6 * vachestot$dmC[i] + 0.15 * vachestot$ds[i] + + 0.25 * vachestot$af[i], 1) + } else { + vachestot$ptgV[i] <- NA + } + + if (nrow(veaux) > 3){ + vachestot$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2) + alpha <- 1.62 - 0.01 * vachestot$precocite[i] + } else { + vachestot$precocite[i] <- NA + alpha <- 1.62 + } + if (!is.na(vachestot$pat24m[i])) { + vachestot$pad[i] <- round((vachestot$pat24m[i] - 50 * exp(-720 * alpha * 10**(-3))) + / (1 - exp(-720 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat18m[i])) { + vachestot$pad[i] <- round((vachestot$pat18m[i] - 50 * exp(-540 * alpha * 10**(-3))) + / (1 - exp(-540 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat12m[i])) { + vachestot$pad[i] <- round((vachestot$pat12m[i] - 50 * exp(-360 * alpha * 10**(-3))) + / (1-exp(-360 * alpha * 10**(-3))), 1) + } else { + vachestot$pad[i] <- NA + } + + # calcul des perfs de repro et du temps productif ____________________________ + + vachestot$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1) + + if (1 %in% veaux$ravelamere) { + vachestot$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1] + } else { + vachestot$agevel1[i] <- NA + } + + if (2 %in% veaux$ravelamere) { + vachestot$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1] + } else { + vachestot$ivv1[i] <- NA + } + if (3 %in% veaux$ravelamere) { + vachestot$ivv2p[i] <- round(mean(subset(veaux, + veaux$ravelamere > 2)$ivv, na.rm=T), 1) + } + + if (is.na(vachestot$ivv1[i]) | (!is.na(vachestot$ivv1[i]) + & vachestot$ivv1[i] < 390) ){ + e2 <- 0 + } else if (!is.na(vachestot$ivv1[i]) & vachestot$ivv1[i] >= 390) { + e2 <- vachestot$ivv1[i] - 390 + } + if (is.na(vachestot$ivv2p[i]) | (!is.na(vachestot$ivv2p[i]) + & vachestot$ivv2p[i] < 365) ){ + e3 <- 0 + } else if (!is.na(vachestot$ivv2p[i]) & vachestot$ivv2p[i] >= 365) { + e3 <- vachestot$ivv1[i] - 365 + } + if (is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") - 365 + } + } else if (!is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") - 365 + } + } + + vachestot$tempsprod[i] <- round( (vachestot$age_days[i] + - ( vachestot$agevel1[i] * 30.4 + + e2 + + e3 * (vachestot$nbcampvel[i] - 2) + + e4 + )) / vachestot$age_days[i] * 100, 1) + + # calcul des donn?es synthetiques sur les produitstot ___________________________ + + vachestot$prol[i] <- round(nrow(veaux) / (vachestot$nbcampvel[i]) * 100, 1) + vachestot$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O')) + / nrow(veaux)* 100, 1) + vachestot$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O')) + / nrow(veaux)* 100, 1) + vachestot$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T) + vachestot$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T) + vachestot$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux)* 100, 1) + vachestot$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') )) + / nrow(veaux)* 100, 1) + vachestot$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE) + + 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1) + vachestot$pn_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$ponais, na.rm=T), 1) + vachestot$p120_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat04m, na.rm=T), 1) + vachestot$p210_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat07m, na.rm=T), 1) + vachestot$pn_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$ponais, na.rm=T), 1) + vachestot$p120_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat04m, na.rm=T), 1) + vachestot$p210_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat07m, na.rm=T), 1) + vachestot$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1) + vachestot$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1) + vachestot$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1) + + ### convertion des NaN en NA + L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr', + 'p210_m','p210_f','p210_corr') + for (j in L){ + if (is.nan(vachestot[i,j]) == TRUE){ + vachestot[i,j] <- NA + } + } + } + } + } + # calcul des stats par pere ____________________________________________________ + + stats_peres <- PRODDIR %>% group_by(pere) %>% + summarise(nb_prod_in_chep = n()) %>% filter(nb_prod_in_chep >=5) + + stats_peres <- stats_peres %>% + add_column(utilgen = NA, prol = NA, mort = NA, txrepros = NA, nbpp = NA, + txvf = NA, pnm = NA, pnf = NA, p120m = NA, p120f = NA, p210m = NA, + p210f = NA, dmsev = NA, dssev = NA, + nbfilles_avecprod = NA, pctfilles_avecprod = NA, + isu_fillestot = NA, age_sort_fillestot = NA, + agevel1_fillestot = NA, ivv1_fillestot = NA, ivv2p_fillestot = NA, + vieprod_fillestot = NA, dmad_fillestot = NA, dsad_fillestot = NA, + afad_fillestot = NA, nbprod_fillestot = NA, txrepros_fillestot = NA, + nbpp_fillestot = NA, prol_fillestot = NA, mort_fillestot = NA, + txvf_fillestot = NA, + nbfillesact_avecprod = NA, pctfillesact_avecprod = NA, + isu_fillesact = NA, age_sort_fillesact = NA, + agevel1_fillesact = NA, ivv1_fillesact = NA, ivv2p_fillesact = NA, + vieprod_fillesact = NA, dmad_fillesact = NA, dsad_fillesact = NA, + afad_fillesact = NA, nbprod_fillesact = NA, txrepros_fillesact = NA, + nbpp_fillesact = NA, prol_fillesact = NA, mort_fillesact = NA, + txvf_fillesact = NA, nbfilles_renouv = NA) + + for (i in 1:nrow(stats_peres)) { + # stats sur la prod directe __________________________________________________ + li_prod <- subset(PRODDIR, PRODDIR$pere == stats_peres$pere[i]) + + stats_peres$utilgen[i] <- round(nrow(subset(li_prod, + li_prod$ravelamere == 1)) + / nrow(li_prod) * 100, 1) + stats_peres$prol[i] <- round(nrow(li_prod) + / nrow(li_prod %>% distinct(danais, mere)) + * 100, 1) + stats_peres$mort[i] <- round(nrow(subset(li_prod, li_prod$mortsev == 'O')) + / nrow(li_prod) * 100, 1) + stats_peres$txrepros[i] <- round(nrow(subset(li_prod, li_prod$repro == 'O')) + / nrow(subset(li_prod, + is.na(li_prod$mortsev))) * 100, 1) + stats_peres$nbpp[i] <- sum(li_prod$nbdescendants) + stats_peres$txvf[i] <- round(nrow(subset(li_prod, li_prod$conais %in% c('1','2'))) + / nrow(li_prod) * 100, 1) + stats_peres$pnm[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$ponais, na.rm=T),1) + stats_peres$pnf[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$ponais, na.rm=T),1) + stats_peres$p120m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat04m, na.rm=T),1) + stats_peres$p120f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat04m, na.rm=T),1) + stats_peres$p210m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat07m, na.rm=T),1) + stats_peres$p210f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat07m, na.rm=T),1) + stats_peres$dmsev[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$devmus, na.rm=T),1) + stats_peres$dssev[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$devsqe, na.rm=T),1) + + # stats sur la prod par les filles ___________________________________________ + li_filles <- subset(vachestot, vachestot$pere == stats_peres$pere[i]) + + # modif du 30/04/2024 + if (nrow(li_filles) > 0){ + stats_peres$nbfilles_avecprod[i] <- nrow(li_filles) + stats_peres$pctfilles_avecprod[i] <- round(nrow(li_filles) + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_filles) >= 3) { + stats_peres$isu_fillestot[i] <- round(mean(li_filles$indisu, na.rm=T),1) + stats_peres$age_sort_fillestot[i] <- round(mean(li_filles$age_years, na.rm=T),1) + stats_peres$agevel1_fillestot[i] <- round(mean(li_filles$agevel1, na.rm=T),1) + stats_peres$vieprod_fillestot[i] <- round(mean(li_filles$tempsprod, na.rm=T),1) + stats_peres$ivv1_fillestot[i] <- round(mean(li_filles$ivv1, na.rm=T),1) + stats_peres$ivv2p_fillestot[i] <- round(mean(li_filles$ivv2p, na.rm=T),1) + + stats_peres$dmad_fillestot[i] <- round(mean(li_filles$dmC, na.rm=T),1) + stats_peres$dsad_fillestot[i] <- round(mean(li_filles$ds, na.rm=T),1) + stats_peres$afad_fillestot[i] <- round(mean(li_filles$af, na.rm=T),1) + + stats_peres$prol_fillestot[i] <- round(mean(li_filles$prol, na.rm=T),1) + stats_peres$mort_fillestot[i] <- round(mean(li_filles$mort, na.rm=T),1) + stats_peres$txvf_fillestot[i] <- round(mean(li_filles$txvf, na.rm=T),1) + + stats_peres$nbprod_fillestot[i] <- round(sum(li_filles$nbdescendants),1) + stats_peres$txrepros_fillestot[i] <- round(mean(li_filles$txrepros, na.rm=T),1) + stats_peres$nbpp_fillestot[i] <- round(sum(li_filles$nbpp),1) + } + + # stats sur la prod par les filles actives ___________________________________ + li_filles_act <- subset(vachestot, vachestot$pere == stats_peres$pere[i] + & is.na(vachestot$dasort)) + + # modif du 30/04/2024 + if (nrow(li_filles_act) > 0) { + stats_peres$nbfillesact_avecprod[i] <- nrow(li_filles_act) + stats_peres$pctfillesact_avecprod[i] <- round(nrow(li_filles_act) + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_filles_act) >= 3) { + stats_peres$isu_fillesact[i] <- round(mean(li_filles_act$indisu, na.rm=T),1) + stats_peres$age_sort_fillesact[i] <- round(mean(li_filles_act$age_years, na.rm=T),1) + stats_peres$agevel1_fillesact[i] <- round(mean(li_filles_act$agevel1, na.rm=T),1) + stats_peres$vieprod_fillesact[i] <- round(mean(li_filles_act$tempsprod, na.rm=T),1) + stats_peres$ivv1_fillesact[i] <- round(mean(li_filles_act$ivv1, na.rm=T),1) + stats_peres$ivv2p_fillesact[i] <- round(mean(li_filles_act$ivv2p, na.rm=T),1) + + stats_peres$dmad_fillesact[i] <- round(mean(li_filles_act$dmC, na.rm=T),1) + stats_peres$dsad_fillesact[i] <- round(mean(li_filles_act$ds, na.rm=T),1) + stats_peres$afad_fillesact[i] <- round(mean(li_filles_act$af, na.rm=T),1) + + stats_peres$prol_fillesact[i] <- round(mean(li_filles_act$prol, na.rm=T),1) + stats_peres$mort_fillesact[i] <- round(mean(li_filles_act$mort, na.rm=T),1) + stats_peres$txvf_fillesact[i] <- round(mean(li_filles_act$txvf, na.rm=T),1) + + stats_peres$nbprod_fillesact[i] <- round(sum(li_filles_act$nbdescendants),1) + stats_peres$txrepros_fillesact[i] <- round(mean(li_filles_act$txrepros, na.rm=T),1) + stats_peres$nbpp_fillesact[i] <- round(sum(li_filles_act$nbpp),1) + } + #filles a venir + nbfr <- nrow(subset(inventaire, + inventaire$pere == stats_peres$pere[i] + & inventaire$nbdescendants == 0 + & inventaire$sexbov == '2')) + if (nbfr > 0 ){ + stats_peres$nbfilles_renouv[i] <- nbfr + } + } + + stats_peres <- merge(peres, stats_peres, all.x=F, all.y=T) + + write.table(stats_peres, + file = paste(rep, '/', CHEP, '_ResTaureaux_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + + + ################################################################################ + ### remontee des lignees femelles ############################################## + ################################################################################ + + hbcgene_coltypes <- cols(anim = col_character(), nobovi = col_character(), + nomnais = col_character(), qualifco = col_character(), + pere = col_character(), mere = col_character(), + dcre = col_character(), danais = col_character(), + ifnais = col_integer(), crsevs = col_integer(), + dmsevs = col_integer(), dssevs = col_integer(), + alaits = col_integer(), isevre = col_integer(), + ivmate = col_integer(), iqmqms = col_integer(), + iabjbs = col_integer(), avelag = col_integer(), + indisu = col_integer(), + cdisev = col_number()) + + ## on remonte vers les fondatrices + + femelles <- inventaire %>% filter(sexbov == '2') + femelles[] <- lapply(femelles, function(x) if(is.logical(x)) as.character(x) else x) + + old <- Sys.time() + + t_travail <- femelles + t_temp = t_final <- inventaire[0,] + + line_mere <- inventaire[0,] + #line_mere$iqmqms = line_mere$iabjbs <- NA + + # mise en commentaire : 07/03/2023 + # t_travail[] <- lapply(t_travail, function(x) if(is.Date(x)) as.character(x) else x) + # t_final[] <- lapply(t_final, function(x) if(is.Date(x)) as.character(x) else x) + # t_temp[] <- lapply(t_temp, function(x) if(is.Date(x)) as.character(x) else x) + + t_travail[] <- lapply(t_travail, function(x) if(is.logical(x)) as.character(x) else x) + t_final[] <- lapply(t_final, function(x) if(is.logical(x)) as.character(x) else x) + t_temp[] <- lapply(t_temp, function(x) if(is.logical(x)) as.character(x) else x) + + nbl <- nrow(t_travail) + nb_tours <- 0 + + while (nbl > 0) { + for (i in 1:nrow(t_travail)) { + if (!is.na(t_travail$mere[i])) { + if ((trim_str(t_travail$mere[i]) %in% trim_str(t_final$anim)) + | (trim_str(t_travail$mere[i]) %in% trim_str(t_travail$anim)) + | (trim_str(t_travail$mere[i]) %in% trim_str(t_temp$anim))) { + #print(paste0(as.character(i), "D?ja list?e")) + } else { + #print(t_travail$mere[i]) + line_mere <- chgt_infos(trim_str(t_travail$mere[i])) + if (is.data.frame(line_mere)) { + if (nrow(line_mere) > 0 ) { + + # ajout du 07/03/2023 + line_mere <- line_mere[, intersect(names(line_mere), names(femelles))] + line_mere[] <- lapply(line_mere, function(x) if(is.logical(x)) as.character(x) else x) + for ( x in colnames(line_mere) ) { + line_mere[,x] <- eval(call( paste0("as.", class(femelles[,x])), line_mere[,x]) ) + } + + if (ncol(line_mere) > 22) { + # attribution a line_mere les memes types de col que inventaire + # afin de permettre la jointure sans erreur de type + + # modif : mise en commentaire 07/03/2023 + # line_mere$iqmqms = line_mere$iabjbs <- NA + # line_mere <- line_mere[, colnames(t_final)] + # line_mere[] <- mapply(FUN = as, line_mere, sapply(t_final, class), SIMPLIFY = FALSE) + + if ( !is.na(line_mere$chna) & trim_str(line_mere$chna) == CHEP) { + t_temp <- bind_rows(t_temp, line_mere) + } else { + #print("N?e ailleurs") + t_final <- bind_rows(t_final, line_mere) + } + } else { + #print("Ligne de Hbcgene") + # attribution a line_mere les types de col definis plus haut + # afin de permettre la jointure sans erreur de type + + # modif : mise en commentaire 07/03/2023 + # line_mere <- type.convert(line_mere, col_types = hbcgene_coltypes) + # line_mere$nobovi <- as.character(line_mere$nobovi) + + #cat(i, class(line_mere$indite), class(t_final$indite)) # pb de types + t_final <- bind_rows(t_final, line_mere) + } + } + } else { + #print("Retour vide du WS") + } + } + } else { + #print("Pas de mere") + } + } # for + t_final <- bind_rows(t_final, t_travail) + t_travail <- t_temp + t_temp <- t_temp[0,] + nbl <- nrow(t_travail) + nb_tours <- nb_tours+1 + print(paste("Nombre de g?n?rations depuis les animaux actifs : ", nb_tours, sep='')) + } # while + + inv_asc <- t_final + + fondatrices <- subset(inv_asc, is.na(t_final$mere) + | trim_str(t_final$chna) != CHEP + | is.na(t_final$chna) + | !(trim_str(inv_asc$mere) %in% trim_str(inv_asc$anim)) ) # modif du 27/03/2023 + + new <- Sys.time()-old + cat("Remont?e des lign?es :", round(new, 1) , "sec") + + # on redescendant vers tous les animaux n?s dans le cheptel issus des fondatrices + # on met de c?t? les vaches ayant produits a leur tour dans le cheptel + # ainsi que les males ayant produit (peu importe ou) + + old <- Sys.time() + + t_travail <- fondatrices + t_travail$fondatrice <- t_travail$anim + t_temp = t_final <- inventaire[0,] + t_final <- t_final %>% add_column(fondatrice = NA, iqmqms = NA, iabjbs = NA) + t_temp <- t_temp %>% add_column(fondatrice = NA, iqmqms = NA, iabjbs = NA) + + t_travail[] <- lapply(t_travail, function(x) if(is.logical(x)) as.character(x) else x) + t_final[] <- lapply(t_final, function(x) if(is.logical(x)) as.character(x) else x) + t_temp[] <- lapply(t_temp, function(x) if(is.logical(x)) as.character(x) else x) + # mise en commentaire : 07/03/2023 + # t_travail[] <- lapply(t_travail, function(x) if(is.Date(x)) as.character(x) else x) + # t_final[] <- lapply(t_final, function(x) if(is.Date(x)) as.character(x) else x) + # t_temp[] <- lapply(t_temp, function(x) if(is.Date(x)) as.character(x) else x) + + nbl <- nrow(t_travail) + nb_tours <- 0 + + while (nbl > 0) { + for (i in 1:nrow(t_travail)) { + cat(nbl, i, t_travail$anim[i], t_travail$nobovi[i], '\n') + produits <- try(appel_infos(trim_str(t_travail$anim[i]), reqMere)) + if (!is.null(produits)) { + + # MAJ du 07/03/2023 + produits <- produits[, intersect(names(produits), names(femelles))] + produits[] <- lapply(produits, function(x) if(is.logical(x)) as.character(x) else x) + for ( x in colnames(produits) ) { + produits[,x] <- eval(call( paste0("as.", class(femelles[,x])), produits[,x]) ) + } + + # modif : mise en commentaire 07/03/2023 + # produits$iqmqms = produits$iabjbs = produits$fondatrice <- NA + # produits <- produits[,colnames(t_final)] + # produits[] <- mapply(FUN = as, produits, sapply(t_final, class), SIMPLIFY = FALSE) + # produits[] <- lapply(produits, function(x) if(is.logical(x)) as.character(x) else x) + # produits[] <- lapply(produits, function(x) if(is.Date(x)) as.character(x) else x) + + produits <- subset(produits, trim_str(produits$chna) == CHEP) + if (length(produits) > 0 & nrow(produits) > 0){ + produits$fondatrice <- t_travail$fondatrice[i] + t_final <- bind_rows(t_final, produits) + repros <- subset(produits, produits$nbdescendants > 0 + & produits$sexbov == '2') + if (nrow(repros) > 0) { + t_temp <- bind_rows(t_temp, repros) + } + } + } + } # for + t_final <- bind_rows(t_final, t_travail) + t_travail <- t_temp + t_temp <- t_temp[0,] + nbl <- nrow(t_travail) + nb_tours <- nb_tours+1 + print(paste("Nombre de g?n?rations apras les fondatrices : ", nb_tours, sep='')) + } # while + + inv_desc <- t_final + + # doublons ??? + inv_desc <- inv_desc[-which(duplicated(inv_desc$anim)),] + if (nrow(inv_desc) == 0 ){ + inv_desc <- t_final + } + + # modif du 07/03/2023 + # pb du nombre de produits non ramenés par WS en appellant la mère + # inv_asc_not_in_desc <- inv_asc %>% filter( !(trim_str(anim) %in% trim_str(inv_desc$anim)) ) + # if ( nrow(inv_asc_not_in_desc) > 0) { + # inv_desc <- bind_rows(inv_desc, inv_asc_not_in_desc) + # } + + new <- Sys.time()-old + cat("Remont?e des lign?es :", round(new, 1)) + + # vaches tot + vachestot <- inv_desc %>% filter(sexbov == '2' & nbdescendants > 0) + produitstot <- subset(inv_desc, trim_str(inv_desc$mere) %in% trim_str(vachestot$anim)) + + if (nrow(vachestot) > 0) { + # recherche des meres dans les porteuses pour aller chercher + # les produitstot s'ils existent dans HBCANIM + + porteuses <- subset(indite, !is.na(indite$MEREIPG) + & indite$MEREIPG %in% trim_str(vachestot$anim)) + donneuses <- subset(indite, !is.na(indite$MERECPB) + & indite$MERECPB %in% trim_str(vachestot$anim)) + # l'indicateur de donneuse d'embryon est renseign? apres dans --> vachestot$ACINAC + + if ( is.numeric(vachestot$danais[1]) & vachestot$danais[1] > 1*(10**8) ) { + vachestot$danais <- as.Date(as.POSIXct(vachestot$danais / 1000, origin="1970-01-01")) + vachestot$dasort <- as.Date(as.POSIXct(vachestot$dasort / 1000, origin="1970-01-01")) + } + + for (i in 1:nrow(vachestot)) { + if (is.na(vachestot$dasort[i])){ + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], Sys.Date()), unit="days") + } else { + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], vachestot$dasort[i]), unit="days") + } + } + + vachestot$age_years <- round(vachestot$age_days / 365, 1) + + # les veaux port?s sont rajout?s aux produitstot si non r?cup?r?s avant ________ non appliqu? car raisonnement sur lign?es + # if (nrow(porteuses) > 0) { + # for (i in 1:nrow(porteuses)) { + # if (!(porteuses$ANIM[i] %in% trim_str(produitstot$anim))) { + # + # temp <- appel_infos(porteuses$ANIM[i], hbcanim) # a voir : gerer les retours vides !!!! + # li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i]) + # + # temp$mere[1] <- porteuses$MEREIPG[i] + # temp[1, c(60:67, 86:103)] <- NA + # temp$danaismere[1] <- as.character(li_mere$danais[1]) + # temp$indite[1] <- 'O_corr' + # + # produitstot <- rbind(produitstot, temp) + # } + # } + # } + + # modifs des types de donn?es, pour calcul par la suite + if ( is.numeric(produitstot$danais[1]) & produitstot$danais[1] > 1*(10**8) ) { + produitstot$danais <- as.Date(as.POSIXct(produitstot$danais / 1000, origin="1970-01-01")) + produitstot$dasort <- as.Date(as.POSIXct(produitstot$dasort / 1000, origin="1970-01-01")) + produitstot$danaismere <- as.Date(as.POSIXct(produitstot$danaismere / 1000, origin="1970-01-01")) + } + + test_date <- produitstot %>% filter( !is.na(danaismere) ) + if (nrow(test_date) > 0){ + if ( is.numeric(test_date$danaismere[1]) & test_date$danaismere[1] > 1*(10**8) ) { + produitstot$danaismere <- as.Date(as.POSIXct(produitstot$danaismere / 1000, origin="1970-01-01")) + } + } + + produitstot$danais <- as.Date(produitstot$danais, format = "%Y-%m-%d") + produitstot$dasort <- as.Date(produitstot$dasort, format = "%Y-%m-%d") + + produitstot$mere <- trim_str(produitstot$mere) + produitstot$pere <- trim_str(produitstot$pere) + produitstot$anim <- trim_str(produitstot$anim) + + produitstot$ravelamere <- as.numeric(produitstot$ravelamere) + produitstot$ivv <- as.numeric(produitstot$ivv) + produitstot$campn <- as.numeric(produitstot$campn) + produitstot$nbdescendants <- as.numeric(produitstot$nbdescendants) + + produitstot$ponais <- as.numeric(produitstot$ponais) + produitstot$pat04m <- as.numeric(produitstot$pat04m) + produitstot$pat07m <- as.numeric(produitstot$pat07m) + + produitstot$devsqe <- as.numeric(produitstot$devsqe) + produitstot$devmus <- as.numeric(produitstot$devmus) + produitstot$aptfon <- as.numeric(produitstot$aptfon) + + # on ne garde que les TE port?s par une vache active du cheptel + PRODTOT <- subset(produitstot, produitstot$indite != 'O') + + # ajout des produitstot IPG + PRODTOT <- merge(PRODTOT, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + PRODTOT <- PRODTOT[order(PRODTOT$danais, decreasing = F),] + PRODTOT <- PRODTOT[order(PRODTOT$mere, decreasing = T),] + + # correction des ravelamere des TE si possible + for (i in 1:nrow(PRODTOT)) { + if (is.na(PRODTOT$ravelamere[i])) { + if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] %in% c(1, 2)) { + PRODTOT$ravelamere[i] <- 1 + PRODTOT$typemere[i] <- 'G' + } else if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] > 1) { + PRODTOT$ravelamere[i] <- PRODTOT$ravelamere[i+1] - 1 + PRODTOT$typemere[i] <- 'V' + } + } + } + + # age au velage de la mere + PRODTOT$agevel <- round(time_length(interval(PRODTOT$danaismere, PRODTOT$danais), + unit="months"), 1) + + # IVV : utilisation de la colonne deja pr?sente de HBCANIM + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$indite[i] == 'O_corr') { + PRODTOT$nobovi[i] <- paste('#', PRODTOT$nobovi[i], sep='') + } + # repro + if (PRODTOT$anim[i] %in% czhbc$ANIM + | (!is.na(PRODTOT$NBPRODIPG[i]) & PRODTOT$NBPRODIPG[i] > 0) + | (!is.na(PRODTOT$nbdescendants[i]) + & as.numeric(PRODTOT$nbdescendants[i]) > 0)) { + PRODTOT$repro[i] <- 'O' + } else { + PRODTOT$repro[i] <- NA + PRODTOT$nobovi[i] <- PRODTOT$nobovi[i] %>% str_to_lower() + } + # mortalite + if (!is.na(PRODTOT$dasort[i]) & !is.na(PRODTOT$casort[i]) + & PRODTOT$casort[i] == 'M' + & time_length(interval(PRODTOT$danais[i], PRODTOT$dasort[i]), + unit="days") < 211){ + PRODTOT$mortsev[i] <- 'O' + PRODTOT$nobovi[i]=paste(PRODTOT$nobovi[i], ' (MavS)', sep='') + } else { + PRODTOT$mortsev[i] <- NA + } + # IVV + if (i > 1) { + # cas normaux + if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + 1 + #& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] == '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- PRODTOT$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- round(time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + / (PRODTOT$ravelamere[i] + - PRODTOT$ravelamere[i-1]), 0) + } else { + PRODTOT$ivv[i] <- NA + } + if (!is.na(PRODTOT$ivv[i]) & PRODTOT$ivv[i] < 280) { + PRODTOT$ivv[i] <- NA + } + } + } + + # calcul des effets du cheptel : rang de velage et sexe du veau + effet <- PRODTOT %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) + effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] + effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p120[1] + effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p210[1] + + # calcul des effets du cheptel : sexe sur la repro + effetsexe <- PRODTOT %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + + # report des effets sur les produitstot + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$sexbov[i] == '2') { #___________________________________ FEMELLES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] * rapport_MF + if (!is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #___genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #________________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] + if ( !is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #_________________________________genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } + } + + # calcul des donn?es ?labor?es par vache active + + for (i in 1:nrow(vachestot)) { + # ___________________________________________rappel des produitstot par vache + veaux <- PRODTOT %>% filter(mere == trim_str(vachestot$anim[i])) + + # ___________________________________________calcul des infos utiles par vache + + # calcul du poids adulte estim? et synthese pointage vache ___________________ + if (!is.na(vachestot$dmC[i])) { + vachestot$ptgV[i] <- round(0.6 * vachestot$dmC[i] + 0.15 * vachestot$ds[i] + + 0.25 * vachestot$af[i], 1) + } else { + vachestot$ptgV[i] <- NA + } + + if (nrow(veaux) > 3){ + vachestot$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2) + alpha <- 1.62 - 0.01 * vachestot$precocite[i] + } else { + vachestot$precocite[i] <- NA + alpha <- 1.62 + } + if (!is.na(vachestot$pat24m[i])) { + vachestot$pad[i] <- round((as.numeric(vachestot$pat24m[i]) - 50 * exp(-720 * alpha * 10**(-3))) + / (1 - exp(-720 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat18m[i])) { + vachestot$pad[i] <- round((as.numeric(vachestot$pat18m[i]) - 50 * exp(-540 * alpha * 10**(-3))) + / (1 - exp(-540 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat12m[i])) { + vachestot$pad[i] <- round((as.numeric(vachestot$pat12m[i]) - 50 * exp(-360 * alpha * 10**(-3))) + / (1-exp(-360 * alpha * 10**(-3))), 1) + } else { + vachestot$pad[i] <- NA + } + + # calcul des perfs de repro et du temps productif ____________________________ + + vachestot$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1) + + if (1 %in% veaux$ravelamere) { + vachestot$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1] + } else { + vachestot$agevel1[i] <- NA + } + + if (2 %in% veaux$ravelamere) { + vachestot$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1] + } else { + vachestot$ivv1[i] <- NA + } + if (3 %in% veaux$ravelamere) { + vachestot$ivv2p[i] <- round(mean(subset(veaux, + veaux$ravelamere > 2)$ivv, na.rm=T), 1) + } + + if (is.na(vachestot$ivv1[i]) | (!is.na(vachestot$ivv1[i]) + & vachestot$ivv1[i] < 390) ){ + e2 <- 0 + } else if (!is.na(vachestot$ivv1[i]) & vachestot$ivv1[i] >= 390) { + e2 <- vachestot$ivv1[i] - 390 + } + if (is.na(vachestot$ivv2p[i]) | (!is.na(vachestot$ivv2p[i]) + & vachestot$ivv2p[i] < 365) ){ + e3 <- 0 + } else if (!is.na(vachestot$ivv2p[i]) & vachestot$ivv2p[i] >= 365) { + e3 <- vachestot$ivv1[i] - 365 + } + if (is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") - 365 + } + } else if (!is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") - 365 + } + } + + vachestot$tempsprod[i] <- round( (vachestot$age_days[i] + - ( vachestot$agevel1[i] * 30.4 + + e2 + + e3 * (vachestot$nbcampvel[i] - 2) + + e4 + )) / vachestot$age_days[i] * 100, 1) + + # calcul des donn?es synthetiques sur les produitstot ___________________________ + + vachestot$prol[i] <- round(nrow(veaux) / (vachestot$nbcampvel[i]) * 100, 1) + vachestot$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O')) + / nrow(veaux)* 100, 1) + vachestot$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O')) + / nrow(veaux)* 100, 1) + vachestot$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T) + vachestot$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T) + vachestot$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux)* 100, 1) + vachestot$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') )) + / nrow(veaux)* 100, 1) + vachestot$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE) + + 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1) + vachestot$pn_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$ponais, na.rm=T), 1) + vachestot$p120_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat04m, na.rm=T), 1) + vachestot$p210_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat07m, na.rm=T), 1) + vachestot$pn_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$ponais, na.rm=T), 1) + vachestot$p120_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat04m, na.rm=T), 1) + vachestot$p210_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat07m, na.rm=T), 1) + vachestot$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1) + vachestot$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1) + vachestot$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1) + + ### convertion des NaN en NA + L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr', + 'p210_m','p210_f','p210_corr') + for (j in L){ + if (is.nan(vachestot[i,j]) == TRUE){ + vachestot[i,j] <- NA + } + } + } + } + + # calcul des stats par fondatrice ______________________________________________ + + stats_lignees <- PRODTOT %>% group_by(fondatrice) %>% + summarise(nb_desc_in_chep = n()) %>% filter(nb_desc_in_chep >=5) + + stats_lignees <- stats_lignees %>% + add_column(utilgen = NA, prol = NA, mort = NA, txrepros = NA, nbpp = NA, + txvf = NA, pnm = NA, pnf = NA, p120m = NA, p120f = NA, p210m = NA, + p210f = NA, dmsev = NA, dssev = NA, + nbfem_avecprod = NA, pctfem_avecprod = NA, + isu_femtot = NA, age_sort_femtot = NA, + agevel1_femtot = NA, ivv1_femtot = NA, ivv2p_femtot = NA, + vieprod_femtot = NA, dmad_femtot = NA, dsad_femtot = NA, + afad_femtot = NA, nbprod_femtot = NA, txrepros_femtot = NA, + nbpp_femtot = NA, prol_femtot = NA, mort_femtot = NA, + txvf_femtot = NA, + nbfemact_avecprod = NA, pctfemact_avecprod = NA, + isu_femact = NA, age_sort_femact = NA, + agevel1_femact = NA, ivv1_femact = NA, ivv2p_femact = NA, + vieprod_femact = NA, dmad_femact = NA, dsad_femact = NA, + afad_femact = NA, nbprod_femact = NA, txrepros_femact = NA, + nbpp_femact = NA, prol_femact = NA, mort_femact = NA, + txvf_femact = NA, nbfem_renouv = NA) + + for (i in 1:nrow(stats_lignees)) { + # stats sur la prod directe __________________________________________________ + li_prod <- subset(PRODTOT, PRODTOT$fondatrice == stats_lignees$fondatrice[i]) + + stats_lignees$utilgen[i] <- round(nrow(subset(li_prod, + li_prod$ravelamere == 1)) + / nrow(li_prod) * 100, 1) + stats_lignees$prol[i] <- round(nrow(li_prod) + / nrow(li_prod %>% distinct(danais, mere)) + * 100, 1) + stats_lignees$mort[i] <- round(nrow(subset(li_prod, li_prod$mortsev == 'O')) + / nrow(li_prod) * 100, 1) + stats_lignees$txrepros[i] <- round(nrow(subset(li_prod, li_prod$repro == 'O')) + / nrow(subset(li_prod, + is.na(li_prod$mortsev))) * 100, 1) + stats_lignees$nbpp[i] <- sum(li_prod$nbdescendants) + stats_lignees$txvf[i] <- round(nrow(subset(li_prod, li_prod$conais %in% c('1','2'))) + / nrow(li_prod) * 100, 1) + stats_lignees$pnm[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$ponais, na.rm=T),1) + stats_lignees$pnf[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$ponais, na.rm=T),1) + stats_lignees$p120m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat04m, na.rm=T),1) + stats_lignees$p120f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat04m, na.rm=T),1) + stats_lignees$p210m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat07m, na.rm=T),1) + stats_lignees$p210f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat07m, na.rm=T),1) + stats_lignees$dmsev[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$devmus, na.rm=T),1) + stats_lignees$dssev[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$devsqe, na.rm=T),1) + + # stats sur la prod par les fem ___________________________________________ + li_fem <- subset(vachestot, vachestot$fondatrice == stats_lignees$fondatrice[i]) + + # modif du 30/04/2024 + if (nrow(li_fem) > 0) { + stats_lignees$nbfem_avecprod[i] <- nrow(li_fem) + stats_lignees$pctfem_avecprod[i] <- round(nrow(li_fem) + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_fem) >= 3) { + stats_lignees$isu_femtot[i] <- round(mean(li_fem$indisu, na.rm=T),1) + stats_lignees$age_sort_femtot[i] <- round(mean(li_fem$age_years, na.rm=T),1) + stats_lignees$agevel1_femtot[i] <- round(mean(li_fem$agevel1, na.rm=T),1) + stats_lignees$vieprod_femtot[i] <- round(mean(li_fem$tempsprod, na.rm=T),1) + stats_lignees$ivv1_femtot[i] <- round(mean(li_fem$ivv1, na.rm=T),1) + stats_lignees$ivv2p_femtot[i] <- round(mean(as.numeric(li_fem$ivv2p), na.rm=T),1) + + stats_lignees$dmad_femtot[i] <- round(mean(li_fem$dmC, na.rm=T),1) + stats_lignees$dsad_femtot[i] <- round(mean(li_fem$ds, na.rm=T),1) + stats_lignees$afad_femtot[i] <- round(mean(li_fem$af, na.rm=T),1) + + stats_lignees$prol_femtot[i] <- round(mean(li_fem$prol, na.rm=T),1) + stats_lignees$mort_femtot[i] <- round(mean(li_fem$mort, na.rm=T),1) + stats_lignees$txvf_femtot[i] <- round(mean(li_fem$txvf, na.rm=T),1) + + stats_lignees$nbprod_femtot[i] <- round(sum(li_fem$nbdescendants),1) + stats_lignees$txrepros_femtot[i] <- round(mean(li_fem$txrepros, na.rm=T),1) + stats_lignees$nbpp_femtot[i] <- round(sum(li_fem$nbpp),1) + } + + # stats sur la prod par les fem actives ___________________________________ + li_fem_act <- subset(vachestot, vachestot$fondatrice == stats_lignees$fondatrice[i] + & is.na(vachestot$dasort)) + + # modif du 30/04/2024 + if (nrow(li_fem_act) > 0) { + stats_lignees$nbfemact_avecprod[i] <- nrow(li_fem_act) + stats_lignees$pctfemact_avecprod[i] <- round(nrow(li_fem_act) + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_fem_act) >= 3) { + stats_lignees$isu_femact[i] <- round(mean(li_fem_act$indisu, na.rm=T),1) + stats_lignees$age_sort_femact[i] <- round(mean(li_fem_act$age_years, na.rm=T),1) + stats_lignees$agevel1_femact[i] <- round(mean(li_fem_act$agevel1, na.rm=T),1) + stats_lignees$vieprod_femact[i] <- round(mean(li_fem_act$tempsprod, na.rm=T),1) + stats_lignees$ivv1_femact[i] <- round(mean(li_fem_act$ivv1, na.rm=T),1) + stats_lignees$ivv2p_femact[i] <- round(mean(as.numeric(li_fem_act$ivv2p), na.rm=T),1) + + stats_lignees$dmad_femact[i] <- round(mean(li_fem_act$dmC, na.rm=T),1) + stats_lignees$dsad_femact[i] <- round(mean(li_fem_act$ds, na.rm=T),1) + stats_lignees$afad_femact[i] <- round(mean(li_fem_act$af, na.rm=T),1) + + stats_lignees$prol_femact[i] <- round(mean(li_fem_act$prol, na.rm=T),1) + stats_lignees$mort_femact[i] <- round(mean(li_fem_act$mort, na.rm=T),1) + stats_lignees$txvf_femact[i] <- round(mean(li_fem_act$txvf, na.rm=T),1) + + stats_lignees$nbprod_femact[i] <- round(sum(li_fem_act$nbdescendants),1) + stats_lignees$txrepros_femact[i] <- round(mean(li_fem_act$txrepros, na.rm=T),1) + stats_lignees$nbpp_femact[i] <- round(sum(li_fem_act$nbpp),1) + } + # filles a venir + nbfr <- nrow(subset(inv_desc, + inv_desc$fondatrice == stats_lignees$fondatrice[i] + & inv_desc$nbdescendants == 0 + & inv_desc$sexbov == '2' + & inv_desc$actif == '1')) + if (nbfr > 0) { + stats_lignees$nbfem_renouv[i] <- nbfr + } + } + + fondatrices$anim <- trim_str(fondatrices$anim) + stats_lignees$fondatrice <- trim_str(stats_lignees$fondatrice) + stats_lignees <- merge(fondatrices[,c('anim', 'nobovi', 'danais', 'nomnais')], + stats_lignees, by.x='anim', by.y='fondatrice', all.x=F, all.y=T) + + write.table(stats_lignees, + file = paste(rep, '/', CHEP, '_ResLigneesF_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + + ################################################################################ + ### trac? des lign?es sur PDF __________________________________________________ + ################################################################################ + + # modif 27/03/2023 : + # déduction campagne en cours pour garder les femelles de renouvellement + # sans les laitonnes de la campagne en cours + camp_actuelle = ifelse(month(Sys.Date()) %in% c('08','09','10','11','12'), + year(Sys.Date()) + 1, + year(Sys.Date())) + + fem_tot <- inv_desc %>% filter(sexbov == '2' & campn < camp_actuelle & (nbdescendants > 0 | actif == '1')) + + # modif 27/03/2023 : + # modif de la valeur "actif" pour mettre en rouge les vaches actives ailleurs + fem_tot$actif <- ifelse(fem_tot$actif == '1' & trim_str(fem_tot$chepdet) == CHEP, '1', '0') + + fem_tot$anim <- trim_str(fem_tot$anim) + fem_tot$mere <- trim_str(fem_tot$mere) + fem_tot$pere <- trim_str(fem_tot$pere) + for (i in 1:nrow(fem_tot)) { + if (fem_tot$indite[i] == 'O') { + fem_tot$nobovi[i] <- paste(fem_tot$nobovi[i], ' (TE)', sep='') + } + if (fem_tot$nbdescendants[i] == 0) { + fem_tot$nobovi[i] <- fem_tot$nobovi[i] %>% tolower() + } + if (fem_tot$corabo[i] == '38'){ + fem_tot$corabo[i] <- 'CHAROLAISE' + } else { + fem_tot$corabo[i] <- 'CROISEE' + } + if (fem_tot$sexbov[i] == '2') { + fem_tot$sexbov[i] <- 'female' + } else if (fem_tot$sexbov[i] == '1'){ + fem_tot$sexbov[i] <- 'male'} + if (is.na(fem_tot$nobovi[i])){ + fem_tot$nobovi[i] <- paste(str_sub(fem_tot$anim[i], -4), + subset(LETTRES, LETTRES$ANNEE == fem_tot$campn[i])[1,'LETTRE'], sep='_') + } + } + + cla_rg <- tabfinal[,c('NUM_VACHE', 'rang CARRIERE')] + nbvcla <- nrow(subset(cla_rg, !is.na(cla_rg$`rang CARRIERE`))) + for(i in 1:nrow(cla_rg)) { + if (!is.na(cla_rg$`rang CARRIERE`[i])){ + cla_rg$`rang CARRIERE`[i] <- paste('eCow : ', cla_rg$`rang CARRIERE`[i], ' / ', nbvcla, sep='') + } else { + cla_rg$`rang CARRIERE`[i] <- 'eCow : NC' + } + } + + sub_ped <- fem_tot[,c('anim', 'pere', 'mere', 'sexbov', 'corabo', 'campn', 'actif', 'nobovi')] + sub_ped <- merge(sub_ped, cla_rg, by.x='anim', by.y='NUM_VACHE', all.x=T, all.y=T) + colnames(sub_ped)=c('Indiv','Sire','Dam','Sex','Breed','Born','Affected','Nom','ecowcarr') + + Pedig <- prePed(sub_ped) + for(i in 1:nrow(Pedig)) { + if (is.na(Pedig$ecowcarr[i])){ + Pedig$ecowcarr[i] <- '' + } + if (!is.na(Pedig$Sex[i]) & Pedig$Sex[i] == 'male'){ + toro <- subset(inv_desc, trim_str(inv_desc$pere) == Pedig$Indiv[i]) + Pedig$Nom[i] <- toro$nompere[1] + } + if (!is.na(Pedig$Sex[i]) & Pedig$Sex[i] == 'female' & is.na(Pedig$Nom[i]) ){ + mom <- subset(inv_desc, trim_str(inv_desc$mere) == Pedig$Indiv[i]) + Pedig$Nom[i] <- mom$nommere[1] + } + } + + img=readPNG("C:/Users/LJeannot/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/IMPORTS_R/HBC-Logo.png") + + dir.create(path=paste(rep, "/", CHEP, '_pdf_ligneesF', sep='')) + sousrep=paste(rep, "/" ,CHEP, '_pdf_ligneesF', sep='') + + fondatrices$anim <- trim_str(fondatrices$anim) + fondatrices <- subset(fondatrices, (fondatrices$nbdescendants > 0 | is.na(fondatrices$nbdescendants)) + & fondatrices$anim %in% trim_str(fem_tot$fondatrice)) + + if (nrow(fondatrices) > 0) { + for (i in 1:nrow(fondatrices)) { + print(fondatrices$anim[i]) + sPed <- subPed(Pedig, keep=fondatrices$anim[i], prevGen=0, succGen=10) + taille <- nrow(sPed) + print(taille) + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100, 1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)) { + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n') + } + tryCatch( + expr = { + if (nrow(sPed) > 1 & nbt > 0) { + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], '.pdf', sep='') + pdf(file = paste(sousrep, "/", nom, sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? a droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2, 2, 2, 5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == '1', "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 15, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette lignee representent ',tx2,"% des vaches en production du cheptel.",sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 20, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ',tx,"% des vaches actives de cette lignee appartiennent a la moitie superieure classee du cheptel.",sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + } + + if (taille >= 80){ + z <- subset(fem_tot, fem_tot$mere == fondatrices$anim[i]) + if (nrow(z) > 1){ + for (k in 1:nrow(z)){ + sPed <- subPed(Pedig, keep=z$anim[k], prevGen=0, succGen=10) + taille <- nrow(sPed) + + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100,1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)){ + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n') + } + + if (nrow(sPed) > 1 & nbt > 0){ + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], '_sl_', z$anim[k], '.pdf', sep='') + pdf(file = paste(sousrep, "/", nom, sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? a droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2,2,2,5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0, + paste('Sous-lignee : fille', z$nobovi[k], str_sub(z$anim[k], -4), sep=' '), + srt=270, cex=0.6, col='dark red', font=1) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette sous-lignee representent ', + tx2, "% des vaches en production du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ', tx, + "% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + + + if (taille >= 80){ + a <- subset(fem_tot, fem_tot$mere == z$anim[k]) + if (nrow(a) > 1){ + for (n in 1:nrow(a)){ + sPed <- subPed(Pedig, keep=a$anim[n], prevGen=0, succGen=10) + taille <- nrow(sPed) + + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100, 1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)){ + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j],-4), sPed$Nom[j], sep='\n') + } + + if (nrow(sPed) > 1 & nbt > 0){ + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], + '_ssl_', z$anim[k], '_', a$anim[n], '.pdf',sep='') + pdf(file = paste(sousrep,"/",nom,sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? ? droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2,2,2,5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0, + paste('Sous-lignee : petite-fille',a$nobovi[n], str_sub(a$anim[n],-4),sep=' '), + srt=270, cex=0.6, col='dark red', font=1) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette sous-lignee representent ', + tx2, "% des vaches en production du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ', tx, + "% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + } + } + } + } + + } + } + } else { + w <- subset(fem_tot, fem_tot$mere == z$anim[1]) + if (nrow(w) > 1){ + for (m in 1:nrow(w)){ + sPed <- subPed(Pedig, keep=w$anim[m], prevGen=0, succGen=10) + taille <- nrow(sPed) + + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100, 1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)){ + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n') + } + + if (nrow(sPed) > 1 & nbt > 0){ + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], + '_ssl_', w$anim[m], '.pdf', sep='') + pdf(file = paste(sousrep, "/", nom, sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? ? droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2,2,2,5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lign?e :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0, + paste('Sous-lignee : petite-fille', w$nobovi[m], str_sub(w$anim[m], -4), sep=' '), + srt=270, cex=0.6, col='dark red', font=1) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette sous-lignee representent ', + tx2, "% des vaches en production du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ', tx, + "% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + } + } + } + + } + } + }, + error = function(erreur) { + print("Erreur") + } + ) + } + } + + contenu <- as.data.frame(list.files(paste0(rep, "/", CHEP, '_pdf_ligneesF'))) + + if (nrow(contenu) > 0) { + staple_pdf(input_directory = sousrep, + input_files = NULL, + output_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''), + overwrite = TRUE) + + rotate_pdf(page_rotation = 270, + input_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''), + output_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''), + overwrite = TRUE) + } + + unlink(paste(rep, '/', CHEP, '_pdf_ligneesF', sep=''), recursive=TRUE) + + new=Sys.time()-old + print(paste('Trac? des lign?es femelles :',new,sep='')) + + + ### g?n?ration du rapport HTML ################################################ + + # a revoir pour les petits cheptels + render_report(CHEP, TECH, date_imp) + + render_synthese(CHEP, TECH, date_imp) + + # temps total + NEW <- Sys.time() - OLD + print(paste("Temps total d'execution :", NEW, sep='')) + } else { + print("inventaire vide") + } +} + + +################################################################################ +### saisie des cheptels ? sortir ############################################### +################################################################################ + +# CHEP <- 'FR63119077' # avec le FR +# TECH <- 'GADES' +# +# render_all_fic(CHEP, TECH) +# +# +# render_report(CHEP, TECH, date_imp) +# render_synthese(CHEP, TECH, date_imp) + + +################################################################################ +### requete sur les cheptels ? rechercher pr?vus en tourn?e #################### +################################################################################ + +# dept_tech <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/IMPORTS_R/dept_tech.csv", +# ";", escape_double = FALSE, locale = locale(encoding = "ISO-8859-1"), +# trim_ws = TRUE) +# +# +# itic <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcitic/finddatefieldbynamedquery/Hbcitic.findByPrevejo/" +# date_req <- Sys.Date() +# li_dates <- seq(as.Date(Sys.Date()), as.Date(Sys.Date()+21), by="days") +# +# itineraires <- fromJSON(paste(itic, "2021-06-11", sep=''))[0,] +# +# for (i in 1:length(li_dates)){ +# it <- fromJSON(paste(itic, li_dates[i], sep='')) +# itineraires <- bind_rows(itineraires, it) +# } +# +# li_erreurs <- c() +# for (i in 1:nrow(itineraires)) { +# CHEP <- paste('FR', substr(itineraires$nuchep[i],1,8) , sep='') +# if (itineraires$codoper[i] %in% c('ERLAM', 'STBIL', 'FRROB', 'JEAUC', 'GADES', 'ETJON', 'LOCDG', 'ANHUV')) { +# TECH <- itineraires$codoper[i] +# } else { +# li_tech <- subset(dept_tech, dept_tech$num == substr(itineraires$nuchep[i], 1, 2)) +# TECH <- li_tech$tech1[1] +# } +# cat(CHEP, TECH, '\n') +# if (dir.exists(path=paste(rep_exp, TECH, '/', CHEP, sep='')) == FALSE +# | file.exists(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), +# '/', CHEP, '_synthese_eCow5.html', sep = "")) == FALSE) { +# # tryCatch( +# # expr = { +# render_all_fic(CHEP, TECH) +# # }, +# # error = function(e) { +# # cat('ERREUR CALCUL', CHEP, '\n') +# # append(li_erreurs, CHEP) +# # }) +# #render_all_fic(CHEP, TECH) +# } +# } +# print(li_erreurs) + + +################################################################################ +### requete sur les cheptels d'une liste d?finie ############################### +################################################################################ +options(timeout = 1200) + +li_chep <- c( + "FR63118167" +) + +TECH <- 'VN2025' + +li_erreurs <- c() +for (i in 1:length(li_chep)) { + CHEP <- li_chep[i] + cat(CHEP, TECH, '\n') + if (dir.exists(path=paste(rep_exp, TECH, '/', CHEP, sep='')) == FALSE + | file.exists(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''), + '/', CHEP, '_synthese_eCow5.html', sep = "")) == FALSE) { + tryCatch( + expr = { + render_all_fic(CHEP, TECH) + }, + error = function(e) { + cat('ERREUR CALCUL', CHEP) + li_erreurs[[(length(li_erreurs) + 1)]] <- CHEP + }) + render_all_fic(CHEP, TECH) + } +} + + +adh_avril2024 <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/Bureau/adhhbc_20240429.csv", + delim = ";", escape_double = FALSE, trim_ws = TRUE) +adh_avril2024$export <- NA + +for (i in 1:nrow(adh_avril2024)){ + + CHEP <- adh_avril2024$CHEP[i] + TECH <- adh_avril2024$TECH[i] + cat(CHEP, TECH, '\n') + + tryCatch( + expr = { + render_all_fic(CHEP, TECH) + }, + error = function(e){ + cat('ERREUR CALCUL', CHEP, "\n") + adh_avril2024$export[i] <- "ERREUR" + } + ) + +} + + +################################################################################ +### requete ? partir d'un fichier de cheptels et techs ######################## +################################################################################ + +# +# li_spec <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/Bureau/pre_engagement_VN2023_14juin.csv", +# ";", escape_double = FALSE, trim_ws = TRUE) +# +# li_erreurs <- c() +# +# for (i in 1:nrow(li_spec)) { +# CHEP <- li_spec$cheptel[i] +# TECH <- li_spec$tech[i] +# cat(CHEP, TECH, '\n') +# tryCatch( +# expr = { +# render_all_fic(CHEP, TECH) +# }, +# error = function(e) { +# cat('ERREUR CALCUL', CHEP) +# li_erreurs[[(length(li_erreurs) + 1)]] <- CHEP +# }) +# #render_all_fic(CHEP, TECH) +# } + + +################################################################################ +### SCRIPT d'ARCHIVAGE des VIEUX FICHIERS/DOSSIERS ############################# +################################################################################ + + +# # contenu du dossier EXPORT +# li_doc_rep <- as.data.frame(list.files(path = rep_exp)) +# +# #contenu des dossiers TECH +# li_doc_sousrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[2,1], sep = ''))) +# #contenu des dossiers CHEPTEL +# li_doc_ssrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[2,1], '/', li_doc_sousrep[1,1], sep = ''))) +# +# auj <- Sys.time() +# +# nb_fic_supp <- 0 +# nb_fic_archive <- 0 +# +# for (i in 2:nrow(li_doc_rep)) { +# # contenu des dossiers TECH +# li_doc_sousrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[i,1], sep = ''))) +# for (j in 1:nrow(li_doc_sousrep)) { +# # contenu des dossiers CHEPTEL +# li_doc_ssrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''))) +# +# dc <- file.info(paste(rep_exp, li_doc_rep[i,1], '/',li_doc_sousrep[j,1], '/',li_doc_ssrep[1,1], sep = ''))$ctime +# #cat(dc, '\n') +# +# if (is.na(dc)) { # si dossier vide, on le supprime +# print('VIDE') +# print(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = '')) +# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''), recursive = TRUE) +# nb_fic_supp <- nb_fic_supp + 1 +# +# } else if (time_length(interval(dc, auj), "days") > 180) { # sinon on l'archive +# print('VIEUX') +# print(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = '')) +# nb_fic_archive <- nb_fic_archive + 1 +# +# # on supprime les fichiers html et pdf (car volumineux) +# if (file.exists(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_ArbreLigneesF_eCow5.pdf', sep = ''))) { +# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_ArbreLigneesF_eCow5.pdf', sep = ''), recursive = TRUE) +# } +# if (file.exists(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_rapport_eCow5.html', sep = ''))) { +# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_rapport_eCow5.html', sep = ''), recursive = TRUE) +# } +# if (file.exists(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_synthese_eCow5.html', sep = ''))) { +# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_synthese_eCow5.html', sep = ''), recursive = TRUE) +# } +# +# # on archive les fichiers csv en dehors du fichier export ------------------------------------- date à modifier !!!!!!!!!!!!!!! +# dir.create(paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/archives_EXPORTS_R/20231205/", li_doc_sousrep[j,1], sep='')) +# li_doc_ssrep2 <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''))) +# for (k in 1:nrow(li_doc_ssrep2)) { +# filesstrings::file.move(paste(rep_exp, li_doc_rep[i,1], '/',li_doc_sousrep[j,1], '/',li_doc_ssrep2[k,1], sep = ''), +# paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/archives_EXPORTS_R/20231205/", li_doc_sousrep[j,1], sep='')) +# } +# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''), recursive = TRUE) +# +# } +# } +# print(paste("NB fichiers supprimes : ", nb_fic_supp, sep='')) +# print(paste("NB fichiers archives : ", nb_fic_archive)) +# } + + +################################################################################ +### Fonction de recuperation des classements eCow pour la Vente Nationale 2022 ### +################################################################################ + + +li_vn <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/VN/VN2025_liste_meres.csv", delim = ";") + +li_vn$NOM_MERE = li_vn$AGE = li_vn$nb_VA_tot = li_vn$nb_VA_cla = li_vn$rg <- NA +# clsst = data.frame(matrix(NA, ncol = 6, nrow = 1)) +# colnames(clsst) = c('ANIM', 'NOBOVI', 'AGE', 'nb_VA_tot', 'nb_VA_cla', 'rg') + +for(i in 1:nrow(li_vn)){ + print(i) + CHEP = li_vn$CHEPDET[i] + #TECH = li_vn$TECH[i] + ANIM = li_vn$MERE[i] + ## si le fichier existe + pathVN = "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/EXPORTS_2/VN2025" #paste(rep_exp, TECH, '/', CHEP, sep='') + if (dir.exists(path = pathVN) == TRUE + & file.exists(paste(pathVN, '/', CHEP,'/', CHEP, '_classement_eCow5.csv', sep = "")) == TRUE) { + ## si il est assez recent : < 3 mois + if( file.info(paste(pathVN, '/', CHEP,'/', CHEP, '_classement_eCow5.csv', sep = ""))$ctime > "2022-03-27") { + # on va chercher les infos + recup <- read_delim( paste(pathVN, '/', CHEP, '/', CHEP, '_classement_eCow5.csv', sep = ""), + delim = ";", escape_double = FALSE, + locale = locale(decimal_mark = ","), + trim_ws = TRUE) + li_vn$nb_VA_tot[i] = nrow(recup) + x = subset(recup, recup$NUM_VACHE == ANIM) + cla = subset(recup, !is.na(recup$`rang CARRIERE`)) + if(nrow(x) > 0){ + li_vn$NOM_MERE[i] = x$NOM_VACHE[1] + li_vn$AGE[i] = x$`AGE (annees)`[1] + li_vn$rg[i] = x$`rang CARRIERE`[1] + li_vn$nb_VA_cla[i] = nrow(cla) + } else { + li_vn$rg[i] = 'abs' + } + } else { + print("else0") + ## sinon on le genere + # tryCatch( + # expr = { + # render_all_fic(CHEP, TECH) + # }, + # error = function(e) { + # cat('ERREUR CALCUL', CHEP, '\n') + # }) + # ## puis on va chercher le fichier + # recup <- read_delim( paste( paste(rep_exp, TECH, '/' ,CHEP, sep=''), + # '/', CHEP, '_classement_eCow5.csv', sep = ""), + # delim = ";", escape_double = FALSE, + # locale = locale(decimal_mark = ","), + # trim_ws = TRUE) + # li_vn$nb_VA_tot[i] = nrow(recup) + # x = subset(recup, recup$NUM_VACHE == ANIM) + # cla = subset(recup, !is.na(recup$`rang CARRIERE`)) + # if(nrow(x) > 0){ + # li_vn$NOBOVI[i] = x$NOM_VACHE[1] + # li_vn$AGE[i] = x$`AGE (annees)`[1] + # li_vn$rg[i] = x$`rang CARRIERE`[1] + # li_vn$nb_VA_cla[i] = nrow(cla) + # } else { + # li_vn$rg[i] = 'abs' + # } + } + + } else { + print("else1") + ## sinon on genere le fichier + # tryCatch( + # expr = { + # render_all_fic(CHEP, TECH) + # }, + # error = function(e) { + # cat('ERREUR CALCUL', CHEP, '\n') + # }) + # ## puis on va chercher le fichier + # recup <- read_delim( paste( paste(rep_exp, TECH, '/' ,CHEP, sep=''), + # '/', CHEP, '_classement_eCow5.csv', sep = ""), + # delim = ";", escape_double = FALSE, + # locale = locale(decimal_mark = ","), + # trim_ws = TRUE) + # li_vn$nb_VA_tot[i] = nrow(recup) + # x = subset(recup, recup$NUM_VACHE == ANIM) + # cla = subset(recup, !is.na(recup$`rang CARRIERE`)) + # if(nrow(x) > 0){ + # li_vn$NOBOVI[i] = x$NOM_VACHE[1] + # li_vn$AGE[i] = x$`AGE (annees)`[1] + # li_vn$rg[i] = x$`rang CARRIERE`[1] + # li_vn$nb_VA_cla[i] = nrow(cla) + # } else { + # li_vn$rg[i] = 'abs' + # } + } +} + +write.table(li_vn, + file = "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/VN/VN2025_eCow_MERES.csv", + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") diff --git a/R/project/old_ecow_individuel.R b/R/project/old_ecow_individuel.R new file mode 100755 index 0000000..dca316a --- /dev/null +++ b/R/project/old_ecow_individuel.R @@ -0,0 +1,3436 @@ + +# version temporaire eCow - 5eme calcul +# LJ - 14/04/2020 + +################################################################################ +### chgt des libraries ######################################################### +################################################################################ + +library(tidyverse) +library(lubridate) +library(jsonlite) + +library(optiSel) +library(staplr) +library(png) +library(grid) + +options(scipen = 999) #permet d'?crire les nombres en entier quand ils sont au format scientifique +# necessaire pour la convertion des dates au format unix + +options(timeout = 300) + +################################################################################ +### chgt des fichiers et donn?es utiles ######################################## +################################################################################ + +rep_exp <- "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/EXPORTS_2/" + +rep_imp <- "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/IMPORTS_R/" + +img <- readPNG("C:/Users/LJeannot/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/IMPORTS_R/HBC-Logo.png") + +date_imp <- as.Date("2025-06-18") #"2023-03-27" + +adhhbc <- read_delim(paste(rep_imp, "adhhbc_20250618.csv", sep=''), # ok 20230327 + ";", escape_double = FALSE, trim_ws = TRUE) + +czhbc <- read_csv(paste(rep_imp, "cz_20250618.csv", sep='')) # ok 20230327 + +LETTRES <- read_delim(paste(rep_imp, "LETTRES.csv", sep=''), + ";", escape_double = FALSE, trim_ws = TRUE) + +indite <- read_csv(paste(rep_imp, "indite_20250618.csv", sep=''), # ok 20230327 + col_types = cols(DANAIS = col_date(format = "%Y-%m-%d"))) +indite <- indite[-which(duplicated(indite$ANIM)),] +#$indite <- subset(indite, !is.na(indite$MEREIPG)) + +meresIPG <- read_csv(paste(rep_imp, "nbprodIPG_byMERE_20250618.csv", sep='')) # ok 20230327 +colnames(meresIPG) <- c('ANIM','NBPRODIPG') + +peresIPG <- read_csv(paste(rep_imp, "nbprodIPG_byPERE_20250618.csv", sep='')) # ok 20230327 +colnames(peresIPG) <- c('ANIM','NBPRODIPG') + +parentsIPG <- rbind(meresIPG, peresIPG) + +### liste des webservices ###################################################### + +# appel du listing d'un cheptel +webappli <- "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/findbyactivecheptel/" + +# appel de l'IC pour un animal +hbcanim <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/" + +# appel de hbcgene pour un animal +hbcgene <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcgene/" + +# liste des produits d'une vache +reqMere <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/findstringfieldbynamedquery/Hbcanim.findByMere/" + +# liste des produits d'un taureau +reqPere <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/findstringfieldbynamedquery/Hbcanim.findByPere/" + +# liste des produits d'un animal n?s dans un cheptel cible +reqProdNaiss <- "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/findProductByAnimAndChna/" +# ? completer par anim/chna, ex : FR7121831530/FR71499477 + +#_______________________________________________________________PONDERATIONS AHP +## Ponderations Carri?re #### +Pcar=data.frame(type='final', agevel1_n=3, ivv1_n=6, ivv2p_n=12, + ptgv_n=4, pad_n=2, prol_n=2, mort_n=12, + txrepros_n=8, nbpp_n=10, txm_n=1, txvf_n=10, + ptgp_n=6, pn_n=4, p120_n=10, p210_n=10) + +### Ponderations Campagne #### +Pcamp=rbind(data.frame(type='AHPtech', pn_n=5.3, txvf_n=14.9, txm_n=4.5, + ptgp_n=8.2, p120_n=15.1, p210_n=12.6, + prol_n=3.2, mort_n=19.9, ivv_n=16.2), + data.frame(type='final', pn_n=6, txvf_n=15, txm_n=1, + ptgp_n=9, p120_n=15, p210_n=15, + prol_n=3, mort_n=18, ivv_n=18)) +# pond?rations finales ajustees a partir de l'enquete +# peut etre pas judicieux + +################################################################################ +### fonctions utiles ########################################################### +################################################################################ + +# suppression des espaces superflus +trim_str = function (string) { + gsub("\\s+", " ", gsub("^\\s+|\\s+$", "", string)) +} + +# recuperation de l'inventaire des animaux actifs du cheptel +get_inventaire <- function(cheptel) { + old <- Sys.time() + # liste des animaux du cheptel + lichep <- fromJSON(paste(webappli, cheptel, sep='')) + inventaire <- lichep$hbcanim + # calcul du temps de chargement + new <- Sys.time()-old + cat("Chargement de l'inventaire :", round(new, 1) , "sec \n") + # resultat + return(inventaire) +} + +# mise en forme d'un retour de WS sous forme de dataframe +# necessaire quand l'appel ne concerne qu'un animal car le retour est une liste nomm?e +appel_infos <- function(animal, url_ws, cheptel = NA) { + animal <- trim_str(animal) + if (!is.na(cheptel)) { + li_anim <- try(fromJSON(paste(url_ws, animal, '/', cheptel, sep = '')), silent = TRUE) + } else { + li_anim <- try(fromJSON(paste(url_ws, animal, sep = '')), silent = TRUE) + } + if (inherits(li_anim, "try-error")) { + return(NA) + } else { + if (class(li_anim) == "list" & length(li_anim) > 0) { + li_anim[sapply(li_anim, function(x) length(x) == 0L)] <- NA + df_anim <- as.data.frame(t(unlist(li_anim))) + return(df_anim) + } else if (class(li_anim) == "data.frame") { + return(li_anim) + } + } +} + +# appel des donnees anim en fonction de leur existance +# si animal absent de hbcanim, on va voir dans hbcgene +chgt_infos <- function(animal) { + # on va chercher la ligne animal dans hbcanim + line_anim <- try(appel_infos(animal, hbcanim), silent = TRUE) + # Si erreur, on va chercher dans hbcgene + if (inherits(line_anim, "try-error") ) { # | is.na(line_anim) + line_anim <- appel_infos(animal, hbcgene) + } + return(line_anim) +} + +# fonction de cr?ation d'un dataframe vide +create_df <- function(nbl, liste_nomcol){ + new <- data.frame(matrix(NA, ncol=length(liste_nomcol), nrow=nbl)) + colnames(new) <- liste_nomcol + return(new) +} + +get_stats <- function(tab, nom_tab, col,conditions, nom_cond) { + if (missing(conditions) & missing(nom_cond)) { + x <- tab + nom_cond <- NA + } else { + x <- subset(tab, conditions) + } + min <- round(min(x[,col], na.rm=TRUE), 1) + q1 <- round(quantile(x[[col]], probs=0.25, na.rm=TRUE), 1) + med <- round(median(x[[col]], na.rm=TRUE), 1) + moy <- round(mean(x[[col]], na.rm=TRUE), 1) + q3 <- round(quantile(x[[col]], probs=0.75, na.rm=TRUE), 1) + max <- round(max(x[,col], na.rm=TRUE), 1) + nbval <- nrow(subset(x, is.na(x[,col]) == FALSE)) + nas <- nrow(subset(x, is.na(x[,col]) == TRUE)) + tab_col <- as.character(paste(nom_tab, col, sep='$')) + sc <- data.frame('var'=tab_col, 'cond'=nom_cond, 'min'=min, 'q1'=q1, + 'med'=med, 'moy'=moy, 'q3'=q3, 'max'=max, 'nbval'=nbval, 'nas'=nas) + rownames(sc) <- '' + return(sc) +} + +# fonction de recuperation des produits d'un taureau +# recup annul?e si taureau d'IA avec bcp de produits ie >275 +get_produits_taureau <- function(animal) { + old <- Sys.time() + anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ### + if (!is.na(anim) & (class(anim) == "try-error") == FALSE) { # _______________________________ + if (anim$sexbov[1] == '1') { + if (as.numeric(anim$nbdescendants[1]) >= 275 & anim$taureauia[1] == '1') { + produits <- NA + cat("\n", "Produits non charg?s car taureau d'IA avec production superieure a 275") + } else if ( (as.numeric(anim$nbdescendants[1]) > 0 + & anim$taureauia[1] == '0') | + (as.numeric(anim$nbdescendants[1]) < 275 + & anim$taureauia[1] == '1') ) { + produits <- try(appel_infos(animal, reqPere), silent=TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + cat("\n", "Produits non charg?s car non disponibles") + produits <- NA + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } else { + produits <- NA + cat("\n", "???") + } + } else { + produits <- NA + cat("\n", "L'animal n'est pas un male") + } + } else if ((class(anim) == "try-error") == TRUE) { # _________________________ + cat("\n", "P?re sans ligne individuelle dans HBCANIM") + produits <- try(appel_infos(animal, reqPere), silent = TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + produits <- NA + cat("\n", "Produits non charg?s car non disponibles") + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } + return(produits) +} + +# fonction de recuperation des produits d'une vache +get_produits_vache <- function(animal) { + old <- Sys.time() + anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ### + if ((class(anim) == "try-error") == FALSE) { # _______________________________ + if (anim$sexbov[1] == '2') { + produits <- try(appel_infos(animal, reqMere), silent=TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + cat("\n", "Produits non charg?s car non disponibles") + produits <- NA + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } else { + produits <- NA + cat("\n", "L'animal n'est pas une femelle") + } + } else if ((class(anim) == "try-error") == TRUE) { # _________________________ + produits <- try(appel_infos(animal, reqMere), silent = TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + produits <- NA + cat("\n", "Produits non charg?s car non disponibles") + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } + return(produits) +} + +# fonction de recuperation des produits d'un animal dans un cheptel naisseur +get_produits_in_chep <- function(animal, cheptel) { + old <- Sys.time() + anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ### + if ((class(anim) == "try-error") == FALSE) { # _______________________________ + produits <- try(appel_infos(animal, reqProdNaiss, cheptel), silent=TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + cat("\n", "Produits non charg?s car non disponibles") + produits <- NA + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } else if ((class(anim) == "try-error") == TRUE) { # _________________________ + produits <- try(appel_infos(animal, reqMere), silent = TRUE) ### + if ((class(produits) == "try-error") == TRUE){ + produits <- NA + cat("\n", "Produits non charg?s car non disponibles") + } else { + new <- Sys.time() - old + cat("\n", "Chargement des produits :", round(new, 1) , "sec") + } + } + return(produits) +} + +# fonction de modif des formats dates à partir du retour d'un WS +change_format_date_unix <- function(dataframe) { + if (is.data.frame(dataframe)){ + # recup des indices de colonnes de dates : commencent par 'da' ou 'DA' + li_ix_dates <- c(grep("^da", colnames(dataframe))) + if (length(li_ix_dates) == 0){ + li_ix_dates <- c(grep("^DA", colnames(dataframe))) + } + # si existance de colonnes de dates : + if (length(li_ix_dates) > 0) { + for(j in li_ix_dates) { + # on recupere les valeurs non nulles + not_na <- c(which(!is.na(dataframe[,j]))) + if(length(not_na) > 0) { + # on verifie que c'est bien un format UNIX + if ( dataframe[not_na[1],j] > 1*(10**8) & grepl("-", dataframe[not_na[1],j], fixed=FALSE) == FALSE) { + # puis on modifie le format + dataframe[,j] <- as.Date(as.POSIXct(dataframe[,j] / 1000, origin = "1970-01-01")) + } else { + #print("Dates pas au format UNIX") + } + } else { + #print("Aucune date non nulle dans cette colonne") + } + } + return(dataframe) + } else { + print("Pas de colonne commençant par 'da'/'DA'") + } + } else { + print("l'objet n'est pas un dataframe") + } +} + +### g?n?ration du rapport HTML ################################################ + +render_report = function(CHEP, TECH, date_imp) { + rmarkdown::render( + paste(substr(rep_exp, 1, nchar(rep_exp)-10), "eCow5_rapport_v3.Rmd", sep=''), params = list( + CHEP = CHEP, + TECH = TECH, + date_imp = date_imp + ), + output_file = paste(rep, '/', CHEP, '_rapport_eCow5.html', sep = "") + ) +} + +render_synthese = function(CHEP, TECH, date_imp) { + rmarkdown::render( + paste(substr(rep_exp, 1, nchar(rep_exp)-10), "eCow5_synthese.Rmd", sep=''), params = list( + CHEP = CHEP, + TECH = TECH, + date_imp = date_imp + ), + output_file = paste(rep, '/', CHEP, '_synthese_eCow5.html', sep = "") + ) +} + +# fonction de cr?ation du rapport pour la VN 2021 + +render_vn = function(CHEP, TECH) { + rmarkdown::render( + paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/ECOW/", "test_VN.Rmd", sep=''), params = list( + CHEP = CHEP, + TECH = TECH + ), + output_file = paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/ECOW/", CHEP, '_VN.html', sep = "") + ) +} + +################################################################################ +### choix du cheptel ########################################################### +################################################################################ + +# 03162009 # +# 08027008 # +# 08261022 # +# 35072060 # +# 36044803 # +# 42194151 # +# 58292027 # +# 63011058 +# 63428102 # +# 71340026 # +# 71368015 # + +## cheptels Inno'vente +# "FR03002076","FR03014061","FR03026005","FR03067051","FR03124009","FR03201108", +# "FR03257059","FR03320016","FR07287031","FR12033328","FR15013028","FR18017200", +# "FR18212029","FR21098031","FR37250300","FR55301004","FR58051043","FR58152118", +# "FR58152156","FR58249060","FR58249065","FR70441006","FR70526011","FR71178407", +# "FR71291008","FR71306010","FR71334035","FR71531193" + +CHEP <- 'FR72119112' # avec le FR +TECH <- 'LOCDG' +# creation du repertoire d'export +dir.create(path=paste(rep_exp, TECH, '/', CHEP, sep='')) +rep <- paste(rep_exp, TECH, '/' ,CHEP, sep='') + + +################################################################################ +### calcul du classement vaches ################################################ +################################################################################ + +OLD <- Sys.time() +## r?cup des animaux de l'inventaire +old <- Sys.time() + +inventaire <- get_inventaire(CHEP) + +# modif du 28/03/2023 : ajout de la verif chepdet = CHEP pour filtrer les pensions +inventaire <- inventaire %>% filter(trim_str(chepdet) == CHEP) + +# if ( inventaire$danais[1] > 1*(10**8) ) { +# inventaire$danais <- as.Date(as.POSIXct(inventaire$danais / 1000, origin="1970-01-01")) +# } + +tryCatch( + { + inventaire <- change_format_date_unix(inventaire) + } +) + +inventaire$danais <- as.Date(inventaire$danais, format = "%Y-%m-%d") +inventaire$mere <- trim_str(inventaire$mere) +inventaire$pere <- trim_str(inventaire$pere) +inventaire$anim <- trim_str(inventaire$anim) + +inventaire$ds <- as.numeric(inventaire$ds) +inventaire$af <- as.numeric(inventaire$af) +inventaire$dmC <- as.numeric(inventaire$dmC) + +# vaches actives +vaches <- subset(inventaire, + inventaire$sexbov == 2 & inventaire$nbdescendants > 0) + +# recherche des meres dans les porteuses pour aller chercher +# les produits s'ils existent dans HBCANIM + +porteuses <- subset(indite, !is.na(indite$MEREIPG) + & indite$MEREIPG %in% trim_str(vaches$anim)) +donneuses <- subset(indite, !is.na(indite$MERECPB) + & indite$MERECPB %in% trim_str(vaches$anim)) +# l'indicateur de donneuse d'embryon est renseign? apres dans --> vaches$ACINAC + +vaches$age_days <- time_length(interval(vaches$danais, Sys.Date()), unit="days") +vaches$age_years <- round(vaches$age_days / 365, 1) +vaches$acinac <- NA + +# liste de tous leurs produits +produits <- vaches[0,] + +if (nrow(vaches) > 0 ) { + for (i in 1:nrow(vaches)){ + # r?cup des produits dans HBCANIM + temp <- try(fromJSON(paste(reqMere, trim_str(vaches$anim[i]), sep='')), silent = TRUE) + if (inherits(temp, "try-error")) { + temp <- vaches[0,] + } else { + #temp <- fromJSON(paste(reqMere, trim_str(vaches$anim[i]), sep='')) # a voir : gerer les retours vides !!!! + produits <- rbind(produits, temp) + # on annote les donneuses + if( is.data.frame(subset(temp, temp$indite == 'O')) ) { + if (nrow(subset(temp, temp$indite == 'O')) > 0){ + vaches$acinac[i] <- 'DONNEUSE' + } + } + # ajout d'un nom ? la vache si null + if (is.na(vaches$nobovi[i])) { + lettre <- subset(LETTRES, LETTRES$ANNEE == vaches$campn[i]) + vaches$nobovi[i] <- paste(lettre$LETTRE[1], vaches$nutrav[i], sep='_') + } + } + } +} else { + print("AUCUNE VACHE ACTIVE DANS LE CHEPTEL") +} + + +# les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant +if (nrow(porteuses) > 0) { + for (i in 1:nrow(porteuses)) { + if (!(porteuses$ANIM[i] %in% trim_str(produits$anim))) { + + temp <- appel_infos(porteuses$ANIM[i], hbcanim) + li_mere <- subset(vaches, vaches$anim == porteuses$MEREIPG[i]) + + if ( is.data.frame(temp) && nrow(temp) > 0) { + temp$mere[1] <- porteuses$MEREIPG[i] + temp[1, c(60:67, 86:103)] <- NA + if ( nrow(li_mere) > 0){ + temp$danaismere[1] <- as.character(li_mere$danais[1]) + } + temp$indite[1] <- 'O_corr' + + produits <- rbind(produits, temp) + } + } + } +} + +# modifs des types de donn?es, pour calcul par la suite +produits$danais <- as.Date(produits$danais, format = "%Y-%m-%d") +produits$dasort <- as.Date(produits$dasort, format = "%Y-%m-%d") + +produits$mere <- trim_str(produits$mere) +produits$pere <- trim_str(produits$pere) +produits$anim <- trim_str(produits$anim) + +produits$ravelamere <- as.numeric(produits$ravelamere) +produits$ivv <- as.numeric(produits$ivv) +produits$campn <- as.numeric(produits$campn) + +produits$ponais <- as.numeric(produits$ponais) +produits$pat04m <- as.numeric(produits$pat04m) +produits$pat07m <- as.numeric(produits$pat07m) + +produits$devsqe <- as.numeric(produits$devsqe) +produits$devmus <- as.numeric(produits$devmus) +produits$aptfon <- as.numeric(produits$aptfon) + +# on ne garde que les TE port?s par une vache active du cheptel +PROD <- subset(produits, produits$indite != 'O') + +# ajout des produits IPG +PROD <- merge(PROD, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + +PROD <- PROD[order(PROD$danais, decreasing = F),] +PROD <- PROD[order(PROD$mere, decreasing = T),] + +# correction des ravelamere des TE si possible +for (i in 1:nrow(PROD)) { + if (is.na(PROD$ravelamere[i])) { + if (!is.na(PROD$ravelamere[i+1]) & PROD$ravelamere[i+1] %in% c(1, 2)) { + PROD$ravelamere[i] <- 1 + PROD$typemere[i] <- 'G' + } else if (!is.na(PROD$ravelamere[i+1]) & PROD$ravelamere[i+1] > 1) { + PROD$ravelamere[i] <- PROD$ravelamere[i+1] - 1 + PROD$typemere[i] <- 'V' + } + } +} + +# age au velage de la mere +PROD$agevel <- round(time_length(interval(PROD$danaismere, PROD$danais), + unit="months"), 1) + +# IVV : utilisation de la colonne deja presente de HBCANIM + +for (i in 1:nrow(PROD)) { + if (PROD$indite[i] == 'O_corr') { + PROD$nobovi[i] <- paste('#', PROD$nobovi[i], sep='') + } + # repro + if (PROD$anim[i] %in% czhbc$ANIM + | (!is.na(PROD$NBPRODIPG[i]) & PROD$NBPRODIPG[i] > 0) + | (!is.na(PROD$nbdescendants[i]) & as.numeric(PROD$nbdescendants[i]) > 0)) { + PROD$repro[i] <- 'O' + } else { + PROD$repro[i] <- NA + PROD$nobovi[i] <- PROD$nobovi[i] %>% str_to_lower() + } + # mortalite + if (!is.na(PROD$dasort[i]) & !is.na(PROD$casort[i]) & PROD$casort[i] == 'M' + & time_length(interval(PROD$danais[i], PROD$dasort[i]), unit="days") < 211){ + PROD$mortsev[i] <- 'O' + PROD$nobovi[i]=paste(PROD$nobovi[i], ' (MavS)', sep='') + } else { + PROD$mortsev[i] <- NA + } + # IVV + if (i > 1) { + # cas normaux + if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1]) + & PROD$ravelamere[i] != 1 + & PROD$ravelamere[i] == PROD$ravelamere[i-1] + 1 + #& !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] != '2' + & !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) { + PROD$ivv[i] <- time_length(interval(PROD$danais[i-1], PROD$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1]) + & PROD$ravelamere[i] != 1 + & PROD$ravelamere[i] == PROD$ravelamere[i-1] + & !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] == '2' + & !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) { + PROD$ivv[i] <- PROD$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1]) + & PROD$ravelamere[i] != 1 + & !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] != '2' + & !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) { + PROD$ivv[i] <- round(time_length(interval(PROD$danais[i-1], + PROD$danais[i]), + unit="days") + / (PROD$ravelamere[i] - PROD$ravelamere[i-1]), 0) + } else { + PROD$ivv[i] <- NA + } + } +} + +# calcul des effets du cheptel : rang de velage et sexe du veau +effet <- PROD %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) +effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] +effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p120[1] +effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p210[1] + +# calcul des effets du cheptel : sexe sur la repro +effetsexe <- PROD %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) +rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + +# report des effets sur les produits + +for (i in 1:nrow(PROD)) { + if (PROD$sexbov[i] == '2') { #_______________________________________ FEMELLES + PROD$nbpp_corr[i] <- PROD$NBPRODIPG[i] * rapport_MF + if (!is.na(PROD$typemere[i]) & PROD$typemere[i] == 'G') { #_________genisses + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } else { #________________________________________________ vaches ou inconnu + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PROD$nbpp_corr[i] <- PROD$NBPRODIPG[i] + if (!is.na(PROD$typemere[i]) & PROD$typemere[i] == 'G') { #____________________________________genisses + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } else { #________________________________________________ vaches ou inconnu + if (!is.na(PROD$ponais[i])) { + PROD$pn_corr[i] <- (PROD$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PROD$pn_corr[i] <- NA + } + if (!is.na(PROD$pat04m[i])) { + PROD$p120_corr[i] <- (PROD$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PROD$p120_corr[i] <- NA + } + if (!is.na(PROD$pat07m[i])) { + PROD$p210_corr[i] <- (PROD$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PROD$p210_corr[i] <- NA + } + } + } +} + +# calcul des donn?es ?labor?es par vache active + +for (i in 1:nrow(vaches)) { + # _______________________________________________rappel des produits par vache + veaux <- PROD %>% filter(mere == vaches$anim[i]) + + # ___________________________________________calcul des infos utiles par vache + + # calcul du poids adulte estim? et synthese pointage vache ___________________ + if (!is.na(vaches$dmC[i])) { + vaches$ptgV[i] <- round(0.6 * vaches$dmC[i] + 0.15 * vaches$ds[i] + + 0.25 * vaches$af[i], 1) + } else { + vaches$ptgV[i] <- NA + } + + if (nrow(veaux) > 3){ + vaches$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2) + alpha <- 1.62 - 0.01 * vaches$precocite[i] + } else { + vaches$precocite[i] <- NA + alpha <- 1.62 + } + if (!is.na(vaches$pat24m[i])) { + vaches$pad[i] <- round((vaches$pat24m[i] - 50 * exp(-720 * alpha * 10**(-3))) + / (1 - exp(-720 * alpha * 10**(-3))), 1) + } else if (!is.na(vaches$pat18m[i])) { + vaches$pad[i] <- round((vaches$pat18m[i] - 50 * exp(-540 * alpha * 10**(-3))) + / (1 - exp(-540 * alpha * 10**(-3))), 1) + } else if (!is.na(vaches$pat12m[i])) { + vaches$pad[i] <- round((vaches$pat12m[i] - 50 * exp(-360 * alpha * 10**(-3))) + / (1-exp(-360 * alpha * 10**(-3))), 1) + } else { + vaches$pad[i] <- NA + } + + # calcul des perfs de repro et du temps productif ____________________________ + + vaches$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1) + + if (1 %in% veaux$ravelamere) { + vaches$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1] + } else { + vaches$agevel1[i] <- NA + } + + if (2 %in% veaux$ravelamere) { + vaches$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1] + } else { + vaches$ivv1[i] <- NA + } + if (3 %in% veaux$ravelamere) { + vaches$ivv2p[i] <- round(mean(subset(veaux, + veaux$ravelamere > 2)$ivv, na.rm=T), 1) + } + + if (is.na(vaches$ivv1[i]) | (!is.na(vaches$ivv1[i]) & vaches$ivv1[i] < 390) ){ + e2 <- 0 + } else if (!is.na(vaches$ivv1[i]) & vaches$ivv1[i] >= 390) { + e2 <- vaches$ivv1[i] - 390 + } + if (is.na(vaches$ivv2p[i]) | (!is.na(vaches$ivv2p[i]) & vaches$ivv2p[i] < 365) ){ + e3 <- 0 + } else if (!is.na(vaches$ivv2p[i]) & vaches$ivv2p[i] >= 365) { + e3 <- vaches$ivv1[i] - 365 + } + if (time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") - 365 + } + + vaches$tempsprod[i] <- round( (vaches$age_days[i] + - ( vaches$agevel1[i] * 30.4 + + e2 + + e3 * (vaches$nbcampvel[i] - 2) + + e4 + )) / vaches$age_days[i] * 100, 1) + + # calcul des donn?es synth?tiques sur les produits ___________________________ + + vaches$prol[i] <- round(nrow(veaux) / (vaches$nbcampvel[i]) * 100, 1) + vaches$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O')) + / nrow(veaux)* 100, 1) + vaches$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O')) + / nrow(veaux)* 100, 1) + vaches$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T) + vaches$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T) + vaches$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux)* 100, 1) + vaches$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') )) + / nrow(veaux)* 100, 1) + vaches$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE) + + 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1) + vaches$pn_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$ponais, na.rm=T), 1) + vaches$p120_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat04m, na.rm=T), 1) + vaches$p210_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat07m, na.rm=T), 1) + vaches$pn_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$ponais, na.rm=T), 1) + vaches$p120_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat04m, na.rm=T), 1) + vaches$p210_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat07m, na.rm=T), 1) + vaches$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1) + vaches$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1) + vaches$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1) + + ### convertion des NaN en NA + L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr', + 'p210_m','p210_f','p210_corr') + for (j in L){ + if (is.nan(vaches[i,j]) == TRUE){ + vaches[i,j] <- NA + } + } +} + +# calcul des stats, valeurs extremes et references pour la normalisation + +stats_chep <- create_df(0,c('var', 'cond', 'min', 'q1', 'med', + 'moy', 'q3', 'max', 'nbval', 'nas')) + +stats_chep <- rbind(stats_chep, + get_stats(vaches, "vaches", "indisu"), + get_stats(vaches, "vaches", "agevel1"), + get_stats(vaches, "vaches", "ivv1"), + get_stats(vaches, "vaches", "ivv2p"), + get_stats(vaches, "vaches", "prol"), + get_stats(vaches, "vaches", "mort"), + get_stats(vaches, "vaches", "txrepros"), + get_stats(vaches, "vaches", "nbpp_corr"), + get_stats(vaches, "vaches", "txvf"), + get_stats(vaches, "vaches", "txmales"), + get_stats(vaches, "vaches", "ptgP"), + get_stats(vaches, "vaches", "pn_corr"), + get_stats(vaches, "vaches", "p120_corr"), + get_stats(vaches, "vaches", "p210_corr"), + get_stats(vaches, "vaches", "pad"), + get_stats(vaches, "vaches", "ptgV"), + get_stats(vaches, "vaches", "age_years"), + get_stats(vaches, "vaches", "tempsprod"), + get_stats(vaches, "vaches", "pn_m"), + get_stats(vaches, "vaches", "pn_f"), + get_stats(vaches, "vaches", "p120_m"), + get_stats(vaches, "vaches", "p120_f"), + get_stats(vaches, "vaches", "p210_m"), + get_stats(vaches, "vaches", "p210_f"), + get_stats(vaches, "vaches", "nbpp")) + +#_______________________________calcul des valeurs normalis?es par vache + +for (i in 1:nrow(vaches)) { + # ____________________________________________ perfs individuelles normalis?es + if (!is.na(vaches$agevel1[i])){ + if (vaches$agevel1[i] > 48) { + vaches$agevel1_n[i] <- 0 + } else if (vaches$agevel1[i] <= 48) { + vaches$agevel1_n[i] <- round(-2 * (10**-6) + * (vaches$agevel1[i] * 30.4) ** 2 + + 0.0027 * (vaches$agevel1[i] * 30.4) + + 8 * (10 ** -15), 3) + + } else { + vaches$agevel1_n[i] <- NA + } + } else { + vaches$agevel1_n[i] <- NA + } + + if (is.na(vaches$ivv1[i])) { + vaches$ivv1_n[i] <- NA + } else if (vaches$ivv1[i] > 460) { + vaches$ivv1_n[i] <- 0 + } else if (vaches$ivv1[i] < 390) { + vaches$ivv1_n[i] <- 1 + } else { + vaches$ivv1_n[i] <- round(1 - abs(390 - vaches$ivv1[i]) / abs(390 - 460), 3) + } + + if (is.na(vaches$ivv2p[i]) | is.nan(vaches$ivv2p[i])) { + vaches$ivv2p_n[i] <- NA + } else if (vaches$ivv2p[i] > 435) { + vaches$ivv2p_n[i] <- 0 + } else if (vaches$ivv2p[i] < 365) { + vaches$ivv2p_n[i] <- 1 + } else { + vaches$ivv2p_n[i] <- round(1 - abs(365 - vaches$ivv2p[i]) / abs(365 - 435), 3) + } + + if (is.na(vaches$pad[i])) { + vaches$pad_n[i] <- NA + } else { + vaches$pad_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$pad')[,'max'] + - vaches$pad[i]) + / abs(subset(stats_chep, var == 'vaches$pad')[,'max'] + - subset(stats_chep, var == 'vaches$pad')[,'min'])), 3) + } + + if (is.na(vaches$ptgV[i])) { + vaches$ptgv_n[i] <- NA + } else { + vaches$ptgv_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$ptgV')[,'max'] + - vaches$ptgV[i]) + / abs(subset(stats_chep, var == 'vaches$ptgV')[,'max'] + - subset(stats_chep, var == 'vaches$ptgV')[,'min'])), 3) + } + + if (vaches$prol[i] >= 100) { + vaches$prol_n[i] <- 1 + } else if (vaches$prol[i] < 50){ + vaches$prol_n[i] <- 0 + } else { + vaches$prol_n[i] <- round(1 - (abs(100 - vaches$prol[i]) / abs(100 - 50)), 3) + } + + if (is.na(vaches$pn_corr[i])) { + vaches$pn_n[i] <- NA + } else if (40 < vaches$pn_corr[i] & vaches$pn_corr[i] < 50) { + vaches$pn_n[i] <- 1 + } else if (22 > vaches$pn_corr[i] | vaches$pn_corr[i] > 68) { + vaches$pn_n[i] <- 0 + } else if (22 < vaches$pn_corr[i] & vaches$pn_corr[i] < 40) { + vaches$pn_n[i] <- round(0.056 * (vaches$pn_corr[i] - 22), 3) + } else { + vaches$pn_n[i] <- round(1 - 0.056 * (vaches$pn_corr[i] - 50), 3) + } + + vaches$txvf_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txvf')[,'max'] + - vaches$txvf[i]) / + abs(subset(stats_chep, var == 'vaches$txvf')[,'max'] + - subset(stats_chep, var == 'vaches$txvf')[,'min'])), 3) + vaches$txm_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txmales')[,'max'] + - vaches$txmales[i]) + / abs(subset(stats_chep, var == 'vaches$txmales')[,'max'] + - subset(stats_chep, var == 'vaches$txmales')[,'min'])), 3) + vaches$mort_n[i] <- round(1.0 * exp(-0.031 * vaches$mort[i]), 3) + vaches$txrepros_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txrepros')[,'max'] + - vaches$txrepros[i]) + / abs(subset(stats_chep, var == 'vaches$txrepros')[,'max'] + - subset(stats_chep, var == 'vaches$txrepros')[,'min'])), 3) + vaches$nbpp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$nbpp_corr')[,'max'] + - vaches$nbpp_c[i]) + / abs(subset(stats_chep, var == 'vaches$nbpp_corr')[,'max'] + - subset(stats_chep, var == 'vaches$nbpp_corr')[,'min'])), 3) + vaches$ptgp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$ptgP')[,'max'] + - vaches$ptgP[i]) + / abs(subset(stats_chep, var == 'vaches$ptgP')[,'max'] + - subset(stats_chep, var == 'vaches$ptgP')[,'min'])), 3) + vaches$p120_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$p120_corr')[,'max'] + - vaches$p120_c[i]) + / abs(subset(stats_chep, var == 'vaches$p120_corr')[,'max'] + - subset(stats_chep, var == 'vaches$p120_corr')[,'min'])), 3) + vaches$p210_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$p210_corr')[,'max'] + - vaches$p210_c[i]) + / abs(subset(stats_chep, var == 'vaches$p210_corr')[,'max'] + - subset(stats_chep, var == 'vaches$p210_corr')[,'min'])), 3) + # __________________________________________________ calcul des notes carriere + somme <- 0 + pond <- sum(Pcar[,c(2:16)]) + for (j in c(190:204)){ # attention a la correspondance des numeros de colonnes !!! + # modif du 29/04/2024 : passage de 189:203 à 190:204 + if (is.na(vaches[i,j])){ + valperf <- 0 + #mt_col <- mt_col + 1 # nb de colonnes sans valeur + pond <- pond - Pcar[1, (j - 189 + 1)] + } else { + valperf <- vaches[i, j] * Pcar[1, (j - 189 + 1)] # critere normalise X ponderation + } + somme <- somme + valperf # somme sur une ligne + } + SOMME_tot <- somme / pond * 10 # rapport en prenant que les criteres ayant une valeur + if (is.na(vaches$ptgp_n[i]) & is.na(vaches$p120_n[i]) & is.na(vaches$p210_n[i])){ + vaches$ecowcarr[i] <- NA + } else { + vaches$ecowcarr[i] <- round(SOMME_tot * 100, 0) + } +} +vaches$rg_carr <- rank(1 / vaches$ecowcarr, na.last="keep") + + +##################################################### calcul des notes campagnes + +campagnes <- PROD %>% distinct(mere, campn, ravelamere) + +for (i in 1:nrow(campagnes)){ + #y <- subset(VA,VA$ANIM==C$mereref[i]) # ligne de la mere dans VA + veaux <- subset(PROD, PROD$campn == campagnes$campn[i] + & PROD$mere == campagnes$mere[i]) # ligne(s) du ou des veaux dans PR + + campagnes$pn_c[i] <- round(mean(veaux$pn_corr, na.rm=TRUE), 1) + campagnes$txvf[i] <- round(nrow(subset(veaux, + veaux$conais %in% c('1','2'))) + / nrow(veaux) * 100, 1) + campagnes$txm[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux) * 100, 1) + campagnes$ptgp[i] <- round(mean((0.75 * veaux$devmus + + 0.25 * veaux$devsqe), na.rm=TRUE) ,1) + campagnes$p120_c[i] <- round(mean(veaux$p120_corr, na.rm=TRUE), 1) + campagnes$p210_c[i] <- round(mean(veaux$p210_corr, na.rm=TRUE), 1) + campagnes$prol[i] <- nrow(veaux) * 100 + campagnes$ivv[i] <- veaux$ivv[1] + campagnes$mort[i] <- round(nrow(subset(veaux,veaux$mortsev == 'O')) + / nrow(veaux) * 100, 1) + + L <- c('ptgp','pn_c','p120_c','p210_c') + for (j in L){ + if (is.nan(campagnes[i,j])){ + campagnes[i,j] <- NA + } + } + + if (nrow(veaux) == 1){ + nv <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + } else if (nrow(veaux) == 2){ + nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_') + nv <- paste(nv1, nv2, sep=', ') + } else if (nrow(veaux) == 3){ + nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_') + nv3 <- paste(str_sub(veaux$anim[3], -4), trim_str(veaux$nobovi[3]), sep='_') + nv <- paste(nv1, nv2, nv3, sep=', ') + } else if (nrow(veaux) == 4){ + nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_') + nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_') + nv3 <- paste(str_sub(veaux$anim[3], -4), trim_str(veaux$nobovi[3]), sep='_') + nv4 <- paste(str_sub(veaux$anim[4], -4), trim_str(veaux$nobovi[4]), sep='_') + nv <- paste(nv1, nv2, nv3, nv4, sep=', ') + } + if(is.na(veaux$nompere[1])){ + if (is.na(veaux$pere[1])){ + pere <- '' + } else { + pere <- str_sub(trim_str(veaux$pere[1]), -4) + } + } else { + pere <- trim_str(veaux$nompere[1]) + } + campagnes$noms[i] <- paste(nv, pere, sep=' / ') +} + +stats_chep <- rbind(stats_chep, + get_stats(campagnes,'campagnes','ivv'), + get_stats(campagnes,'campagnes','prol'), + get_stats(campagnes,'campagnes','mort'), + get_stats(campagnes,'campagnes','txvf'), + get_stats(campagnes,'campagnes','txm'), + get_stats(campagnes,'campagnes','ptgp'), + get_stats(campagnes,'campagnes','pn_c'), + get_stats(campagnes,'campagnes','p120_c'), + get_stats(campagnes,'campagnes','p210_c')) + +for (i in 1:nrow(campagnes)){ + # _____________________________________ calcul des perfs campagnes normalis?es + #pn + if (is.na(campagnes$pn_c[i])) { + campagnes$pn_n[i] <- NA + } else if (campagnes$pn_c[i] >= 40 & campagnes$pn_c[i] <= 50) { + campagnes$pn_n[i] <- 1 + } else if (22 >= campagnes$pn_c[i] | campagnes$pn_c[i] >= 68) { + campagnes$pn_n[i] <- 0 + } else if (22 < campagnes$pn_c[i] & campagnes$pn_c[i] < 40) { + campagnes$pn_n[i] <- round(0.056 * (campagnes$pn_c[i] - 22), 3) + } else { + campagnes$pn_n[i] <- round(1 - 0.056 * (campagnes$pn_c[i] - 50), 3) + } + + campagnes$txvf_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$txvf')[,'max'] + - campagnes$txvf[i]) + / abs(subset(stats_chep, var == 'campagnes$txvf')[,'max'] + - subset(stats_chep, var == 'campagnes$txvf')[,'min'])), 3) + campagnes$txm_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$txm')[,'max'] + - campagnes$txm[i]) + / abs(subset(stats_chep, var == 'campagnes$txm')[,'max'] + - subset(stats_chep, var == 'campagnes$txm')[,'min'])), 3) + campagnes$ptgp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$ptgp')[,'max'] + - campagnes$ptgp[i]) + / abs(subset(stats_chep, var == 'campagnes$ptgp')[,'max'] + - subset(stats_chep, var == 'campagnes$ptgp')[,'min'])), 3) + campagnes$p120_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$p120_c')[,'max'] + - campagnes$p120_c[i]) + / abs(subset(stats_chep, var == 'campagnes$p120_c')[,'max'] + - subset(stats_chep, var == 'campagnes$p120_c')[,'min'])), 3) + campagnes$p210_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$p210_c')[,'max'] + - campagnes$p210_c[i]) + / abs(subset(stats_chep, var == 'campagnes$p210_c')[,'max'] + - subset(stats_chep, var == 'campagnes$p210_c')[,'min'])), 3) + + #prol + if (is.na(campagnes$prol[i])) { + campagnes$prol_n[i] <- NA + } else if (campagnes$prol[i] == 100) { + campagnes$prol_n[i] <- 0.8 + } else { + campagnes$prol_n[i] <- 1 + } + + campagnes$mort_n[i] <- round(1.0 * exp(-0.031 * campagnes$mort[i]), 3) + + #ivv + if (is.na(campagnes$ravelamere[i]) | campagnes$ravelamere[i] == 1 + | is.na(campagnes$ivv[i])) { + campagnes$ivv_n[i] <- NA + } else if (campagnes$ravelamere[i] == 2) { + if (!is.na(campagnes$ivv[i])){ + if (campagnes$ivv[i] > 460) { + campagnes$ivv_n[i] <- 0 + } else if (campagnes$ivv[i] < 390) { + campagnes$ivv_n[i] <- 1 + } else { + campagnes$ivv_n[i] <- round(1 - abs(390 - campagnes$ivv[i]) / abs(390 - 460), 3) + } + } + } else { + if (!is.na(campagnes$ivv[i])) { + if (campagnes$ivv[i] > 435) { + campagnes$ivv_n[i] <- 0 + } else if (campagnes$ivv[i] < 365) { + campagnes$ivv_n[i] <- 1 + } else { + campagnes$ivv_n[i] <- round(1 - abs(365 - campagnes$ivv[i]) / abs(365 - 435), 3) + } + } + } + + # _________________________________________________ calcul des notes campagnes + somme <- 0 + pond <- sum(Pcamp[2,c(2:10)]) + for (j in c(14:22)){ # attention a la correspondance des num?ros de colonnes !!! + if (is.na(campagnes[i,j])){ + valperf <- 0 + #mt_col <- mt_col + 1 # nb de colonnes sans valeur + pond <- pond - Pcamp[1, (j - 13 + 1)] + } else { + valperf <- campagnes[i, j] * Pcamp[1, (j - 13 + 1)] # critere normalise X ponderation + } + somme <- somme + valperf # somme sur une ligne + } + SOMME_tot <- somme / pond * 10 # rapport en prenant que les criteres ayant une valeur + if (is.na(campagnes$ptgp_n[i]) & is.na(campagnes$p120_n[i]) & is.na(campagnes$p210_n[i])){ + campagnes$ecowcamp[i] <- round(SOMME_tot, 1) + } else { + campagnes$ecowcamp[i] <- round(SOMME_tot * 10, 0) + } + +} + +# remplissage de la table vaches avec les notes campagnes + +for (i in 1:nrow(vaches)){ + # moyenne notes campagnes + subcamp <- subset(campagnes, campagnes$mere == vaches$anim[i] + & campagnes$ecowcamp > 10) + if (nrow(subcamp)>0){ + vaches$moyecowcamp[i] <- round(mean(subcamp$ecowcamp, na.rm=TRUE), 1) + } else { + vaches$moyecowcamp[i] <- NA + } + # vaches non class?es en minuscules + if (is.na(vaches$ecowcarr[i])) { + vaches$nobovi[i] <- vaches$nobovi[i] %>% str_to_lower() + } + # donneuses soulignees par un # + embr <- subset(PROD, PROD$mere == vaches$anim[i] & PROD$indite == 'O') + if (nrow(embr) > 0) { + vaches$nobovi[i] <- paste('#', vaches$nobovi[i], sep=' ') + } +} +vaches$rg_camp <- rank(1 / vaches$moyecowcamp, na.last='keep') + +# creation du tableau CAMPAGNES + +nbcol <- max(campagnes$ravelamere, na.rm = TRUE) # nombre de colonnes de rangs de v?lage ? cr?er +CAMP <- cbind('anim'=vaches$anim, create_df(nrow(vaches), c(1:nbcol))) +for (i in 1:nrow(CAMP)){ + subcamp <- subset(campagnes, campagnes$mere == CAMP$anim[i]) + for (j in 2:ncol(CAMP)){ + veaux <- subset(subcamp, subcamp$ravelamere == j-1) + if (nrow(veaux) > 0) { + CAMP[i,j] <- paste(veaux$noms[1], veaux$ecowcamp[1], sep=' : ') + } + } +} + +vaches <- merge(vaches, CAMP, by.x='anim', by.y='anim', all.x=T, all.y=T) + + +# selection des colonnes d'interet pour la table finale +tabfinal <- merge(vaches[,c('chepdet', 'anim', 'nobovi', 'nompere', 'indisu', + 'tempsprod', 'age_years', 'ecowcarr', 'rg_carr', + 'ptgV', 'agevel1', 'ivv1', 'ivv2p', + 'prol', 'mort', 'txrepros', 'nbpp', + 'txvf', 'pn_m', 'pn_f', + 'p120_m', 'p120_f', 'p210_m', 'p210_f', + 'ptgP', + 'moyecowcamp', 'rg_camp')], + CAMP, by.x='anim', by.y='anim', all.x=T, all.y=T) + +tabfinal <- tabfinal[order(tabfinal$rg_carr),] +tabfinal <- tabfinal %>% select(chepdet, everything()) + +colnames(tabfinal)=c("CHEPTEL", "NUM_VACHE", "NOM_VACHE", "PERE", "ISU", + "% VIE PRODUCTIVE", "AGE (annees)", + "note eCow CARRIERE (/1000)", "rang CARRIERE", + "pointage VACHE *m", "age 1er velage (m)", "IVV1 (j)", + "IVV2+ (j)", "prolificite (%)", "mortalite av.sevr (%)", + "% produits repros", "nb petits-produits", + "% velages tranquilles", "PN males (kg)", + "PN femelles (kg)", "P120 males (kg)", "P120 femelles (kg)", + "P210 males (kg)","P210 femelles (kg)", + "pointage PRODUITS *m", "Moyenne notes eCow CAMPAGNE (/100)", + "rang CAMPAGNE", c(1:nbcol)) + +write.table(tabfinal, + file = paste(rep, '/', CHEP, '_classement_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + +new <- Sys.time() - old +print(paste('Calcul du classement éCow :', new, sep = '')) + + + +# a revoir pour les petits cheptels +#render_vn(CHEP, TECH) + +################################################################################ +### calcul du resume cheptel ################################################### +################################################################################ + +# lecture du fichier des stats des adherents +detail_stats_chep <- read_delim(paste(rep_exp, "detail_stats_chep.csv", sep=''), + ";", escape_double = FALSE, + locale = locale(decimal_mark = ",", + grouping_mark = ""), trim_ws = TRUE) +#detail_stats_chep$date_calc <- '2020-09-06' +# perfs dont l'unit? de calcul est la vache : ie toutes les vaches actives +# isu, age, temps prod, ptg adulte, agevel1, ivv1 et 2+ +# perfs dont l'unit? de calcul est le produit : ie tous les produits issus de vaches actives +# prol, mort, tx de repros, nb de PP, tx de VF, PN, P120 et 210, ptg sevrage + + +## stats du cheptel a inserer dans la liste des adherents pour comparaison + +stats_chep_bis <- detail_stats_chep[1,] +stats_chep_bis[1,] <- NA + +stats_chep_bis$ADHHBC <- CHEP + +stats_chep_bis$isu[1] <- round( mean(vaches$indisu, na.rm=T), 1) +stats_chep_bis$tps_prod[1] <- round( mean(vaches$tempsprod, na.rm=T), 1) +stats_chep_bis$age[1] <- round( mean(vaches$age_years, na.rm=T), 1) +stats_chep_bis$ptgv[1] <- round( mean(vaches$ptgV, na.rm=T), 1) +stats_chep_bis$agevel1[1] <- round( mean(vaches$agevel1, na.rm=T), 1) +stats_chep_bis$ivv1[1] <- round( mean(vaches$ivv1, na.rm=T), 1) +stats_chep_bis$ivv2p[1] <- round( mean(vaches$ivv2p, na.rm=T), 1) + +stats_chep_bis$prol[1] <- round( nrow(PROD) / nrow(campagnes) * 100, 1) +stats_chep_bis$mort[1] <- round( nrow(subset(PROD, PROD$mortsev == 'O')) + / nrow(PROD) * 100, 1) +stats_chep_bis$txvf[1] <- round( nrow(subset(PROD, PROD$conais %in% c('1','2'))) + / nrow(PROD) * 100, 1) +stats_chep_bis$tx_repros[1] <- round( nrow(subset(PROD, PROD$NBPRODIPG > 0)) + / nrow(PROD) * 100, 1) +stats_chep_bis$nbpp[1] <- sum(PROD$NBPRODIPG, na.rm=TRUE) +stats_chep_bis$ptgp[1] <- round( mean(0.75 * PROD$devmus + 0.25 * PROD$devsqe, + na.rm=TRUE), 1) +stats_chep_bis$pnm[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$ponais, + na.rm=TRUE), 1) +stats_chep_bis$pnf[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$ponais, + na.rm=TRUE), 1) +stats_chep_bis$p120m[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$pat04m, + na.rm=TRUE), 1) +stats_chep_bis$p120f[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$pat04m, + na.rm=TRUE), 1) +stats_chep_bis$p210m[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$pat07m, + na.rm=TRUE), 1) +stats_chep_bis$p210f[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$pat07m, + na.rm=TRUE), 1) +stats_chep_bis$date_calc[1] <- as.character(Sys.Date()) + +# on met a jour le fichier des stats des adh +#____________________________ prevoir une ?tape de verif de VALEURS ABERRENTES ! + +detail_stats_chep <- subset(detail_stats_chep, detail_stats_chep$ADHHBC != CHEP) + +detail_stats_chep <- rbind(detail_stats_chep, stats_chep_bis) + +write.table(detail_stats_chep, + file = paste(rep_exp, "detail_stats_chep.csv", sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"),na = "") + + +## stats du cheptel avec distribution des adh?rents et des vaches +rownames(stats_chep) <- stats_chep$var + +res_chep <- stats_chep[c('vaches$indisu', 'vaches$tempsprod', 'vaches$age_years', + 'vaches$ptgV','vaches$agevel1', 'vaches$ivv1', + 'vaches$ivv2p', 'vaches$prol', 'vaches$mort', + 'vaches$txrepros', 'vaches$nbpp', 'vaches$txvf', + 'vaches$pn_m', 'vaches$pn_f', 'vaches$p120_m', + 'vaches$p120_f', 'vaches$p210_m', 'vaches$p210_f', + 'vaches$ptgP'), + c('moy', 'min', 'q1', 'med', 'q3', 'max')] + +# creation d'un table contenant la distribution des cheptels pour chaque variable +stats_adh <- data.frame(matrix(NA, ncol = 7,nrow = 19)) +colnames(stats_adh) <- c("var", "moy_c", "min_c", "Q1_c", "med_c", "Q3_c", "max_c" ) +stats_adh[,1] <- c('isu','tps_prod','age','ptgv','agevel1','ivv1','ivv2p', + 'prol','mort','tx_repros','nbpp','txvf', + 'pnm','pnf','p120m','p120f','p210m','p210f','ptgp') + +# remplissage de la table +for (i in 1:nrow(stats_adh)){ + stats_adh$moy_c[i] <- round(mean(unlist(detail_stats_chep[,i + 1]), + na.rm = TRUE), 1) + stats_adh$min_c[i] <- round(min(detail_stats_chep[,i + 1], na.rm = TRUE), 1) + stats_adh$Q1_c[i] <- round(quantile(detail_stats_chep[,i + 1], + probs = 0.25, na.rm = TRUE), 1) + stats_adh$med_c[i] <- round(quantile(detail_stats_chep[,i + 1], + probs = 0.50, na.rm = TRUE), 1) + stats_adh$Q3_c[i] <- round(quantile(detail_stats_chep[,i + 1], + probs = 0.75,na.rm = TRUE), 1) + stats_adh$max_c[i] <- round(max(detail_stats_chep[,i + 1], na.rm = TRUE), 1) +} + +# on fusionne distribution des adherents et des vaches du cheptel d'?tude +STATS <- cbind(stats_adh, t(stats_chep_bis[, c(2 : (ncol(stats_chep_bis) - 1))])) + +STATS <- cbind(STATS, res_chep) + +STATS$var <- c("ISU", "% vie productive", "age (annees)", + "pointage VACHE *m", "age 1er velage (m)", "IVV1 (j)", "IVV2+ (j)", + "prolificite (%)", "mortalite av.sevr (%)", "% produits repros", + "nb petits-produits", "% velages tranquilles", "PN males (kg)", + "PN femelles (kg)", "P120 males (kg)", "P120 femelles (kg)", + "P210 males (kg)", "P210 femelles (kg)", "pointage PRODUITS *m") +colnames(STATS) <- c('Variable', 'Moyenne_ADH', 'Min_ADH', 'Q1_ADH', + 'Mediane_ADH', 'Q3_ADH', 'Max_ADH', 'Moyenne_cheptel', + 'Moyenne_vaches', 'Min_vaches', 'Q1_vaches', + 'Mediane_vaches', 'Q3_vaches', 'Max_vaches') + +write.table(STATS, + file = paste(rep, '/', CHEP, '_ResChep_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + +print("Fin du calcul des stats cheptels") + +################################################################################ +### remont?e des perfs des taureaux marquants ################################## +################################################################################ + +# on r?cupere les peres des animaux actifs +# on regarde s'ils ont un nombre raisonnable de produits, ie moins de 275 +# si c'est la cas, on r?cupere tous les produits puis on trie ceux n?s dans le cheptel + +## update du 13dec2021 apres mise en prod du WS sur la production d'un animal dans un cheptel particulier + +peres <- inventaire %>% + filter(trim_str(chna) == CHEP & !is.na(pere)) %>% + distinct(pere, nompere) %>% add_column('naisseur' = NA) + +if (nrow(peres) > 0) { + for (i in 1:nrow(peres)) { + li_anim <- chgt_infos(trim_str(peres$pere[i])) + if (is.data.frame(li_anim)) { + peres$naisseur[i] <- li_anim$nomnais[1] + } + } + + prod_peres <- inventaire[0,] + pp_peres <- inventaire[0,] + + for (i in 1 : nrow(peres)) { + animal <- peres$pere[i] + cat("\n", animal, peres$nompere[i]) + try({ + produits <- get_produits_in_chep(animal, CHEP) # loc update + if (is.data.frame(produits) == TRUE) { #__________________________________ + produits <- produits %>% filter(trim_str(chna) == CHEP) + prod_peres <- rbind(prod_peres, produits) + for (j in 1:nrow(produits)) { + if (produits$sexbov[j] == '2' & as.numeric(produits$nbdescendants[j]) > 0) { + pp <- get_produits_vache(trim_str(produits$anim[j])) + if (is.data.frame(pp) == TRUE) { #______________________________ + pp <- pp %>% filter(trim_str(chna) == CHEP) + pp_peres <- rbind(pp_peres, pp) + } + } + } + } else { #________________________________________________________________ + cat("\n", "Aucune donn?e charg?e") + } + }) + } + + if (nrow(prod_peres) > 0) { + if (!is.na(prod_peres$danais[1]) & nchar(as.character(prod_peres$danais[1])) > 10) { + prod_peres$danais <- as.Date(substr(as.POSIXct(prod_peres$danais / 1000, + origin = "1970-01-01"), 1, 10), + format = "%Y-%m-%d", + origin = "1970-01-01") + } else { + prod_peres$danais <- as.Date(prod_peres$danais, + format = "%Y-%m-%d") + } + sortis <- subset(prod_peres, !is.na(prod_peres$dasort)) + if (nrow(sortis) > 0 && nchar(as.character(sortis$dasort[1])) > 10) { + prod_peres$dasort <- as.Date(substr(as.POSIXct(prod_peres$dasort / 1000, + origin = "1970-01-01"), 1, 10), + format = "%Y-%m-%d", + origin = "1970-01-01") + } else { + prod_peres$dasort <- as.Date(prod_peres$dasort, + format = "%Y-%m-%d") + } + if (!is.na(prod_peres$danaismere[1]) & nchar(as.character(prod_peres$danaismere[1])) > 10) { + prod_peres$danaismere <- as.Date(substr(as.POSIXct(prod_peres$danaismere / 1000, + origin = "1970-01-01"), 1, 10), + format = "%Y-%m-%d", + origin = "1970-01-01") + } else { + prod_peres$danaismere <- as.Date(prod_peres$danaismere, + format = "%Y-%m-%d") + } + + prod_peres$mere <- trim_str(prod_peres$mere) + prod_peres$pere <- trim_str(prod_peres$pere) + prod_peres$anim <- trim_str(prod_peres$anim) + prod_peres$ds <- as.numeric(prod_peres$ds) + prod_peres$af <- as.numeric(prod_peres$af) + prod_peres$dmC <- as.numeric(prod_peres$dmC) + + # liste de tous leurs produitsdir + produitsdir <- prod_peres #%>% filter(chna == CHEP) # _________________________ filtre a reflechir ????? + + # vachestot actives + vachestot <- subset(prod_peres, + prod_peres$sexbov == '2' & prod_peres$nbdescendants > 0 ) + + # les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant + if (nrow(porteuses) > 0) { + for (i in 1:nrow(porteuses)) { + if (!(porteuses$ANIM[i] %in% trim_str(produitsdir$anim))) { + + temp <- appel_infos(porteuses$ANIM[i], hbcanim) + li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i]) + + if ( is.data.frame(temp) & nrow(temp) > 0 ) { + temp$mere[1] <- porteuses$MEREIPG[i] + temp[1, c(60:67, 86:103)] <- NA + if ( nrow(li_mere) > 0){ + temp$danaismere[1] <- as.character(li_mere$danais[1]) + } + temp$indite[1] <- 'O_corr' + + tryCatch({ + produitsdir <- rbind(produitsdir, temp[,colnames(produitsdir)]) #-------------------------------- tryCatch à supp + }, + error = function(e) e) + } + } + } + } + + # modifs des types de donn?es, pour calcul par la suite + produitsdir$danais <- as.Date(produitsdir$danais, format = "%Y-%m-%d") + produitsdir$dasort <- as.Date(produitsdir$dasort, format = "%Y-%m-%d") + + produitsdir$mere <- trim_str(produitsdir$mere) + produitsdir$pere <- trim_str(produitsdir$pere) + produitsdir$anim <- trim_str(produitsdir$anim) + + produitsdir$ravelamere <- as.numeric(produitsdir$ravelamere) + produitsdir$ivv <- as.numeric(produitsdir$ivv) + produitsdir$campn <- as.numeric(produitsdir$campn) + produitsdir$nbdescendants <- as.numeric(produitsdir$nbdescendants) + + produitsdir$ponais <- as.numeric(produitsdir$ponais) + produitsdir$pat04m <- as.numeric(produitsdir$pat04m) + produitsdir$pat07m <- as.numeric(produitsdir$pat07m) + + produitsdir$devsqe <- as.numeric(produitsdir$devsqe) + produitsdir$devmus <- as.numeric(produitsdir$devmus) + produitsdir$aptfon <- as.numeric(produitsdir$aptfon) + + # on ne garde que les TE port?s par une vache active du cheptel + PRODDIR <- subset(produitsdir, produitsdir$indite != 'O') + + # ajout des produitsdir IPG + PRODDIR <- merge(PRODDIR, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + PRODDIR <- PRODDIR[order(PRODDIR$danais, decreasing = F),] + PRODDIR <- PRODDIR[order(PRODDIR$mere, decreasing = T),] + + # correction des ravelamere des TE si possible + for (i in 1:nrow(PRODDIR)) { + if (is.na(PRODDIR$ravelamere[i])) { + if (!is.na(PRODDIR$ravelamere[i+1]) & PRODDIR$ravelamere[i+1] %in% c(1, 2)) { + PRODDIR$ravelamere[i] <- 1 + PRODDIR$typemere[i] <- 'G' + } else if (!is.na(PRODDIR$ravelamere[i+1]) & PRODDIR$ravelamere[i+1] > 1) { + PRODDIR$ravelamere[i] <- PRODDIR$ravelamere[i+1] - 1 + PRODDIR$typemere[i] <- 'V' + } + } + } + + # age au velage de la mere + PRODDIR$agevel <- round(time_length(interval(PRODDIR$danaismere, PRODDIR$danais), + unit="months"), 1) + + # IVV : utilisation de la colonne deja pr?sente de HBCANIM + + for (i in 1:nrow(PRODDIR)) { + if (PRODDIR$indite[i] == 'O_corr') { + PRODDIR$nobovi[i] <- paste('#', PRODDIR$nobovi[i], sep='') + } + # repro + if (PRODDIR$anim[i] %in% czhbc$ANIM + | (!is.na(PRODDIR$NBPRODIPG[i]) & PRODDIR$NBPRODIPG[i] > 0) + | (!is.na(PRODDIR$nbdescendants[i]) + & as.numeric(PRODDIR$nbdescendants[i]) > 0)) { + PRODDIR$repro[i] <- 'O' + } else { + PRODDIR$repro[i] <- NA + PRODDIR$nobovi[i] <- PRODDIR$nobovi[i] %>% str_to_lower() + } + # mortalite + if (!is.na(PRODDIR$dasort[i]) & !is.na(PRODDIR$casort[i]) + & PRODDIR$casort[i] == 'M' + & time_length(interval(PRODDIR$danais[i], PRODDIR$dasort[i]), + unit="days") < 211){ + PRODDIR$mortsev[i] <- 'O' + PRODDIR$nobovi[i]=paste(PRODDIR$nobovi[i], ' (MavS)', sep='') + } else { + PRODDIR$mortsev[i] <- NA + } + # IVV + if (i > 1) { + # cas normaux + if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1]) + & PRODDIR$ravelamere[i] != 1 + & PRODDIR$ravelamere[i] == PRODDIR$ravelamere[i-1] + 1 + #& !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] != '2' + & !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) { + PRODDIR$ivv[i] <- time_length(interval(PRODDIR$danais[i-1], PRODDIR$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1]) + & PRODDIR$ravelamere[i] != 1 + & PRODDIR$ravelamere[i] == PRODDIR$ravelamere[i-1] + & !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] == '2' + & !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) { + PRODDIR$ivv[i] <- PRODDIR$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1]) + & PRODDIR$ravelamere[i] != 1 + & !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] != '2' + & !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) { + PRODDIR$ivv[i] <- round(time_length(interval(PRODDIR$danais[i-1], + PRODDIR$danais[i]), + unit="days") + / (PRODDIR$ravelamere[i] + - PRODDIR$ravelamere[i-1]), 0) + } else { + PRODDIR$ivv[i] <- NA + } + } + } + + # calcul des effets du cheptel : rang de velage et sexe du veau + effet <- PRODDIR %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) + effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] + effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p120[1] + effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p210[1] + + # calcul des effets du cheptel : sexe sur la repro + effetsexe <- PRODDIR %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + + # report des effets sur les produitsdir + + for (i in 1:nrow(PRODDIR)) { + if (PRODDIR$sexbov[i] == '2') { #____________________________________ FEMELLES + PRODDIR$nbpp_corr[i] <- PRODDIR$NBPRODIPG[i] * rapport_MF + if (!is.na(PRODDIR$typemere[i]) & PRODDIR$typemere[i] == 'G') { #____genisses + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PRODDIR$nbpp_corr[i] <- PRODDIR$NBPRODIPG[i] + if (!is.na(PRODDIR$typemere[i]) & PRODDIR$typemere[i] == 'G') { #_________________________________genisses + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODDIR$ponais[i])) { + PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODDIR$pn_corr[i] <- NA + } + if (!is.na(PRODDIR$pat04m[i])) { + PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODDIR$p120_corr[i] <- NA + } + if (!is.na(PRODDIR$pat07m[i])) { + PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODDIR$p210_corr[i] <- NA + } + } + } + } + } + + if (nrow(vachestot) > 0) { + # recherche des meres dans les porteuses pour aller chercher + # les produitstot s'ils existent dans HBCANIM + + porteuses <- subset(indite, !is.na(indite$MEREIPG) + & indite$MEREIPG %in% trim_str(vachestot$anim)) + donneuses <- subset(indite, !is.na(indite$MERECPB) + & indite$MERECPB %in% trim_str(vachestot$anim)) + # l'indicateur de donneuse d'embryon est renseign? apr?s dans --> vachestot$ACINAC + + for (i in 1:nrow(vachestot)) { + if (is.na(vachestot$dasort[i])){ + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], Sys.Date()), unit="days") + } else { + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], vachestot$dasort[i]), unit="days") + } + } + + vachestot$age_years <- round(vachestot$age_days / 365, 1) + + # liste de tous leurs produitstot + produitstot <- pp_peres #%>% filter(chna == CHEP) # ___________________________ filtre a reflechir ????? + + # les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant + if (nrow(porteuses) > 0) { + for (i in 1:nrow(porteuses)) { + if (!(porteuses$ANIM[i] %in% trim_str(produitstot$anim))) { + + temp <- appel_infos(porteuses$ANIM[i], hbcanim) + li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i]) + + if ( is.data.frame(temp) & nrow(temp) > 0 ) { + temp$mere[1] <- porteuses$MEREIPG[i] + temp[1, c(60:67, 86:103)] <- NA + if ( nrow(li_mere) > 0){ + temp$danaismere[1] <- as.character(li_mere$danais[1]) + } + temp$indite[1] <- 'O_corr' + + produitstot <- rbind(produitstot, temp[,colnames(produitstot)]) + } + } + } + } + + # modifs des types de donn?es, pour calcul par la suite + produitstot$danais <- as.Date(produitstot$danais, format = "%Y-%m-%d") + produitstot$dasort <- as.Date(produitstot$dasort, format = "%Y-%m-%d") + + produitstot$mere <- trim_str(produitstot$mere) + produitstot$pere <- trim_str(produitstot$pere) + produitstot$anim <- trim_str(produitstot$anim) + + produitstot$ravelamere <- as.numeric(produitstot$ravelamere) + produitstot$ivv <- as.numeric(produitstot$ivv) + produitstot$campn <- as.numeric(produitstot$campn) + produitstot$nbdescendants <- as.numeric(produitstot$nbdescendants) + + produitstot$ponais <- as.numeric(produitstot$ponais) + produitstot$pat04m <- as.numeric(produitstot$pat04m) + produitstot$pat07m <- as.numeric(produitstot$pat07m) + + produitstot$devsqe <- as.numeric(produitstot$devsqe) + produitstot$devmus <- as.numeric(produitstot$devmus) + produitstot$aptfon <- as.numeric(produitstot$aptfon) + + # on ne garde que les TE port?s par une vache active du cheptel + PRODTOT <- subset(produitstot, produitstot$indite != 'O') + + # ajout des produitstot IPG + PRODTOT <- merge(PRODTOT, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + PRODTOT <- PRODTOT[order(PRODTOT$danais, decreasing = F),] + PRODTOT <- PRODTOT[order(PRODTOT$mere, decreasing = T),] + + # correction des ravelamere des TE si possible + for (i in 1:nrow(PRODTOT)) { + if (is.na(PRODTOT$ravelamere[i])) { + if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] %in% c(1, 2)) { + PRODTOT$ravelamere[i] <- 1 + PRODTOT$typemere[i] <- 'G' + } else if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] > 1) { + PRODTOT$ravelamere[i] <- PRODTOT$ravelamere[i+1] - 1 + PRODTOT$typemere[i] <- 'V' + } + } + } + + # age au velage de la mere + PRODTOT$agevel <- round(time_length(interval(PRODTOT$danaismere, PRODTOT$danais), + unit="months"), 1) + + # IVV : utilisation de la colonne deja presente de HBCANIM + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$indite[i] == 'O_corr') { + PRODTOT$nobovi[i] <- paste('#', PRODTOT$nobovi[i], sep='') + } + # repro + if (PRODTOT$anim[i] %in% czhbc$ANIM + | (!is.na(PRODTOT$NBPRODIPG[i]) & PRODTOT$NBPRODIPG[i] > 0) + | (!is.na(PRODTOT$nbdescendants[i]) + & as.numeric(PRODTOT$nbdescendants[i]) > 0)) { + PRODTOT$repro[i] <- 'O' + } else { + PRODTOT$repro[i] <- NA + PRODTOT$nobovi[i] <- PRODTOT$nobovi[i] %>% str_to_lower() + } + # mortalite + if (!is.na(PRODTOT$dasort[i]) & !is.na(PRODTOT$casort[i]) + & PRODTOT$casort[i] == 'M' + & time_length(interval(PRODTOT$danais[i], PRODTOT$dasort[i]), + unit="days") < 211){ + PRODTOT$mortsev[i] <- 'O' + PRODTOT$nobovi[i]=paste(PRODTOT$nobovi[i], ' (MavS)', sep='') + } else { + PRODTOT$mortsev[i] <- NA + } + # IVV + if (i > 1) { + # cas normaux + if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + 1 + #& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] == '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- PRODTOT$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- round(time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + / (PRODTOT$ravelamere[i] + - PRODTOT$ravelamere[i-1]), 0) + } else { + PRODTOT$ivv[i] <- NA + } + } + } + + # calcul des effets du cheptel : rang de velage et sexe du veau + effet <- PRODTOT %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) + effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] + effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p120[1] + effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p210[1] + + # calcul des effets du cheptel : sexe sur la repro + effetsexe <- PRODTOT %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + + # report des effets sur les produitstot + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$sexbov[i] == '2') { #___________________________________ FEMELLES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] * rapport_MF + if (!is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #___genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #________________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] + if ( !is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #_________________________________genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } + } + + # calcul des donn?es ?labor?es par vache active + + for (i in 1:nrow(vachestot)) { + # ___________________________________________rappel des produitstot par vache + veaux <- PRODTOT %>% filter(mere == vachestot$anim[i]) + + # ___________________________________________calcul des infos utiles par vache + + # calcul du poids adulte estim? et synth?se pointage vache ___________________ + if (!is.na(vachestot$dmC[i])) { + vachestot$ptgV[i] <- round(0.6 * vachestot$dmC[i] + 0.15 * vachestot$ds[i] + + 0.25 * vachestot$af[i], 1) + } else { + vachestot$ptgV[i] <- NA + } + + if (nrow(veaux) > 3){ + vachestot$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2) + alpha <- 1.62 - 0.01 * vachestot$precocite[i] + } else { + vachestot$precocite[i] <- NA + alpha <- 1.62 + } + if (!is.na(vachestot$pat24m[i])) { + vachestot$pad[i] <- round((vachestot$pat24m[i] - 50 * exp(-720 * alpha * 10**(-3))) + / (1 - exp(-720 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat18m[i])) { + vachestot$pad[i] <- round((vachestot$pat18m[i] - 50 * exp(-540 * alpha * 10**(-3))) + / (1 - exp(-540 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat12m[i])) { + vachestot$pad[i] <- round((vachestot$pat12m[i] - 50 * exp(-360 * alpha * 10**(-3))) + / (1-exp(-360 * alpha * 10**(-3))), 1) + } else { + vachestot$pad[i] <- NA + } + + # calcul des perfs de repro et du temps productif ____________________________ + + vachestot$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1) + + if (1 %in% veaux$ravelamere) { + vachestot$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1] + } else { + vachestot$agevel1[i] <- NA + } + + if (2 %in% veaux$ravelamere) { + vachestot$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1] + } else { + vachestot$ivv1[i] <- NA + } + if (3 %in% veaux$ravelamere) { + vachestot$ivv2p[i] <- round(mean(subset(veaux, + veaux$ravelamere > 2)$ivv, na.rm=T), 1) + } + + if (is.na(vachestot$ivv1[i]) | (!is.na(vachestot$ivv1[i]) + & vachestot$ivv1[i] < 390) ){ + e2 <- 0 + } else if (!is.na(vachestot$ivv1[i]) & vachestot$ivv1[i] >= 390) { + e2 <- vachestot$ivv1[i] - 390 + } + if (is.na(vachestot$ivv2p[i]) | (!is.na(vachestot$ivv2p[i]) + & vachestot$ivv2p[i] < 365) ){ + e3 <- 0 + } else if (!is.na(vachestot$ivv2p[i]) & vachestot$ivv2p[i] >= 365) { + e3 <- vachestot$ivv1[i] - 365 + } + if (is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") - 365 + } + } else if (!is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") - 365 + } + } + + vachestot$tempsprod[i] <- round( (vachestot$age_days[i] + - ( vachestot$agevel1[i] * 30.4 + + e2 + + e3 * (vachestot$nbcampvel[i] - 2) + + e4 + )) / vachestot$age_days[i] * 100, 1) + + # calcul des donn?es synthetiques sur les produitstot ___________________________ + + vachestot$prol[i] <- round(nrow(veaux) / (vachestot$nbcampvel[i]) * 100, 1) + vachestot$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O')) + / nrow(veaux)* 100, 1) + vachestot$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O')) + / nrow(veaux)* 100, 1) + vachestot$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T) + vachestot$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T) + vachestot$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux)* 100, 1) + vachestot$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') )) + / nrow(veaux)* 100, 1) + vachestot$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE) + + 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1) + vachestot$pn_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$ponais, na.rm=T), 1) + vachestot$p120_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat04m, na.rm=T), 1) + vachestot$p210_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat07m, na.rm=T), 1) + vachestot$pn_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$ponais, na.rm=T), 1) + vachestot$p120_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat04m, na.rm=T), 1) + vachestot$p210_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat07m, na.rm=T), 1) + vachestot$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1) + vachestot$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1) + vachestot$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1) + + ### convertion des NaN en NA + L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr', + 'p210_m','p210_f','p210_corr') + for (j in L){ + if (is.nan(vachestot[i,j]) == TRUE){ + vachestot[i,j] <- NA + } + } + } + } +} +# calcul des stats par pere ____________________________________________________ + +stats_peres <- PRODDIR %>% group_by(pere) %>% + summarise(nb_prod_in_chep = n()) %>% filter(nb_prod_in_chep >=5) + +stats_peres <- stats_peres %>% + add_column(utilgen = NA, prol = NA, mort = NA, txrepros = NA, nbpp = NA, + txvf = NA, pnm = NA, pnf = NA, p120m = NA, p120f = NA, p210m = NA, + p210f = NA, dmsev = NA, dssev = NA, + nbfilles_avecprod = NA, pctfilles_avecprod = NA, + isu_fillestot = NA, age_sort_fillestot = NA, + agevel1_fillestot = NA, ivv1_fillestot = NA, ivv2p_fillestot = NA, + vieprod_fillestot = NA, dmad_fillestot = NA, dsad_fillestot = NA, + afad_fillestot = NA, nbprod_fillestot = NA, txrepros_fillestot = NA, + nbpp_fillestot = NA, prol_fillestot = NA, mort_fillestot = NA, + txvf_fillestot = NA, + nbfillesact_avecprod = NA, pctfillesact_avecprod = NA, + isu_fillesact = NA, age_sort_fillesact = NA, + agevel1_fillesact = NA, ivv1_fillesact = NA, ivv2p_fillesact = NA, + vieprod_fillesact = NA, dmad_fillesact = NA, dsad_fillesact = NA, + afad_fillesact = NA, nbprod_fillesact = NA, txrepros_fillesact = NA, + nbpp_fillesact = NA, prol_fillesact = NA, mort_fillesact = NA, + txvf_fillesact = NA, nbfilles_renouv = NA) + +for (i in 1:nrow(stats_peres)) { + # stats sur la prod directe __________________________________________________ + li_prod <- subset(PRODDIR, PRODDIR$pere == stats_peres$pere[i]) + + stats_peres$utilgen[i] <- round(nrow(subset(li_prod, + li_prod$ravelamere == 1)) + / nrow(li_prod) * 100, 1) + stats_peres$prol[i] <- round(nrow(li_prod) + / nrow(li_prod %>% distinct(danais, mere)) + * 100, 1) + stats_peres$mort[i] <- round(nrow(subset(li_prod, li_prod$mortsev == 'O')) + / nrow(li_prod) * 100, 1) + stats_peres$txrepros[i] <- round(nrow(subset(li_prod, li_prod$repro == 'O')) + / nrow(subset(li_prod, + is.na(li_prod$mortsev))) * 100, 1) + stats_peres$nbpp[i] <- sum(li_prod$nbdescendants) + stats_peres$txvf[i] <- round(nrow(subset(li_prod, li_prod$conais %in% c('1','2'))) + / nrow(li_prod) * 100, 1) + stats_peres$pnm[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$ponais, na.rm=T),1) + stats_peres$pnf[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$ponais, na.rm=T),1) + stats_peres$p120m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat04m, na.rm=T),1) + stats_peres$p120f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat04m, na.rm=T),1) + stats_peres$p210m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat07m, na.rm=T),1) + stats_peres$p210f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat07m, na.rm=T),1) + stats_peres$dmsev[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$devmus, na.rm=T),1) + stats_peres$dssev[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$devsqe, na.rm=T),1) + + # stats sur la prod par les filles ___________________________________________ + li_filles <- subset(vachestot, vachestot$pere == stats_peres$pere[i]) + + # modif du 30/04/2024 + if (nrow(li_filles) > 0){ + stats_peres$nbfilles_avecprod[i] <- nrow(li_filles) + stats_peres$pctfilles_avecprod[i] <- round(nrow(li_filles) + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_filles) >= 3) { + stats_peres$isu_fillestot[i] <- round(mean(li_filles$indisu, na.rm=T),1) + stats_peres$age_sort_fillestot[i] <- round(mean(li_filles$age_years, na.rm=T),1) + stats_peres$agevel1_fillestot[i] <- round(mean(li_filles$agevel1, na.rm=T),1) + stats_peres$vieprod_fillestot[i] <- round(mean(li_filles$tempsprod, na.rm=T),1) + stats_peres$ivv1_fillestot[i] <- round(mean(li_filles$ivv1, na.rm=T),1) + stats_peres$ivv2p_fillestot[i] <- round(mean(li_filles$ivv2p, na.rm=T),1) + + stats_peres$dmad_fillestot[i] <- round(mean(li_filles$dmC, na.rm=T),1) + stats_peres$dsad_fillestot[i] <- round(mean(li_filles$ds, na.rm=T),1) + stats_peres$afad_fillestot[i] <- round(mean(li_filles$af, na.rm=T),1) + + stats_peres$prol_fillestot[i] <- round(mean(li_filles$prol, na.rm=T),1) + stats_peres$mort_fillestot[i] <- round(mean(li_filles$mort, na.rm=T),1) + stats_peres$txvf_fillestot[i] <- round(mean(li_filles$txvf, na.rm=T),1) + + stats_peres$nbprod_fillestot[i] <- round(sum(li_filles$nbdescendants),1) + stats_peres$txrepros_fillestot[i] <- round(mean(li_filles$txrepros, na.rm=T),1) + stats_peres$nbpp_fillestot[i] <- round(sum(li_filles$nbpp),1) + } + + # stats sur la prod par les filles actives ___________________________________ + li_filles_act <- subset(vachestot, vachestot$pere == stats_peres$pere[i] + & is.na(vachestot$dasort)) + + # modif du 30/04/2024 + if (nrow(li_filles_act) > 0) { + stats_peres$nbfillesact_avecprod[i] <- nrow(li_filles_act) + stats_peres$pctfillesact_avecprod[i] <- round(nrow(li_filles_act) + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_filles_act) >= 3) { + stats_peres$isu_fillesact[i] <- round(mean(li_filles_act$indisu, na.rm=T),1) + stats_peres$age_sort_fillesact[i] <- round(mean(li_filles_act$age_years, na.rm=T),1) + stats_peres$agevel1_fillesact[i] <- round(mean(li_filles_act$agevel1, na.rm=T),1) + stats_peres$vieprod_fillesact[i] <- round(mean(li_filles_act$tempsprod, na.rm=T),1) + stats_peres$ivv1_fillesact[i] <- round(mean(li_filles_act$ivv1, na.rm=T),1) + stats_peres$ivv2p_fillesact[i] <- round(mean(li_filles_act$ivv2p, na.rm=T),1) + + stats_peres$dmad_fillesact[i] <- round(mean(li_filles_act$dmC, na.rm=T),1) + stats_peres$dsad_fillesact[i] <- round(mean(li_filles_act$ds, na.rm=T),1) + stats_peres$afad_fillesact[i] <- round(mean(li_filles_act$af, na.rm=T),1) + + stats_peres$prol_fillesact[i] <- round(mean(li_filles_act$prol, na.rm=T),1) + stats_peres$mort_fillesact[i] <- round(mean(li_filles_act$mort, na.rm=T),1) + stats_peres$txvf_fillesact[i] <- round(mean(li_filles_act$txvf, na.rm=T),1) + + stats_peres$nbprod_fillesact[i] <- round(sum(li_filles_act$nbdescendants),1) + stats_peres$txrepros_fillesact[i] <- round(mean(li_filles_act$txrepros, na.rm=T),1) + stats_peres$nbpp_fillesact[i] <- round(sum(li_filles_act$nbpp),1) + } + + #filles a venir + nbfr <- nrow(subset(inventaire, + inventaire$pere == stats_peres$pere[i] + & inventaire$nbdescendants == 0 + & inventaire$sexbov == '2')) + if (nbfr > 0 ){ + stats_peres$nbfilles_renouv[i] <- nbfr + } +} + +stats_peres <- merge(peres, stats_peres, all.x=F, all.y=T) + +write.table(stats_peres, + file = paste(rep, '/', CHEP, '_ResTaureaux_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + +print("Fin du calcul des stats par père") + +################################################################################ +### remontee des lignees femelles ############################################## +################################################################################ + +hbcgene_coltypes <- cols(anim = col_character(), nobovi = col_character(), + nomnais = col_character(), qualifco = col_character(), + pere = col_character(), mere = col_character(), + dcre = col_character(), danais = col_character(), + ifnais = col_integer(), crsevs = col_integer(), + dmsevs = col_integer(), dssevs = col_integer(), + alaits = col_integer(), isevre = col_integer(), + ivmate = col_integer(), iqmqms = col_integer(), + iabjbs = col_integer(), avelag = col_integer(), + indisu = col_integer(), + cdisev = col_number()) + +## on remonte vers les fondatrices + +femelles <- inventaire %>% filter(sexbov == '2') +femelles[] <- lapply(femelles, function(x) if(is.logical(x)) as.character(x) else x) + +old <- Sys.time() + +t_travail <- femelles +t_temp = t_final <- inventaire[0,] + +line_mere <- inventaire[0,] +#line_mere$iqmqms = line_mere$iabjbs <- NA + +# mise en commentaire : 07/03/2023 +# t_travail[] <- lapply(t_travail, function(x) if(is.Date(x)) as.character(x) else x) +# t_final[] <- lapply(t_final, function(x) if(is.Date(x)) as.character(x) else x) +# t_temp[] <- lapply(t_temp, function(x) if(is.Date(x)) as.character(x) else x) + +t_travail[] <- lapply(t_travail, function(x) if(is.logical(x)) as.character(x) else x) +t_final[] <- lapply(t_final, function(x) if(is.logical(x)) as.character(x) else x) +t_temp[] <- lapply(t_temp, function(x) if(is.logical(x)) as.character(x) else x) + +nbl <- nrow(t_travail) +nb_tours <- 0 + +while (nbl > 0) { + for (i in 1:nrow(t_travail)) { + if (!is.na(t_travail$mere[i])) { + if ((trim_str(t_travail$mere[i]) %in% trim_str(t_final$anim)) + | (trim_str(t_travail$mere[i]) %in% trim_str(t_travail$anim)) + | (trim_str(t_travail$mere[i]) %in% trim_str(t_temp$anim))) { + print(paste0(as.character(i), "D?ja list?e")) + } else { + #print(t_travail$mere[i]) + line_mere <- chgt_infos(trim_str(t_travail$mere[i])) + if (is.data.frame(line_mere)) { + if (nrow(line_mere) > 0 ) { + + # ajout du 07/03/2023 + line_mere <- line_mere[, intersect(names(line_mere), names(femelles))] + line_mere[] <- lapply(line_mere, function(x) if(is.logical(x)) as.character(x) else x) + for ( x in colnames(line_mere) ) { + line_mere[,x] <- eval(call( paste0("as.", class(femelles[,x])), line_mere[,x]) ) + } + + if (ncol(line_mere) > 22) { + # attribution a line_mere les memes types de col que inventaire + # afin de permettre la jointure sans erreur de type + + # modif : mise en commentaire 07/03/2023 + # line_mere$iqmqms = line_mere$iabjbs <- NA + # line_mere <- line_mere[, colnames(t_final)] + # line_mere[] <- mapply(FUN = as, line_mere, sapply(t_final, class), SIMPLIFY = FALSE) + + if ( !is.na(line_mere$chna) & trim_str(line_mere$chna) == CHEP) { + t_temp <- bind_rows(t_temp, line_mere) + } else { + print("N?e ailleurs") + t_final <- bind_rows(t_final, line_mere) + } + } else { + print("Ligne de Hbcgene") + # attribution a line_mere les types de col definis plus haut + # afin de permettre la jointure sans erreur de type + + # modif : mise en commentaire 07/03/2023 + # line_mere <- type.convert(line_mere, col_types = hbcgene_coltypes) + # line_mere$nobovi <- as.character(line_mere$nobovi) + + #cat(i, class(line_mere$indite), class(t_final$indite)) # pb de types + t_final <- bind_rows(t_final, line_mere) + } + } + } else { + print("Retour vide du WS") + } + } + } else { + print("Pas de mere") + } + } # for + t_final <- bind_rows(t_final, t_travail) + t_travail <- t_temp + t_temp <- t_temp[0,] + nbl <- nrow(t_travail) + nb_tours <- nb_tours+1 + print(paste("Nombre de g?n?rations depuis les animaux actifs : ", nb_tours, sep='')) +} # while + +inv_asc <- t_final + +fondatrices <- subset(inv_asc, is.na(inv_asc$mere) + | trim_str(inv_asc$chna) != CHEP + | is.na(inv_asc$chna) + | !(trim_str(inv_asc$mere) %in% trim_str(inv_asc$anim)) ) # modif du 27/03/2023 + +new <- Sys.time()-old +cat("Remontée des lignées :", round(new, 1) , "sec") + +# on redescendant vers tous les animaux n?s dans le cheptel issus des fondatrices +# on met de c?t? les vaches ayant produits a leur tour dans le cheptel +# ainsi que les males ayant produit (peu importe ou) + +old <- Sys.time() + +t_travail <- fondatrices +t_travail$fondatrice <- t_travail$anim +t_temp = t_final <- inventaire[0,] +t_final <- t_final %>% add_column(fondatrice = NA, iqmqms = NA, iabjbs = NA) +t_temp <- t_temp %>% add_column(fondatrice = NA, iqmqms = NA, iabjbs = NA) + +t_travail[] <- lapply(t_travail, function(x) if(is.logical(x)) as.character(x) else x) +t_final[] <- lapply(t_final, function(x) if(is.logical(x)) as.character(x) else x) +t_temp[] <- lapply(t_temp, function(x) if(is.logical(x)) as.character(x) else x) +# mise en commentaire : 07/03/2023 +# t_travail[] <- lapply(t_travail, function(x) if(is.Date(x)) as.character(x) else x) +# t_final[] <- lapply(t_final, function(x) if(is.Date(x)) as.character(x) else x) +# t_temp[] <- lapply(t_temp, function(x) if(is.Date(x)) as.character(x) else x) + +nbl <- nrow(t_travail) +nb_tours <- 0 + +while (nbl > 0) { + for (i in 1:nrow(t_travail)) { + cat(nbl, i, t_travail$anim[i], t_travail$nobovi[i], '\n') + produits <- try(appel_infos(trim_str(t_travail$anim[i]), reqMere)) + if (!is.null(produits)) { + + # MAJ du 07/03/2023 + produits <- produits[, intersect(names(produits), names(femelles))] + produits[] <- lapply(produits, function(x) if(is.logical(x)) as.character(x) else x) + for ( x in colnames(produits) ) { + produits[,x] <- eval(call( paste0("as.", class(femelles[,x])), produits[,x]) ) + } + + # modif : mise en commentaire 07/03/2023 + # produits$iqmqms = produits$iabjbs = produits$fondatrice <- NA + # produits <- produits[,colnames(t_final)] + # produits[] <- mapply(FUN = as, produits, sapply(t_final, class), SIMPLIFY = FALSE) + # produits[] <- lapply(produits, function(x) if(is.logical(x)) as.character(x) else x) + # produits[] <- lapply(produits, function(x) if(is.Date(x)) as.character(x) else x) + + produits <- subset(produits, trim_str(produits$chna) == CHEP) + if (length(produits) > 0 & nrow(produits) > 0){ + produits$fondatrice <- t_travail$fondatrice[i] + t_final <- bind_rows(t_final, produits) + repros <- subset(produits, produits$nbdescendants > 0 + & produits$sexbov == '2') + if (nrow(repros) > 0) { + t_temp <- bind_rows(t_temp, repros) + } + } + } + } # for + t_final <- bind_rows(t_final, t_travail) + t_travail <- t_temp + t_temp <- t_temp[0,] + nbl <- nrow(t_travail) + nb_tours <- nb_tours+1 + print(paste("Nombre de g?n?rations apras les fondatrices : ", nb_tours, sep='')) +} # while + +inv_desc <- t_final + +# doublons ??? +inv_desc <- inv_desc[-which(duplicated(inv_desc$anim)),] +if (nrow(inv_desc) == 0 ){ + inv_desc <- t_final +} + +# modif du 07/03/2023 +# pb du nombre de produits non ramenés par WS en appellant la mère +# inv_asc_not_in_desc <- inv_asc %>% filter( !(trim_str(anim) %in% trim_str(inv_desc$anim)) ) +# if ( nrow(inv_asc_not_in_desc) > 0) { +# inv_desc <- bind_rows(inv_desc, inv_asc_not_in_desc) +# } + +new <- Sys.time()-old +cat("Remontée des lignées :", round(new, 1)) + +# vaches tot +vachestot <- inv_desc %>% filter(sexbov == '2' & nbdescendants > 0) +produitstot <- subset(inv_desc, trim_str(inv_desc$mere) %in% trim_str(vachestot$anim)) + +if (nrow(vachestot) > 0) { + # recherche des meres dans les porteuses pour aller chercher + # les produitstot s'ils existent dans HBCANIM + + porteuses <- subset(indite, !is.na(indite$MEREIPG) + & indite$MEREIPG %in% trim_str(vachestot$anim)) + donneuses <- subset(indite, !is.na(indite$MERECPB) + & indite$MERECPB %in% trim_str(vachestot$anim)) + # l'indicateur de donneuse d'embryon est renseign? apres dans --> vachestot$ACINAC + + if ( is.numeric(vachestot$danais[1]) & vachestot$danais[1] > 1*(10**8) ) { + vachestot$danais <- as.Date(as.POSIXct(vachestot$danais / 1000, origin="1970-01-01")) + vachestot$dasort <- as.Date(as.POSIXct(vachestot$dasort / 1000, origin="1970-01-01")) + } + + for (i in 1:nrow(vachestot)) { + if (is.na(vachestot$dasort[i])){ + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], Sys.Date()), unit="days") + } else { + vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], vachestot$dasort[i]), unit="days") + } + } + + vachestot$age_years <- round(vachestot$age_days / 365, 1) + + # les veaux port?s sont rajout?s aux produitstot si non r?cup?r?s avant ________ non appliqu? car raisonnement sur lign?es + # if (nrow(porteuses) > 0) { + # for (i in 1:nrow(porteuses)) { + # if (!(porteuses$ANIM[i] %in% trim_str(produitstot$anim))) { + # + # temp <- appel_infos(porteuses$ANIM[i], hbcanim) # a voir : gerer les retours vides !!!! + # li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i]) + # + # temp$mere[1] <- porteuses$MEREIPG[i] + # temp[1, c(60:67, 86:103)] <- NA + # temp$danaismere[1] <- as.character(li_mere$danais[1]) + # temp$indite[1] <- 'O_corr' + # + # produitstot <- rbind(produitstot, temp) + # } + # } + # } + + # modifs des types de donn?es, pour calcul par la suite + if ( is.numeric(produitstot$danais[1]) & produitstot$danais[1] > 1*(10**8) ) { + produitstot$danais <- as.Date(as.POSIXct(produitstot$danais / 1000, origin="1970-01-01")) + produitstot$dasort <- as.Date(as.POSIXct(produitstot$dasort / 1000, origin="1970-01-01")) + produitstot$danaismere <- as.Date(as.POSIXct(produitstot$danaismere / 1000, origin="1970-01-01")) + } + + test_date <- produitstot %>% filter( !is.na(danaismere) ) + if (nrow(test_date) > 0) { + if ( is.numeric(test_date$danaismere[1]) & test_date$danaismere[1] > 1*(10**8) ) { + produitstot$danaismere <- as.Date(as.POSIXct(produitstot$danaismere / 1000, origin="1970-01-01")) + } + } + + produitstot$danais <- as.Date(produitstot$danais, format = "%Y-%m-%d") + produitstot$dasort <- as.Date(produitstot$dasort, format = "%Y-%m-%d") + + produitstot$mere <- trim_str(produitstot$mere) + produitstot$pere <- trim_str(produitstot$pere) + produitstot$anim <- trim_str(produitstot$anim) + + produitstot$ravelamere <- as.numeric(produitstot$ravelamere) + produitstot$ivv <- as.numeric(produitstot$ivv) + produitstot$campn <- as.numeric(produitstot$campn) + produitstot$nbdescendants <- as.numeric(produitstot$nbdescendants) + + produitstot$ponais <- as.numeric(produitstot$ponais) + produitstot$pat04m <- as.numeric(produitstot$pat04m) + produitstot$pat07m <- as.numeric(produitstot$pat07m) + + produitstot$devsqe <- as.numeric(produitstot$devsqe) + produitstot$devmus <- as.numeric(produitstot$devmus) + produitstot$aptfon <- as.numeric(produitstot$aptfon) + + # on ne garde que les TE port?s par une vache active du cheptel + PRODTOT <- subset(produitstot, produitstot$indite != 'O') + + # ajout des produitstot IPG + PRODTOT <- merge(PRODTOT, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + PRODTOT <- PRODTOT[order(PRODTOT$danais, decreasing = F),] + PRODTOT <- PRODTOT[order(PRODTOT$mere, decreasing = T),] + + # correction des ravelamere des TE si possible + for (i in 1:nrow(PRODTOT)) { + if (is.na(PRODTOT$ravelamere[i])) { + if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] %in% c(1, 2)) { + PRODTOT$ravelamere[i] <- 1 + PRODTOT$typemere[i] <- 'G' + } else if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] > 1) { + PRODTOT$ravelamere[i] <- PRODTOT$ravelamere[i+1] - 1 + PRODTOT$typemere[i] <- 'V' + } + } + } + + # age au velage de la mere + PRODTOT$agevel <- round(time_length(interval(PRODTOT$danaismere, PRODTOT$danais), + unit="months"), 1) + + # IVV : utilisation de la colonne deja pr?sente de HBCANIM + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$indite[i] == 'O_corr') { + PRODTOT$nobovi[i] <- paste('#', PRODTOT$nobovi[i], sep='') + } + # repro + if (PRODTOT$anim[i] %in% czhbc$ANIM + | (!is.na(PRODTOT$NBPRODIPG[i]) & PRODTOT$NBPRODIPG[i] > 0) + | (!is.na(PRODTOT$nbdescendants[i]) + & as.numeric(PRODTOT$nbdescendants[i]) > 0)) { + PRODTOT$repro[i] <- 'O' + } else { + PRODTOT$repro[i] <- NA + PRODTOT$nobovi[i] <- PRODTOT$nobovi[i] %>% str_to_lower() + } + # mortalite + if (!is.na(PRODTOT$dasort[i]) & !is.na(PRODTOT$casort[i]) + & PRODTOT$casort[i] == 'M' + & time_length(interval(PRODTOT$danais[i], PRODTOT$dasort[i]), + unit="days") < 211){ + PRODTOT$mortsev[i] <- 'O' + PRODTOT$nobovi[i]=paste(PRODTOT$nobovi[i], ' (MavS)', sep='') + } else { + PRODTOT$mortsev[i] <- NA + } + # IVV + if (i > 1) { + # cas normaux + if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + 1 + #& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + # jumeaux + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] == '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- PRODTOT$ivv[i-1] + # rang de v?lage manquant + } else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1]) + & PRODTOT$ravelamere[i] != 1 + & !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2' + & !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) { + PRODTOT$ivv[i] <- round(time_length(interval(PRODTOT$danais[i-1], + PRODTOT$danais[i]), + unit="days") + / (PRODTOT$ravelamere[i] + - PRODTOT$ravelamere[i-1]), 0) + } else { + PRODTOT$ivv[i] <- NA + } + if (!is.na(PRODTOT$ivv[i]) & PRODTOT$ivv[i] < 280) { + PRODTOT$ivv[i] <- NA + } + } + } + + # calcul des effets du cheptel : rang de velage et sexe du veau + effet <- PRODTOT %>% group_by(typemere, sexbov) %>% + summarise(m_PN = round(mean(ponais, na.rm=T), 1), + m_p120 = round(mean(pat04m, na.rm=T), 1), + m_p210 = round(mean(pat07m, na.rm=T), 1)) + effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_PN[1] + effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p120[1] + effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$m_p210[1] + + # calcul des effets du cheptel : sexe sur la repro + effetsexe <- PRODTOT %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>% + summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1), + nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) ) + rapport_MF <- round(subset(effetsexe, + effetsexe$sexbov == '1')$nbpp_med[1] + / subset(effetsexe, + effetsexe$sexbov == '2')$nbpp_med[1], 0) + + + # report des effets sur les produitstot + + for (i in 1:nrow(PRODTOT)) { + if (PRODTOT$sexbov[i] == '2') { #___________________________________ FEMELLES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] * rapport_MF + if (!is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #___genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #________________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '2' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } else { #______________________________________________________________ MALES + PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] + if ( !is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #_________________________________genisses + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'G')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } else { #_____________________________________________ vachestot ou inconnu + if (!is.na(PRODTOT$ponais[i])) { + PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_pn[1]) + } else { + PRODTOT$pn_corr[i] <- NA + } + if (!is.na(PRODTOT$pat04m[i])) { + PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p120[1]) + } else { + PRODTOT$p120_corr[i] <- NA + } + if (!is.na(PRODTOT$pat07m[i])) { + PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i] + + subset(effet, effet$sexbov == '1' + & effet$typemere == 'V')$diff_p210[1]) + } else { + PRODTOT$p210_corr[i] <- NA + } + } + } + } + + # calcul des donn?es ?labor?es par vache active + + for (i in 1:nrow(vachestot)) { + # ___________________________________________rappel des produitstot par vache + veaux <- PRODTOT %>% filter(mere == trim_str(vachestot$anim[i])) + + # ___________________________________________calcul des infos utiles par vache + + # calcul du poids adulte estim? et synthese pointage vache ___________________ + if (!is.na(vachestot$dmC[i])) { + vachestot$ptgV[i] <- round(0.6 * vachestot$dmC[i] + 0.15 * vachestot$ds[i] + + 0.25 * vachestot$af[i], 1) + } else { + vachestot$ptgV[i] <- NA + } + + if (nrow(veaux) > 3){ + vachestot$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2) + alpha <- 1.62 - 0.01 * vachestot$precocite[i] + } else { + vachestot$precocite[i] <- NA + alpha <- 1.62 + } + if (!is.na(vachestot$pat24m[i])) { + vachestot$pad[i] <- round((as.numeric(vachestot$pat24m[i]) - 50 * exp(-720 * alpha * 10**(-3))) + / (1 - exp(-720 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat18m[i])) { + vachestot$pad[i] <- round((as.numeric(vachestot$pat18m[i]) - 50 * exp(-540 * alpha * 10**(-3))) + / (1 - exp(-540 * alpha * 10**(-3))), 1) + } else if (!is.na(vachestot$pat12m[i])) { + vachestot$pad[i] <- round((as.numeric(vachestot$pat12m[i]) - 50 * exp(-360 * alpha * 10**(-3))) + / (1-exp(-360 * alpha * 10**(-3))), 1) + } else { + vachestot$pad[i] <- NA + } + + # calcul des perfs de repro et du temps productif ____________________________ + + vachestot$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1) + + if (1 %in% veaux$ravelamere) { + vachestot$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1] + } else { + vachestot$agevel1[i] <- NA + } + + if (2 %in% veaux$ravelamere) { + vachestot$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1] + } else { + vachestot$ivv1[i] <- NA + } + if (3 %in% veaux$ravelamere) { + vachestot$ivv2p[i] <- round(mean(subset(veaux, + veaux$ravelamere > 2)$ivv, na.rm=T), 1) + } + + if (is.na(vachestot$ivv1[i]) | (!is.na(vachestot$ivv1[i]) + & vachestot$ivv1[i] < 390) ){ + e2 <- 0 + } else if (!is.na(vachestot$ivv1[i]) & vachestot$ivv1[i] >= 390) { + e2 <- vachestot$ivv1[i] - 390 + } + if (is.na(vachestot$ivv2p[i]) | (!is.na(vachestot$ivv2p[i]) + & vachestot$ivv2p[i] < 365) ){ + e3 <- 0 + } else if (!is.na(vachestot$ivv2p[i]) & vachestot$ivv2p[i] >= 365) { + e3 <- vachestot$ivv1[i] - 365 + } + if (is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + Sys.Date()), unit="days") - 365 + } + } else if (!is.na(vachestot$dasort[i])) { + if (time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") < 365) { + e4 <- 0 + } else { + e4 <- time_length(interval(max(veaux$danais, na.rm=T), + vachestot$dasort[i]), unit="days") - 365 + } + } + + vachestot$tempsprod[i] <- round( (vachestot$age_days[i] + - ( vachestot$agevel1[i] * 30.4 + + e2 + + e3 * (vachestot$nbcampvel[i] - 2) + + e4 + )) / vachestot$age_days[i] * 100, 1) + + # calcul des donn?es synthetiques sur les produitstot ___________________________ + + vachestot$prol[i] <- round(nrow(veaux) / (vachestot$nbcampvel[i]) * 100, 1) + vachestot$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O')) + / nrow(veaux)* 100, 1) + vachestot$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O')) + / nrow(veaux)* 100, 1) + vachestot$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T) + vachestot$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T) + vachestot$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1')) + / nrow(veaux)* 100, 1) + vachestot$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') )) + / nrow(veaux)* 100, 1) + vachestot$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE) + + 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1) + vachestot$pn_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$ponais, na.rm=T), 1) + vachestot$p120_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat04m, na.rm=T), 1) + vachestot$p210_m[i] <- round(mean(subset(veaux, + veaux$sexbov == '1')$pat07m, na.rm=T), 1) + vachestot$pn_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$ponais, na.rm=T), 1) + vachestot$p120_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat04m, na.rm=T), 1) + vachestot$p210_f[i] <- round(mean(subset(veaux, + veaux$sexbov == '2')$pat07m, na.rm=T), 1) + vachestot$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1) + vachestot$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1) + vachestot$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1) + + ### convertion des NaN en NA + L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr', + 'p210_m','p210_f','p210_corr') + for (j in L){ + if (is.nan(vachestot[i,j]) == TRUE){ + vachestot[i,j] <- NA + } + } + } +} + +# calcul des stats par fondatrice ______________________________________________ + +stats_lignees <- PRODTOT %>% group_by(fondatrice) %>% + summarise(nb_desc_in_chep = n()) %>% filter(nb_desc_in_chep >=5) + +stats_lignees <- stats_lignees %>% + add_column(utilgen = NA, prol = NA, mort = NA, txrepros = NA, nbpp = NA, + txvf = NA, pnm = NA, pnf = NA, p120m = NA, p120f = NA, p210m = NA, + p210f = NA, dmsev = NA, dssev = NA, + nbfem_avecprod = NA, pctfem_avecprod = NA, + isu_femtot = NA, age_sort_femtot = NA, + agevel1_femtot = NA, ivv1_femtot = NA, ivv2p_femtot = NA, + vieprod_femtot = NA, dmad_femtot = NA, dsad_femtot = NA, + afad_femtot = NA, nbprod_femtot = NA, txrepros_femtot = NA, + nbpp_femtot = NA, prol_femtot = NA, mort_femtot = NA, + txvf_femtot = NA, + nbfemact_avecprod = NA, pctfemact_avecprod = NA, + isu_femact = NA, age_sort_femact = NA, + agevel1_femact = NA, ivv1_femact = NA, ivv2p_femact = NA, + vieprod_femact = NA, dmad_femact = NA, dsad_femact = NA, + afad_femact = NA, nbprod_femact = NA, txrepros_femact = NA, + nbpp_femact = NA, prol_femact = NA, mort_femact = NA, + txvf_femact = NA, nbfem_renouv = NA) + +for (i in 1:nrow(stats_lignees)) { + # stats sur la prod directe __________________________________________________ + li_prod <- subset(PRODTOT, PRODTOT$fondatrice == stats_lignees$fondatrice[i]) + + stats_lignees$utilgen[i] <- round(nrow(subset(li_prod, + li_prod$ravelamere == 1)) + / nrow(li_prod) * 100, 1) + stats_lignees$prol[i] <- round(nrow(li_prod) + / nrow(li_prod %>% distinct(danais, mere)) + * 100, 1) + stats_lignees$mort[i] <- round(nrow(subset(li_prod, li_prod$mortsev == 'O')) + / nrow(li_prod) * 100, 1) + stats_lignees$txrepros[i] <- round(nrow(subset(li_prod, li_prod$repro == 'O')) + / nrow(subset(li_prod, + is.na(li_prod$mortsev))) * 100, 1) + stats_lignees$nbpp[i] <- sum(li_prod$nbdescendants) + stats_lignees$txvf[i] <- round(nrow(subset(li_prod, li_prod$conais %in% c('1','2'))) + / nrow(li_prod) * 100, 1) + stats_lignees$pnm[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$ponais, na.rm=T),1) + stats_lignees$pnf[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$ponais, na.rm=T),1) + stats_lignees$p120m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat04m, na.rm=T),1) + stats_lignees$p120f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat04m, na.rm=T),1) + stats_lignees$p210m[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$pat07m, na.rm=T),1) + stats_lignees$p210f[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$pat07m, na.rm=T),1) + stats_lignees$dmsev[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '1')$devmus, na.rm=T),1) + stats_lignees$dssev[i] <- round(mean(subset(li_prod, + li_prod$sexbov == '2')$devsqe, na.rm=T),1) + + # stats sur la prod par les fem ___________________________________________ + li_fem <- subset(vachestot, vachestot$fondatrice == stats_lignees$fondatrice[i]) + + # modif du 30/04/2024 + if (nrow(li_fem) > 0) { + stats_lignees$nbfem_avecprod[i] <- nrow(li_fem) + stats_lignees$pctfem_avecprod[i] <- round(nrow(li_fem) + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_fem) >= 3) { + stats_lignees$isu_femtot[i] <- round(mean(li_fem$indisu, na.rm=T),1) + stats_lignees$age_sort_femtot[i] <- round(mean(li_fem$age_years, na.rm=T),1) + stats_lignees$agevel1_femtot[i] <- round(mean(li_fem$agevel1, na.rm=T),1) + stats_lignees$vieprod_femtot[i] <- round(mean(li_fem$tempsprod, na.rm=T),1) + stats_lignees$ivv1_femtot[i] <- round(mean(li_fem$ivv1, na.rm=T),1) + stats_lignees$ivv2p_femtot[i] <- round(mean(as.numeric(li_fem$ivv2p), na.rm=T),1) + + stats_lignees$dmad_femtot[i] <- round(mean(li_fem$dmC, na.rm=T),1) + stats_lignees$dsad_femtot[i] <- round(mean(li_fem$ds, na.rm=T),1) + stats_lignees$afad_femtot[i] <- round(mean(li_fem$af, na.rm=T),1) + + stats_lignees$prol_femtot[i] <- round(mean(li_fem$prol, na.rm=T),1) + stats_lignees$mort_femtot[i] <- round(mean(li_fem$mort, na.rm=T),1) + stats_lignees$txvf_femtot[i] <- round(mean(li_fem$txvf, na.rm=T),1) + + stats_lignees$nbprod_femtot[i] <- round(sum(li_fem$nbdescendants),1) + stats_lignees$txrepros_femtot[i] <- round(mean(li_fem$txrepros, na.rm=T),1) + stats_lignees$nbpp_femtot[i] <- round(sum(li_fem$nbpp),1) + } + + # stats sur la prod par les fem actives ___________________________________ + li_fem_act <- subset(vachestot, vachestot$fondatrice == stats_lignees$fondatrice[i] + & is.na(vachestot$dasort)) + + # modif du 30/04/2024 + if (nrow(li_fem_act) > 0) { + stats_lignees$nbfemact_avecprod[i] <- nrow(li_fem_act) + stats_lignees$pctfemact_avecprod[i] <- round(nrow(li_fem_act) + / nrow(subset(li_prod, + li_prod$sexbov == '2')) + * 100, 1) + } + + if (nrow(li_fem_act) >= 3) { + stats_lignees$isu_femact[i] <- round(mean(li_fem_act$indisu, na.rm=T),1) + stats_lignees$age_sort_femact[i] <- round(mean(li_fem_act$age_years, na.rm=T),1) + stats_lignees$agevel1_femact[i] <- round(mean(li_fem_act$agevel1, na.rm=T),1) + stats_lignees$vieprod_femact[i] <- round(mean(li_fem_act$tempsprod, na.rm=T),1) + stats_lignees$ivv1_femact[i] <- round(mean(li_fem_act$ivv1, na.rm=T),1) + stats_lignees$ivv2p_femact[i] <- round(mean(as.numeric(li_fem_act$ivv2p), na.rm=T),1) + + stats_lignees$dmad_femact[i] <- round(mean(li_fem_act$dmC, na.rm=T),1) + stats_lignees$dsad_femact[i] <- round(mean(li_fem_act$ds, na.rm=T),1) + stats_lignees$afad_femact[i] <- round(mean(li_fem_act$af, na.rm=T),1) + + stats_lignees$prol_femact[i] <- round(mean(li_fem_act$prol, na.rm=T),1) + stats_lignees$mort_femact[i] <- round(mean(li_fem_act$mort, na.rm=T),1) + stats_lignees$txvf_femact[i] <- round(mean(li_fem_act$txvf, na.rm=T),1) + + stats_lignees$nbprod_femact[i] <- round(sum(li_fem_act$nbdescendants),1) + stats_lignees$txrepros_femact[i] <- round(mean(li_fem_act$txrepros, na.rm=T),1) + stats_lignees$nbpp_femact[i] <- round(sum(li_fem_act$nbpp),1) + } + # filles a venir + nbfr <- nrow(subset(inv_desc, + inv_desc$fondatrice == stats_lignees$fondatrice[i] + & inv_desc$nbdescendants == 0 + & inv_desc$sexbov == '2' + & inv_desc$actif == '1')) + if (nbfr > 0) { + stats_lignees$nbfem_renouv[i] <- nbfr + } +} + +fondatrices$anim <- trim_str(fondatrices$anim) +stats_lignees$fondatrice <- trim_str(stats_lignees$fondatrice) +stats_lignees <- merge(fondatrices[,c('anim', 'nobovi', 'danais', 'nomnais')], + stats_lignees, by.x='anim', by.y='fondatrice', all.x=F, all.y=T) + +write.table(stats_lignees, + file = paste(rep, '/', CHEP, '_ResLigneesF_eCow5.csv', sep = ""), + quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE, + sep = ";", qmethod = c("escape"), na = "") + +print("Fin du calcul des stats par lignée") + +################################################################################ +### trac? des lign?es sur PDF __________________________________________________ +################################################################################ + +# modif 27/03/2023 : +# déduction campagne en cours pour garder les femelles de renouvellement +# sans les laitonnes de la campagne en cours + +camp_actuelle = ifelse(month(Sys.Date()) %in% c('08','09','10','11','12'), + year(Sys.Date()) + 1, + year(Sys.Date())) + +fem_tot <- inv_desc %>% + filter(sexbov == '2' + & campn < camp_actuelle + & (nbdescendants > 0 | actif == '1')) + +# modif 27/03/2023 : +# modif de la valeur "actif" pour mettre en rouge les vaches actives ailleurs +fem_tot$actif <- ifelse(fem_tot$actif == '1' & trim_str(fem_tot$chepdet) == CHEP, '1', '0') + +fem_tot$anim <- trim_str(fem_tot$anim) +fem_tot$mere <- trim_str(fem_tot$mere) +fem_tot$pere <- trim_str(fem_tot$pere) +for (i in 1:nrow(fem_tot)) { + if (fem_tot$indite[i] == 'O') { + fem_tot$nobovi[i] <- paste(fem_tot$nobovi[i], ' (TE)', sep='') + } + if (fem_tot$nbdescendants[i] == 0) { + fem_tot$nobovi[i] <- fem_tot$nobovi[i] %>% tolower() + } + if (fem_tot$corabo[i] == '38'){ + fem_tot$corabo[i] <- 'CHAROLAISE' + } else { + fem_tot$corabo[i] <- 'CROISEE' + } + if (fem_tot$sexbov[i] == '2') { + fem_tot$sexbov[i] <- 'female' + } else if (fem_tot$sexbov[i] == '1'){ + fem_tot$sexbov[i] <- 'male'} + if (is.na(fem_tot$nobovi[i])){ + fem_tot$nobovi[i] <- paste(str_sub(fem_tot$anim[i], -4), + subset(LETTRES, LETTRES$ANNEE == fem_tot$campn[i])[1,'LETTRE'], sep='_') + } +} + +cla_rg <- tabfinal[,c('NUM_VACHE', 'rang CARRIERE')] +nbvcla <- nrow(subset(cla_rg, !is.na(cla_rg$`rang CARRIERE`))) +for(i in 1:nrow(cla_rg)) { + if (!is.na(cla_rg$`rang CARRIERE`[i])){ + cla_rg$`rang CARRIERE`[i] <- paste('eCow : ', cla_rg$`rang CARRIERE`[i], ' / ', nbvcla, sep='') + } else { + cla_rg$`rang CARRIERE`[i] <- 'eCow : NC' + } +} + +sub_ped <- fem_tot[,c('anim', 'pere', 'mere', 'sexbov', 'corabo', 'campn', 'actif', 'nobovi')] +sub_ped <- merge(sub_ped, cla_rg, by.x='anim', by.y='NUM_VACHE', all.x=T, all.y=T) +colnames(sub_ped)=c('Indiv','Sire','Dam','Sex','Breed','Born','Affected','Nom','ecowcarr') + +Pedig <- prePed(sub_ped) +for(i in 1:nrow(Pedig)) { + if (is.na(Pedig$ecowcarr[i])){ + Pedig$ecowcarr[i] <- '' + } + if (!is.na(Pedig$Sex[i]) & Pedig$Sex[i] == 'male'){ + toro <- subset(inv_desc, trim_str(inv_desc$pere) == Pedig$Indiv[i]) + Pedig$Nom[i] <- toro$nompere[1] + } + if (!is.na(Pedig$Sex[i]) & Pedig$Sex[i] == 'female' & is.na(Pedig$Nom[i]) ){ + mom <- subset(inv_desc, trim_str(inv_desc$mere) == Pedig$Indiv[i]) + Pedig$Nom[i] <- mom$nommere[1] + } +} + +dir.create(path=paste(rep, "/", CHEP, '_pdf_ligneesF', sep='')) +sousrep=paste(rep, "/" ,CHEP, '_pdf_ligneesF', sep='') + +fondatrices$anim <- trim_str(fondatrices$anim) +fondatrices <- subset(fondatrices, (fondatrices$nbdescendants > 0 | is.na(fondatrices$nbdescendants)) + & fondatrices$anim %in% trim_str(fem_tot$fondatrice)) + +if (nrow(fondatrices) > 0) { + for (i in 1:nrow(fondatrices)) { + print(fondatrices$anim[i]) + sPed <- subPed(Pedig, keep=fondatrices$anim[i], prevGen=0, succGen=10) + taille <- nrow(sPed) + print(taille) + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100, 1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)) { + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n') + } + tryCatch( + expr = { + if (nrow(sPed) > 1 & nbt > 0) { + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], '.pdf', sep='') + pdf(file = paste(sousrep, "/", nom, sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? a droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2, 2, 2, 5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == '1', "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 15, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette lignee representent ',tx2,"% des vaches en production du cheptel.",sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 20, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ',tx,"% des vaches actives de cette lignee appartiennent a la moitie superieure classee du cheptel.",sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + } + + if (taille >= 80){ + z <- subset(fem_tot, fem_tot$mere == fondatrices$anim[i]) + if (nrow(z) > 1){ + for (k in 1:nrow(z)){ + sPed <- subPed(Pedig, keep=z$anim[k], prevGen=0, succGen=10) + taille <- nrow(sPed) + + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100,1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)){ + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n') + } + + if (nrow(sPed) > 1 & nbt > 0){ + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], '_sl_', z$anim[k], '.pdf', sep='') + pdf(file = paste(sousrep, "/", nom, sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? a droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2,2,2,5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0, + paste('Sous-lignee : fille', z$nobovi[k], str_sub(z$anim[k], -4), sep=' '), + srt=270, cex=0.6, col='dark red', font=1) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette sous-lignee representent ', + tx2, "% des vaches en production du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ', tx, + "% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + + + if (taille >= 80){ + a <- subset(fem_tot, fem_tot$mere == z$anim[k]) + if (nrow(a) > 1){ + for (n in 1:nrow(a)){ + sPed <- subPed(Pedig, keep=a$anim[n], prevGen=0, succGen=10) + taille <- nrow(sPed) + + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100, 1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)){ + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j],-4), sPed$Nom[j], sep='\n') + } + + if (nrow(sPed) > 1 & nbt > 0){ + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], + '_ssl_', z$anim[k], '_', a$anim[n], '.pdf',sep='') + pdf(file = paste(sousrep,"/",nom,sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? ? droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2,2,2,5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0, + paste('Sous-lignee : petite-fille',a$nobovi[n], str_sub(a$anim[n],-4),sep=' '), + srt=270, cex=0.6, col='dark red', font=1) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette sous-lignee representent ', + tx2, "% des vaches en production du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ', tx, + "% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + } + } + } + } + + } + } + } else { + w <- subset(fem_tot, fem_tot$mere == z$anim[1]) + if (nrow(w) > 1){ + for (m in 1:nrow(w)){ + sPed <- subPed(Pedig, keep=w$anim[m], prevGen=0, succGen=10) + taille <- nrow(sPed) + + nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv)) + nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2))) + tx <- round(nb / nbt * 100, 1) + tx2 <- round(nbt / nrow(vaches) * 100, 1) + + if (taille <= 20) {ecr <- 0.5} + else if (taille > 20 & taille <= 50) {ecr <- 0.4} + else if (taille > 50 & taille <= 100){ecr <- 0.3} + else if (taille > 100 & taille <= 150){ecr <- 0.2} + else {ecr <- 0.1} + + for (j in 1:nrow(sPed)){ + #sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4) + #sPed$Sire[j]=str_sub(sPed$Sire[j],-4) + #sPed$Dam[j]=str_sub(sPed$Dam[j],-4) + sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n') + } + + if (nrow(sPed) > 1 & nbt > 0){ + nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], + '_ssl_', w$anim[m], '.pdf', sep='') + pdf(file = paste(sousrep, "/", nom, sep=""), + width = 29.5, height = 21, pointsize = 50) + pedplot(sPed, + label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures + symbolsize=0.6, + pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? ? droite + cex=ecr, # taille d'?criture + branch=0.8, # lignes verticales adoucies + srt=-90, # angle d'orientation du texte + mar=c(2,2,2,5), # marges + lwd=5, # epaisseur des traits --> ne marche pas + col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red"))) + corners <- par("usr") + par(xpd=TRUE) + text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0, + paste(paste(CHEP, vaches$nomdete[1], sep=' - '), + paste('Lign?e :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'), + srt=270, cex=0.8, col='dark red', font=2) + text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0, + paste('Sous-lignee : petite-fille', w$nobovi[m], str_sub(w$anim[m], -4), sep=' '), + srt=270, cex=0.6, col='dark red', font=1) + text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1, + c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'), + srt=270, cex=0.3) + text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5, + paste('Les vaches actives de cette sous-lignee representent ', + tx2, "% des vaches en production du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green') + text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5, + paste('Synthese eCow : ', tx, + "% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''), + srt=270, cex=0.5, col='dark green', font=2) + grid.raster(img, x=0.05, y=0.1, width=0.05) + dev.off() + } + } + } + + } + } + }, + error = function(erreur) { + print("Erreur tracé lignées") + } + ) + } +} + +contenu <- as.data.frame(list.files(paste0(rep, "/", CHEP, '_pdf_ligneesF'))) + +if (nrow(contenu) > 0) { + staple_pdf(input_directory = sousrep, + input_files = NULL, + output_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''), + overwrite = TRUE) + + rotate_pdf(page_rotation = 270, + input_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''), + output_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''), + overwrite = TRUE) +} + +unlink(paste(rep, '/', CHEP, '_pdf_ligneesF', sep=''), recursive=TRUE) + +new = Sys.time() - old +print(paste('Tracé des lignées femelles :', new, sep='')) + + +### g?n?ration du rapport HTML ################################################ + +# a revoir pour les petits cheptels +render_report(CHEP, TECH, date_imp) + +render_synthese(CHEP, TECH, date_imp) + +# # options DT : +# Par d?faut, l'option est dom = "lfrtip", pour +# l: length changing input control, contr?le d'affichage du nombre de lignes +# f: filtering input, widget de recherche / filtre des donn?es +# r: processing display element, permet l'application des filtres, tri, . (charg? par d?faut avec t) +# t: The table!, la table +# i: Table information summary, r?sum? du nombre d'entr?es +# p: pagination control, choix du num?ro de page affich?e +# # extensions : +# c("Scroller", "FixedColumns", "Buttons", "Select") +# 'Responsive' + +# temps total +NEW <- Sys.time() - OLD +print(paste("Temps total d'execution :", NEW, sep='')) + + +################################################################################ +### requete sur les cheptels ? rechercher pr?vus en tourn?e #################### +################################################################################ + +# itic <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcitic/finddatefieldbynamedquery/Hbcitic.findByPrevejo/" +# date_req <- Sys.Date() +# li_dates <- seq(as.Date(Sys.Date()), as.Date(Sys.Date()+7), by="days") +# +# itineraires <- fromJSON(paste(itic, "2021-06-11", sep=''))[0,] +# +# for (i in 1:length(li_dates)){ +# it <- fromJSON(paste(itic, li_dates[i], sep='')) +# itineraires <- bind_rows(itineraires, it) +# } + diff --git a/R/project/postprocessing.R b/R/project/postprocessing.R new file mode 100755 index 0000000..ab51c33 --- /dev/null +++ b/R/project/postprocessing.R @@ -0,0 +1,195 @@ +source(here::here("R/common/db_client.R")) + +save_or_return <- function(results, write_to_db = FALSE) { + if (isTRUE(write_to_db)) { + df <- as.data.frame(results, optional = TRUE) + status <- insert_results(df) + return(status) + } + results +} + +#' TODO voir ce qu'on retourne -> surement tableau de résultats, stockage en base géré dans une autre fonction +#' Met à jour les données éCow pour un cheptel +#' @param cheptel character. Code du cheptel avec le FR +#' @return A définir +maj_ecow_by_cheptel <- function(cheptel) { + list_chep <-list(cheptel) + + maj_ecow_for_list_cheptels(list_chep) +} + +#' Met à jour les données éCow pour tous les cheptels suivis par un technicien +#' @param tech character. Identifiant à 5 lettres du technicien +maj_ecow_by_tech <- function(tech) { + # On récupère tous les cheptels d'un technicien + cheps_tech <- get_cheptels_by_tech(tech) + # On en extrait la liste des numéros de cheptels suivi par le tech + list_chep <- as.list(cheps_tech$numeroCheptel) + + maj_ecow_for_list_cheptels(list_chep) +} + +#' Met à jour les données éCow pour tous les cheptels des adhérents actifs +maj_ecow_for_all <- function() { + # On récupère tous les adhérents dans Dolibarr + adh_hbc <- get_all_adherents_active() + # On en extrait la liste des numéros de cheptels + list_chep <- as.list(adh_hbc$Numchep) + + maj_ecow_for_list_cheptels(list_chep) +} + +mafonctiondetest <- function(cheptel){ + source("R/common/ws_client.R", local = TRUE) + server_path <- "http://localhost:8080/HbcSchedulerAndServices/" + url_active_by_chep <- paste0(server_path, "webresources/animals/findAnimalEcowByActiveCheptel/") + maliste <- http_get(url = paste0(url_active_by_chep, cheptel)) + return(lengths(maliste)) +} + +cheptels <- list("FR71499477", "FR71499477635", "FR71499477") + +#' 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){ + res <- lapply(cheptels, function(num_chep) { + tryCatch( + { + message(sprintf("→ Traitement cheptel %s ...", num_chep)) + out <- mafonctiondetest(num_chep) #' TODO MAJ avec la fonction de calcul globale + # out <- calcul_ecow_by_chep(num_chep) #' Appel de la fonction de calcul globale + message(sprintf("✓ OK cheptel %s : %s lignes", num_chep, ifelse(is.data.frame(out), nrow(out), NA_integer_))) + out + }, + error = function(e) { + # Log + continue + message(sprintf("✗ ERREUR cheptel %s : %s", num_chep, conditionMessage(e))) + NULL + }, + warning = function(w) { + # Tu peux décider de logger les warnings sans interrompre + message(sprintf("! AVERTISSEMENT cheptel %s : %s", num_chep, conditionMessage(w))) + invokeRestart("muffleWarning") # évite d’imprimer plusieurs fois le warning + } + ) + }) +} + +save_data_vaches <- function(vaches){ + tabfinal <- vaches %>% + select( + cheptelDetenteur, anim, nom, nom_pere, embryon, + 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", "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 %>% + mutate( + across( + where(is.character), + ~ str_replace_all(.x, ",", ".") + ), + isu = case_when( + isu == "O" ~ TRUE, + isu == "N" ~ FALSE, + TRUE ~ NA + ), + rang_carr = as.numeric(rang_carr) + ) + + con <- get_db_connection() + + dbWriteTable( + con, + Id(schema = "hbc", table = "ecow_vaches"), + tab_format, + append = TRUE, + row.names = FALSE + ) + dbDisconnect(con) +} + +save_data_campagne <- function(synth_camp){ + # Stockage des données écow_camp + filtered_prod_camp <- synth_camp %>% + select( + cheptel, numeroMipg, dateNaiss, rangVelageMipg, ecowcamp, nom_pere, produits + ) + + colnames(filtered_prod_camp) <- c( + "cheptel", "mere_ipg", "danais", "ravelamer_corr", "note_ecow", "pere", "produits" + ) + + con <- get_db_connection() + + dbWriteTable( + con, + Id(schema = "hbc", table = "ecow_campagne"), + filtered_prod_camp, + append = TRUE, + row.names = FALSE + ) + dbDisconnect(con) +} + +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, + 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 + ) + + colnames(filtered_taureaux) <- c( + "cheptel", "anim", "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" + ) + + filtered_taureaux$cheptel <- cheptel + + con <- get_db_connection() + + dbWriteTable( + con, + Id(schema = "hbc", table = "ecow_taureaux"), + filtered_taureaux, + append = TRUE, + row.names = FALSE + ) + dbDisconnect(con) +} + +save_data_lignees(stats_lignees){ + con <- get_db_connection() + + dbWriteTable( + con, + Id(schema = "hbc", table = "ecow_lignees"), + stats_lignees, + append = TRUE, + row.names = FALSE + ) + dbDisconnect(con) +} \ No newline at end of file diff --git a/R/project/preprocessing.R b/R/project/preprocessing.R new file mode 100755 index 0000000..6c89eff --- /dev/null +++ b/R/project/preprocessing.R @@ -0,0 +1,305 @@ +suppressPackageStartupMessages({ + library(tibble) + library(dplyr) + library(rlang) + library(purrr) +}) +source(here::here('R/common/utils.R')) + +#' Met en forme le tableau des produits des vaches +#' Ajoutes les colonnes nécessaires au calcul du rang ecow des vaches +#' @param produits_vaches dataframe. Tab des produits des vaches du cheptel +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 + parents_ipg <- get_parents_ipg() + liste_produits <- merge(liste_produits, get_parents_ipg(), by.x='anim', by.y='ANIM', all.x=T, all.y=F) + + # Calcul REPRO + liste_produits <- liste_produits %>% + mutate( + repro = case_when( + anim %in% czhbc$ANIM ~ "O", + !is.na(NBPRODIPG) & NBPRODIPG > 0 ~ "O", + nbFinGestation > 0 ~ "O", # TODO pas sure que ce soit la bonne variable + TRUE ~ NA_character_ + ) + ) %>% + # Calcul MORTALITÉ + mutate( + age_jours = as.numeric(difftime(dateSortDetenteur, dateNaiss, units = "days")), + mortnat = if_else( + !is.na(causeSortDetenteur) & causeSortDetenteur == "M" & + !is.na(age_jours) & age_jours < 3, + "O", + NA_character_ + ), + mortsev = if_else( + !is.na(causeSortDetenteur) & causeSortDetenteur == "M" & + !is.na(age_jours) & age_jours >= 3 & age_jours < 211, + "O", + NA_character_ + ), + ) %>% + select(-age_jours) # colonne intermédiaire à retirer si inutile +} + +#' Ajoute à un tableau de produits les valeurs corrigées par l'effet cheptel +#' @param produits dataframe. Tab des produits +apply_effet_chep <- function(produits){ + effets <- env_ecow$effets_chep %>% + select(sexe, typeMipg, diff_pn, diff_p120, diff_p210) + + # Associe les bons effets à chaque produit + produits <- produits %>% + left_join(effets, by = c("sexe", "typeMipg")) %>% + mutate( + nbpp_corr = if_else(sexe == "2", NBPRODIPG * env_ecow$rapport_MF, NBPRODIPG), + pn_corr = if_else(!is.na(poidsNaiss), poidsNaiss + diff_pn, NA_real_) + ) +} + +#' Normalisation des stats cheptel +#' 1 = max +norm_chep <- function(x, var) { + r <- stats_chep %>% dplyr::filter(var == !!var) + if (nrow(r) == 0) return(rep(NA_real_, length(x))) + mmin <- r$min[1]; mmax <- r$max[1] + 1 - (abs(mmax - x) / abs(mmax - mmin)) +} + +#' Calcul des statistiques pour les colonnes d'un tableau +get_stats_tbl <- function(tab, nom_tab, cols, conditions = NULL, nom_cond = NA) { + + # Si conditions présentes → filtrer + if (!is.null(conditions)) { + tab <- tab %>% filter(!! enquo(conditions)) + } + + # Pour chaque colonne → calculer les stats + map_df(cols, function(col) { + x <- tab[[col]] + + tibble( + var = paste0(nom_tab, "$", col), + cond = nom_cond, + min = round(min(as.numeric(x), na.rm = TRUE), 1), + q1 = round(quantile(as.numeric(x), 0.25, na.rm = TRUE), 1), + med = round(median(as.numeric(x), na.rm = TRUE), 1), + moy = round(mean(as.numeric(x), na.rm = TRUE), 1), + q3 = round(quantile(as.numeric(x), 0.75, na.rm = TRUE), 1), + max = round(max(as.numeric(x), na.rm = TRUE), 1), + nbval = sum(!is.na(as.numeric(x))), + nas = sum(is.na(as.numeric(x))) + ) + }) +} + +get_synth_prod_vaches <- function(vaches, produits){ + # On récupère les coefficients de pondération pour les pointages adultes + ppa <- env_ecow$params_ponderation$pointage$adulte + + # On récupère les coefficients de pondération pour les pointages au sevrage + pps <- env_ecow$params_ponderation$pointage$sevrage + + # ========================= + # 1) Synthèse veaux par mère + # ========================= + veaux_summary <- produits %>% + group_by(numeroMipg) %>% + summarise( + n_veaux = n(), + + # plage de campagnes velages (max - min + 1), robustes aux NA + campn_min = {cn <- campagneNaiss[!is.na(campagneNaiss)]; if (length(cn)) min(cn) else NA_integer_}, + campn_max = {cn <- campagneNaiss[!is.na(campagneNaiss)]; if (length(cn)) max(cn) else NA_integer_}, + nbcampvel = ifelse(!is.na(campn_min) & !is.na(campn_max), + campn_max - campn_min + 1, NA_integer_), + + # date du dernier anais (dernier événement) + last_danais = {d <- dateNaiss[!is.na(dateNaiss)]; if (length(d)) max(d) else as.Date(NA)}, + + # moyennes nécessaires pour ptgP et précocité + mean_devmus = mean(dmSevrage, na.rm = TRUE), + mean_devsqe = mean(dsSevrage, na.rm = TRUE), + mean_af = mean(afSevrage, na.rm = TRUE), + mean_diff_dev = mean(dsSevrage - dmSevrage, na.rm = TRUE), + + # indicateurs produits + mort = round((sum(mortsev == "O" | mortnat == "O", na.rm = TRUE)) / n_veaux * 100, 1), + txrepros = round(sum(repro == "O", na.rm = TRUE) / n_veaux * 100, 1), + nbpp = sum(NBPRODIPG, na.rm = TRUE), + nbpp_corr = if ("nbpp_corr" %in% names(.)) sum(nbpp_corr, na.rm = TRUE) else NA_real_, + txmales = round(sum(sexe == "1", na.rm = TRUE) / n_veaux * 100, 1), + txvf = round(sum(conditionNaiss %in% c("1","2"), na.rm = TRUE) / n_veaux * 100, 1), + + # moyennes par sexe + pn_m = round(mean(poidsNaiss[sexe == "1"], na.rm = TRUE), 1), + p120_m = round(mean(pat120[sexe == "1"], na.rm = TRUE), 1), + p210_m = round(mean(pat210[sexe == "1"], na.rm = TRUE), 1), + pn_f = round(mean(poidsNaiss[sexe == "2"], na.rm = TRUE), 1), + p120_f = round(mean(pat120[sexe == "2"], na.rm = TRUE), 1), + p210_f = round(mean(pat210[sexe == "2"], na.rm = TRUE), 1), + + # versions corrigées + pn_corr = if ("pn_corr" %in% names(.)) round(mean(pn_corr, na.rm = TRUE), 1) else NA_real_, + p120_corr = round(mean(pat120Corrige, na.rm = TRUE), 1), + p210_corr = round(mean(pat210Corrige, na.rm = TRUE), 1), + .groups = "drop" + ) + + # ========================= + # 2) Jointure & calculs vaches + # ========================= + v_ref <- vaches %>% + left_join(veaux_summary, by = c("anim" = "numeroMipg")) %>% + mutate( + + # pointage adulte synthétique + ptgV = ifelse(!is.na(dmcAdulte), round(ppa$dmC * dmcAdulte + ppa$ds * dsAdulte + ppa$af * afAdulte, 1), NA_real_), + + # précocité & alpha + precocite = ifelse(!is.na(n_veaux) & n_veaux > 3, round(mean_diff_dev, 2), NA_real_), # TODO à voir pour changer la formule de précocité avec LJ + alpha = ifelse(is.na(precocite), 1.62, 1.62 - 0.01 * precocite), # TODO A MAJ + + # estimation du poids adulte (pad) + pad = dplyr::case_when( # TODO rajouter paramètre cohérence des données, créer max et min + !is.na(pat24M) ~ round((pat24M - 50 * exp(-720 * alpha * 10^(-3))) / (1 - exp(-720 * alpha * 10^(-3))), 1), + !is.na(pat18M) ~ round((pat18M - 50 * exp(-540 * alpha * 10^(-3))) / (1 - exp(-540 * alpha * 10^(-3))), 1), + !is.na(pat12M) ~ round((pat12M - 50 * exp(-360 * alpha * 10^(-3))) / (1 - exp(-360 * alpha * 10^(-3))), 1), + TRUE ~ NA_real_ + ), + + # temps improductif (e2, e3, e4) + e2 = dplyr::case_when( + is.na(ivv1) ~ 0, + ivv1 < 390 ~ 0, + TRUE ~ ivv1 - 390 + ), + e3 = dplyr::case_when( + is.na(ivv2Brut) ~ 0, # TODO voir avec Lauréna si on prend ajust ou brut + ivv2Brut < 365 ~ 0, + TRUE ~ ivv2Brut - 365 + ), + days_since_last = as.numeric(difftime(Sys.Date(), last_danais, units = "days")), + e4 = dplyr::case_when( + is.na(days_since_last) ~ 0, + days_since_last < 365 ~ 0, + TRUE ~ days_since_last - 365 + ), + + # temps productif (%) + age_days = time_length( interval( dateNaiss, Sys.Date() ), "days" ), + age_years = round(age_days / 365, 1), + tempsprod = round( (age_days - (agevel1 * 30.4 + e2 + e3 * (nbcampvel - 2) + e4)) / age_days * 100, 1 ), + + # prolificité + prol = round(n_veaux / nbcampvel * 100, 1), + + # pointage produits + ptgP = round(pps$devmus * mean_devmus + pps$devsqe * mean_devsqe + pps$af * mean_af, 1) + ) %>% + # Conversion des NaN en NA sur certaines moyennes + mutate(across( + 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_, .) + )) + + # ========================= + # 3) Normalisations + # ========================= + v_norm <- v_ref %>% + mutate( + # age au 1er vêlage normalisé + agevel1_n = dplyr::case_when( + is.na(agevel1) ~ NA_real_, + agevel1 > 48 ~ 0, + TRUE ~ round( + -2 * (10^(-6)) * (agevel1 * 30.4)^2 + + 0.0027 * (agevel1 * 30.4) + + 8 * (10^(-15)), + 3 + ) + ), + # ivv1 normalisé + ivv1_n = dplyr::case_when( + is.na(ivv1) ~ NA_real_, + ivv1 > 460 ~ 0, + ivv1 < 390 ~ 1, + TRUE ~ round(1 - abs(390 - ivv1) / abs(390 - 460), 3) + ), + # ivv2+ normalisé + ivv2p_n = dplyr::case_when( + is.na(ivv2Brut) | is.nan(ivv2Brut) ~ NA_real_, + ivv2Brut > 435 ~ 0, + ivv2Brut < 365 ~ 1, + TRUE ~ round(1 - abs(365 - ivv2Brut) / abs(365 - 435), 3) + ), + # normalisations "cheptel 1 = max" + pad_n = round(norm_chep(pad, "vaches$pad"), 3), + ptgv_n = round(norm_chep(ptgV, "vaches$ptgV"), 3), + txvf_n = round(norm_chep(txvf, "vaches$txvf"), 3), + txm_n = round(norm_chep(txmales, "vaches$txmales"), 3), + txrepros_n = round(norm_chep(txrepros, "vaches$txrepros"), 3), + nbpp_n = round(norm_chep(nbpp_corr, "vaches$nbpp_corr"), 3), + ptgp_n = round(norm_chep(ptgP, "vaches$ptgP"), 3), + p120_n = round(norm_chep(p120_corr, "vaches$p120_corr"), 3), + p210_n = round(norm_chep(p210_corr, "vaches$p210_corr"), 3), + + # prolificité + prol_n = dplyr::case_when( + is.na(prol) ~ NA_real_, + prol >= 100 ~ 1, + prol < 50 ~ 0, + TRUE ~ round(1 - (abs(100 - prol) / abs(100 - 50)), 3) + ), + + # poids naissance corrigé + pn_n = dplyr::case_when( + is.na(pn_corr) ~ NA_real_, + 40 < pn_corr & pn_corr < 50 ~ 1, + 22 > pn_corr | pn_corr > 68 ~ 0, + 22 < pn_corr & pn_corr < 40 ~ round(0.056 * (pn_corr - 22), 3), + TRUE ~ round(1 - 0.056 * (pn_corr - 50), 3) + ), + + # mortalité + mort_n = round(1.0 * exp(-0.031 * mort), 3) + ) + + # ========================= + # 4) 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(env_ecow$params_ponderation$carriere, 1) + + v_final <- v_norm %>% + rowwise() %>% + mutate( + SOMME_tot = { + x <- c_across(all_of(names(weights))) + w <- weights + mask <- !is.na(x) & !is.na(w) & + is.finite(x) & is.finite(w) & + w != 0 + + if (sum(mask) == 0) { + NA_real_ + } else { + weighted.mean(x[mask], w[mask]) * 10 + } + }, + ecowcarr = if_else( + is.na(ptgp_n) & is.na(p120_n) & is.na(p210_n), # règle d'exclusion VA4 : si pas ces trois valeurs ça enlève 1/4 de la note -> pas classable, voir pour créer une alternative pour éleveurs + NA_real_, + round(SOMME_tot * 100, 0) + ) + ) %>% + ungroup() + + v_final <- v_final %>% + mutate( + rg_carr = as.integer(rank(1 / ecowcarr, na.last="keep")) + ) +} + diff --git a/README.md b/README.md new file mode 100755 index 0000000..a276898 --- /dev/null +++ b/README.md @@ -0,0 +1,30 @@ +# r-microservice — Squelette de microservice R (Plumber) + +Ce projet expose des fonctions R via une API REST **Plumber**, avec: +- des **fonctions génériques** réutilisables (HTTP, DB, utils, logs), +- des **fonctions spécifiques** au projet (prétraitement, calculs, post-traitement), +- un **endpoint** `/compute` permettant soit de **renvoyer un résultat**, soit **d'insérer en base** et retourner un **code retour**. + +## Lancer en local +```bash +Rscript scripts/run.R +# Puis: http://localhost:8080/health +``` + +## Exemple d'appel +```bash +curl -s -X POST http://localhost:8080/compute -H 'Content-Type: application/json' -d '{"values":[10,12,15,20], "write_to_db": false}' | jq +``` + +## Docker +```bash +docker build -t r-microservice . +docker run -p 8080:8080 --rm r-microservice +``` + +> Pour les insertions en base, configurez `config/config.yml` avec vos paramètres Postgres. + +## Tests +```r +testthat::test_dir('tests/testthat') +``` diff --git a/config/config.yml b/config/config.yml new file mode 100755 index 0000000..42e79bf --- /dev/null +++ b/config/config.yml @@ -0,0 +1,7 @@ +default: + database: + host: "db" + port: 5432 + dbname: "analytics" + user: "user" + password: "password" diff --git a/config/logging.yml b/config/logging.yml new file mode 100755 index 0000000..98a5215 --- /dev/null +++ b/config/logging.yml @@ -0,0 +1,2 @@ +level: INFO +# Placeholder: à brancher si vous intégrez un vrai framework de logs diff --git a/r-microservice.Rproj b/r-microservice.Rproj new file mode 100755 index 0000000..8e3c2eb --- /dev/null +++ b/r-microservice.Rproj @@ -0,0 +1,13 @@ +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX diff --git a/scripts/run.R b/scripts/run.R new file mode 100755 index 0000000..251be56 --- /dev/null +++ b/scripts/run.R @@ -0,0 +1,13 @@ +# Lancement du service Plumber +suppressPackageStartupMessages({ + library(plumber) + #library(plumber2) + library(here) + }) + +pr <- plumb(here("R", "api", "plumber.R")) +options(plumber.debug = TRUE) +pr$run( + host = "0.0.0.0", + port = as.integer(Sys.getenv("PORT", "8000")) +) diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100755 index 0000000..9f83255 --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,26 @@ +# Exécuter tous les tests avec: testthat::test_dir('tests/testthat') +library(testthat) +test_dir('tests/testthat') + +source(here::here("R/project/ecow_calculations.R")) + +# 1 pour juste vaches, 2 = vaches + taureaux, 3 = vaches + taureaux + lignees +calcul_ecow_by_chep('FR03142115', 1) # DIDOU +calcul_ecow_by_chep('FR71499477', 1) # JEANNOT +calcul_ecow_by_chep('FR71082042', 1) # test embryons +calcul_ecow_by_chep('FR03320016', 1) # MICAUD + +# Cheptels tests éCow +calcul_ecow_by_chep('FR49373240', 1) #21s +calcul_ecow_by_chep('FR79296901', 1) #25s +calcul_ecow_by_chep('FR42338149', 1) #21s +calcul_ecow_by_chep('FR71424024', 1) #11s +calcul_ecow_by_chep('FR71499477', 1) #13s +calcul_ecow_by_chep('FR58123075', 1) #24s +calcul_ecow_by_chep('FR71531193', 1) #29s +calcul_ecow_by_chep('FR12124049', 1) #24s +calcul_ecow_by_chep('FR69262063', 1) #22s +calcul_ecow_by_chep('FR72154002', 1) #21 + + + diff --git a/tests/testthat/test_calculs.R b/tests/testthat/test_calculs.R new file mode 100755 index 0000000..ecf0419 --- /dev/null +++ b/tests/testthat/test_calculs.R @@ -0,0 +1,9 @@ +suppressPackageStartupMessages({ library(testthat) }) +source(file.path('R','project','calculations.R'), local = TRUE) + +test_that('compute_metrics calcule correctement la moyenne', { + df <- data.frame(value = c(1,2,3,4)) + res <- compute_metrics(df) + expect_equal(res$mean, 2.5) + expect_equal(res$n, 4) +}) diff --git a/tests/testthat/test_db.R b/tests/testthat/test_db.R new file mode 100755 index 0000000..4d4c6a2 --- /dev/null +++ b/tests/testthat/test_db.R @@ -0,0 +1,3 @@ +# Placeholder pour tests DB (mockez ou utilisez une DB de test) +suppressPackageStartupMessages({ library(testthat) }) +test_that('placeholder db', { expect_true(TRUE) }) diff --git a/tests/testthat/test_ws.R b/tests/testthat/test_ws.R new file mode 100755 index 0000000..704f4d8 --- /dev/null +++ b/tests/testthat/test_ws.R @@ -0,0 +1,3 @@ +# Placeholder pour tests de webservices génériques +suppressPackageStartupMessages({ library(testthat) }) +test_that('placeholder ws', { expect_true(TRUE) })