lea/RProjects
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
0a6cb5fc957b29d1afcf333e3a50b25c16bc5938
RProjects/R/project/old_ecow_individuel.R
T
lea 265e5f1db6 Mise en place projet R
2026-06-08 16:16:27 +02:00

3437 lines
155 KiB
R
Executable File
Raw Blame History

# 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)
# }
Reference in New Issue View Git Blame Copy Permalink