Mise en place projet R

2026-06-08 16:16:27 +02:00
commit 265e5f1db6
27 changed files with 12697 additions and 0 deletions
@@ -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))
+  })
+}
@@ -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, ...)))
+  }
@@ -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)
+}
@@ -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)
+}
@@ -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) 
+}