RProjects/R/common/ws_client.R

#' 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=''), show_col_types = FALSE)
  colnames(meresIPG) <- c('ANIM','NBPRODIPG')
  
  peresIPG <- read_csv(paste(rep_imp, "nb_prod_IPG_byPERE_20260106.csv", sep=''), show_col_types = FALSE)
  colnames(peresIPG) <- c('ANIM','NBPRODIPG')
  
  parentsIPG <- rbind(meresIPG, peresIPG) 
}