lea/RProjects
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Mise en place projet R

Browse Source
This commit is contained in:
Léa
2026-06-08 16:16:27 +02:00
commit 265e5f1db6
27 changed files with 12697 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
.Rprofile
Executable
+3
View File
@@ -0,0 +1,3 @@
options(stringsAsFactors = FALSE)
# Réduire le bruit de readr si utilisé plus tard
options(readr.show_col_types = FALSE)
.gitignore
Executable
+12
View File
@@ -0,0 +1,12 @@
.Rhistory
.RData
.Rproj.user/
.Renviron
.Ruserdata
.DS_Store
*.log
*/.DS_Store
.Rproj.user
.httr-oauth
.quarto
.positai
DESCRIPTION
Executable
+9
View File
@@ -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
Dockerfile
Executable
+13
View File
@@ -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"]
R/api/plumber.R
Executable
+47
View File
@@ -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/<cheptel>
#' @param cheptel:number
#' @serializer unboxedJSON
maj_ecow_chep <- function(cheptel) {
maj_ecow_by_cheptel(cheptel)
}
#' @get /ecow/tech/<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()
}
R/common/db_client.R
Executable
+29
View File
@@ -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))
})
}
R/common/logging.R
Executable
+13
View File
@@ -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, ...)))
}
R/common/prepare_data.R
Executable
+101
View File
@@ -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)
}
R/common/utils.R
Executable
+12
View File
@@ -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)
}
R/common/ws_client.R
Executable
+225
View File
@@ -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)
}
R/notes.R
+210
View File
@@ -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 ####################################################################
R/project/Untitled.R
Executable
+7
View File
@@ -0,0 +1,7 @@
# fichier à supprimer, fonction test pour mise en place de l'api
ma_fonction <- function() {
list(
status = "youhou",
time = Sys.time()
)
}
R/project/ecow_calculations.R
Executable
+523
View File
@@ -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")
}
R/project/old_commente.R
Executable
+3746
View File
File diff suppressed because it is too large Load Diff
R/project/old_ecow_general.R
Executable
+3705
View File
File diff suppressed because it is too large Load Diff
R/project/old_ecow_individuel.R
Executable
+3436
View File
File diff suppressed because it is too large Load Diff
R/project/postprocessing.R
Executable
+195
View File
@@ -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)
}
R/project/preprocessing.R
Executable
+305
View File
@@ -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"))
)
}
README.md
Executable
+30
View File
@@ -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')
```
config/config.yml
Executable
+7
View File
@@ -0,0 +1,7 @@
default:
database:
host: "db"
port: 5432
dbname: "analytics"
user: "user"
password: "password"
config/logging.yml
Executable
+2
View File
@@ -0,0 +1,2 @@
level: INFO
# Placeholder: à brancher si vous intégrez un vrai framework de logs
r-microservice.Rproj
Executable
+13
View File
@@ -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
scripts/run.R
Executable
+13
View File
@@ -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"))
)
tests/testthat.R
Executable
+26
View File
@@ -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
tests/testthat/test_calculs.R
Executable
+9
View File
@@ -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)
})
tests/testthat/test_db.R
Executable
+3
View File
@@ -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) })
tests/testthat/test_ws.R
Executable
+3
View File
@@ -0,0 +1,3 @@
# Placeholder pour tests de webservices génériques
suppressPackageStartupMessages({ library(testthat) })
test_that('placeholder ws', { expect_true(TRUE) })