3706 lines
178 KiB
R
Executable File
3706 lines
178 KiB
R
Executable File
|
|
# version finale eCow - 5eme calcul
|
|
# LJ - 01/07/2021
|
|
|
|
################################################################################
|
|
### chgt des libraries #########################################################
|
|
################################################################################
|
|
|
|
library(tidyverse)
|
|
library(lubridate)
|
|
library(jsonlite)
|
|
|
|
library(optiSel)
|
|
library(staplr)
|
|
library(png)
|
|
library(grid)
|
|
|
|
options(scipen = 999) #permet d'?crire les nombres en entier quand ils sont au format scientifique
|
|
# necessaire pour la convertion des dates au format unix
|
|
|
|
################################################################################
|
|
### chgt des fichiers et donn?es utiles ########################################
|
|
################################################################################
|
|
|
|
rep_exp <- "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/EXPORTS_2/"
|
|
|
|
rep_imp <- "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/IMPORTS_R/"
|
|
|
|
date_imp <- as.Date("2025-06-18")
|
|
|
|
adhhbc <- read_delim(paste(rep_imp, "adhhbc_20250618.csv", sep=''), # ok 20230327
|
|
";", escape_double = FALSE, trim_ws = TRUE)
|
|
|
|
czhbc <- read_csv(paste(rep_imp, "cz_20250618.csv", sep='')) # ok 20230327
|
|
|
|
LETTRES <- read_delim(paste(rep_imp, "LETTRES.csv", sep=''),
|
|
";", escape_double = FALSE, trim_ws = TRUE)
|
|
|
|
indite <- read_csv(paste(rep_imp, "indite_20250618.csv", sep=''), # ok 20230327
|
|
col_types = cols(DANAIS = col_date(format = "%Y-%m-%d")))
|
|
indite <- indite[-which(duplicated(indite$ANIM)),]
|
|
#$indite <- subset(indite, !is.na(indite$MEREIPG))
|
|
|
|
meresIPG <- read_csv(paste(rep_imp, "nbprodIPG_byMERE_20250618.csv", sep='')) # ok 20230327
|
|
colnames(meresIPG) <- c('ANIM','NBPRODIPG')
|
|
|
|
peresIPG <- read_csv(paste(rep_imp, "nbprodIPG_byPERE_20250618.csv", sep='')) # ok 20230327
|
|
colnames(peresIPG) <- c('ANIM','NBPRODIPG')
|
|
|
|
parentsIPG <- rbind(meresIPG, peresIPG)
|
|
|
|
### liste des webservices ######################################################
|
|
|
|
# appel du listing d'un cheptel
|
|
webappli <- "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/findbyactivecheptel/"
|
|
|
|
# appel de l'IC pour un animal
|
|
hbcanim <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/"
|
|
|
|
# appel de hbcgene pour un animal
|
|
hbcgene <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcgene/"
|
|
|
|
# liste des produits d'une vache
|
|
reqMere <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/findstringfieldbynamedquery/Hbcanim.findByMere/"
|
|
|
|
# liste des produits d'un taureau
|
|
reqPere <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcanim/findstringfieldbynamedquery/Hbcanim.findByPere/"
|
|
|
|
# liste des produits d'un animal n?s dans un cheptel cible
|
|
reqProdNaiss <- "https://tomcat.herdbookcharolais.com/HbcSchedulerAndServices-2.0-SNAPSHOT/webresources/animals/findProductByAnimAndChna/"
|
|
# ? completer par anim/chna, ex : FR7121831530/FR71499477
|
|
|
|
#_______________________________________________________________PONDERATIONS AHP
|
|
## Ponderations Carriere ####
|
|
Pcar=data.frame(type='final', agevel1_n=3, ivv1_n=6, ivv2p_n=12,
|
|
ptgv_n=4, pad_n=2, prol_n=2, mort_n=12,
|
|
txrepros_n=8, nbpp_n=10, txm_n=1, txvf_n=10,
|
|
ptgp_n=6, pn_n=4, p120_n=10, p210_n=10)
|
|
|
|
### Ponderations Campagne ####
|
|
Pcamp=rbind(data.frame(type='AHPtech', pn_n=5.3, txvf_n=14.9, txm_n=4.5,
|
|
ptgp_n=8.2, p120_n=15.1, p210_n=12.6,
|
|
prol_n=3.2, mort_n=19.9, ivv_n=16.2),
|
|
data.frame(type='final', pn_n=6, txvf_n=15, txm_n=1,
|
|
ptgp_n=9, p120_n=15, p210_n=15,
|
|
prol_n=3, mort_n=18, ivv_n=18))
|
|
# pond?rations finales ajustees ? partir de l'enquete
|
|
# peut etre pas judicieux
|
|
|
|
################################################################################
|
|
### fonctions utiles ###########################################################
|
|
################################################################################
|
|
|
|
# suppression des espaces superflus
|
|
trim_str = function (string) {
|
|
gsub("\\s+", " ", gsub("^\\s+|\\s+$", "", string))
|
|
}
|
|
|
|
# recuperation de l'inventaire des animaux actifs du cheptel
|
|
get_inventaire <- function(cheptel) {
|
|
old <- Sys.time()
|
|
# liste des animaux du cheptel
|
|
lichep <- fromJSON(paste(webappli, cheptel, sep=''))
|
|
inventaire <- lichep$hbcanim
|
|
# calcul du temps de chargement
|
|
new <- Sys.time()-old
|
|
cat("Chargement de l'inventaire :", round(new, 1) , "sec \n")
|
|
# resultat
|
|
return(inventaire)
|
|
}
|
|
|
|
# mise en forme d'un retour de WS sous forme de dataframe
|
|
# necessaire quand l'appel ne concerne qu'un animal car le retour est une liste nomm?e
|
|
appel_infos <- function(animal, url_ws, cheptel = NA) {
|
|
animal <- trim_str(animal)
|
|
if (!is.na(cheptel)) {
|
|
li_anim <- try(fromJSON(paste(url_ws, animal, '/', cheptel, sep = '')), silent = TRUE)
|
|
} else {
|
|
li_anim <- try(fromJSON(paste(url_ws, animal, sep = '')), silent = TRUE)
|
|
}
|
|
if (inherits(li_anim, "try-error")) {
|
|
return(NA)
|
|
} else {
|
|
if (class(li_anim) == "list" & length(li_anim) > 0) {
|
|
li_anim[sapply(li_anim, function(x) length(x) == 0L)] <- NA
|
|
df_anim <- as.data.frame(t(unlist(li_anim)))
|
|
return(df_anim)
|
|
} else if (class(li_anim) == "data.frame") {
|
|
return(li_anim)
|
|
}
|
|
}
|
|
}
|
|
|
|
# appel des donnees anim en fonction de leur existance
|
|
# si animal absent de hbcanim, on va voir dans hbcgene
|
|
chgt_infos <- function(animal) {
|
|
# on va chercher la ligne animal dans hbcanim
|
|
line_anim <- try(appel_infos(animal, hbcanim), silent = TRUE)
|
|
# Si erreur, on va chercher dans hbcgene
|
|
if (!is.data.frame(line_anim) | inherits(line_anim, "try-error")) {
|
|
line_anim <- appel_infos(animal, hbcgene)
|
|
}
|
|
return(line_anim)
|
|
}
|
|
|
|
# fonction de cr?ation d'un dataframe vide
|
|
create_df <- function(nbl, liste_nomcol){
|
|
new <- data.frame(matrix(NA, ncol=length(liste_nomcol), nrow=nbl))
|
|
colnames(new) <- liste_nomcol
|
|
return(new)
|
|
}
|
|
|
|
get_stats <- function(tab, nom_tab, col,conditions, nom_cond) {
|
|
if (missing(conditions) & missing(nom_cond)) {
|
|
x <- tab
|
|
nom_cond <- NA
|
|
} else {
|
|
x <- subset(tab, conditions)
|
|
}
|
|
min <- round(min(x[,col], na.rm=TRUE), 1)
|
|
q1 <- round(quantile(x[[col]], probs=0.25, na.rm=TRUE), 1)
|
|
med <- round(median(x[[col]], na.rm=TRUE), 1)
|
|
moy <- round(mean(x[[col]], na.rm=TRUE), 1)
|
|
q3 <- round(quantile(x[[col]], probs=0.75, na.rm=TRUE), 1)
|
|
max <- round(max(x[,col], na.rm=TRUE), 1)
|
|
nbval <- nrow(subset(x, is.na(x[,col]) == FALSE))
|
|
nas <- nrow(subset(x, is.na(x[,col]) == TRUE))
|
|
tab_col <- as.character(paste(nom_tab, col, sep='$'))
|
|
sc <- data.frame('var'=tab_col, 'cond'=nom_cond, 'min'=min, 'q1'=q1,
|
|
'med'=med, 'moy'=moy, 'q3'=q3, 'max'=max, 'nbval'=nbval, 'nas'=nas)
|
|
rownames(sc) <- ''
|
|
return(sc)
|
|
}
|
|
|
|
# fonction de recuperation des produits d'un taureau
|
|
# recup annul?e si taureau d'IA avec bcp de produits ie >275
|
|
get_produits_taureau <- function(animal) {
|
|
old <- Sys.time()
|
|
anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ###
|
|
if (!is.na(anim) & (class(anim) == "try-error") == FALSE) { # _______________________________
|
|
if (anim$sexbov[1] == '1') {
|
|
if (as.numeric(anim$nbdescendants[1]) >= 275 & anim$taureauia[1] == '1') {
|
|
produits <- NA
|
|
cat("\n", "Produits non charg?s car taureau d'IA avec production superieure ? 275")
|
|
} else if ( (as.numeric(anim$nbdescendants[1]) > 0
|
|
& anim$taureauia[1] == '0') |
|
|
(as.numeric(anim$nbdescendants[1]) < 275
|
|
& anim$taureauia[1] == '1') ) {
|
|
produits <- try(appel_infos(animal, reqPere), silent=TRUE) ###
|
|
if ((class(produits) == "try-error") == TRUE){
|
|
cat("\n", "Produits non charg?s car non disponibles")
|
|
produits <- NA
|
|
} else {
|
|
new <- Sys.time() - old
|
|
cat("\n", "Chargement des produits :", round(new, 1) , "sec")
|
|
}
|
|
} else {
|
|
produits <- NA
|
|
cat("\n", "???")
|
|
}
|
|
} else {
|
|
produits <- NA
|
|
cat("\n", "L'animal n'est pas un m?le")
|
|
}
|
|
} else if ((class(anim) == "try-error") == TRUE) { # _________________________
|
|
cat("\n", "P?re sans ligne individuelle dans HBCANIM")
|
|
produits <- try(appel_infos(animal, reqPere), silent = TRUE) ###
|
|
if ((class(produits) == "try-error") == TRUE){
|
|
produits <- NA
|
|
cat("\n", "Produits non charg?s car non disponibles")
|
|
} else {
|
|
new <- Sys.time() - old
|
|
cat("\n", "Chargement des produits :", round(new, 1) , "sec")
|
|
}
|
|
}
|
|
return(produits)
|
|
}
|
|
|
|
# fonction de recuperation des produits d'une vache
|
|
get_produits_vache <- function(animal) {
|
|
old <- Sys.time()
|
|
anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ###
|
|
if ((class(anim) == "try-error") == FALSE) { # _______________________________
|
|
if (anim$sexbov[1] == '2') {
|
|
produits <- try(appel_infos(animal, reqMere), silent=TRUE) ###
|
|
if ((class(produits) == "try-error") == TRUE){
|
|
cat("\n", "Produits non charg?s car non disponibles")
|
|
produits <- NA
|
|
} else {
|
|
new <- Sys.time() - old
|
|
cat("\n", "Chargement des produits :", round(new, 1) , "sec")
|
|
}
|
|
} else {
|
|
produits <- NA
|
|
cat("\n", "L'animal n'est pas une femelle")
|
|
}
|
|
} else if ((class(anim) == "try-error") == TRUE) { # _________________________
|
|
produits <- try(appel_infos(animal, reqMere), silent = TRUE) ###
|
|
if ((class(produits) == "try-error") == TRUE){
|
|
produits <- NA
|
|
cat("\n", "Produits non charg?s car non disponibles")
|
|
} else {
|
|
new <- Sys.time() - old
|
|
cat("\n", "Chargement des produits :", round(new, 1) , "sec")
|
|
}
|
|
}
|
|
return(produits)
|
|
}
|
|
|
|
# fonction de recuperation des produits d'un animal dans un cheptel naisseur
|
|
get_produits_in_chep <- function(animal, cheptel) {
|
|
old <- Sys.time()
|
|
anim <- try(appel_infos(trim_str(animal), hbcanim), silent = TRUE) ###
|
|
if ((class(anim) == "try-error") == FALSE) { # _______________________________
|
|
produits <- try(appel_infos(animal, reqProdNaiss, cheptel), silent=TRUE) ###
|
|
if ((class(produits) == "try-error") == TRUE){
|
|
cat("\n", "Produits non charg?s car non disponibles")
|
|
produits <- NA
|
|
} else {
|
|
new <- Sys.time() - old
|
|
cat("\n", "Chargement des produits :", round(new, 1) , "sec")
|
|
}
|
|
} else if ((class(anim) == "try-error") == TRUE) { # _________________________
|
|
produits <- try(appel_infos(animal, reqMere), silent = TRUE) ###
|
|
if ((class(produits) == "try-error") == TRUE){
|
|
produits <- NA
|
|
cat("\n", "Produits non charg?s car non disponibles")
|
|
} else {
|
|
new <- Sys.time() - old
|
|
cat("\n", "Chargement des produits :", round(new, 1) , "sec")
|
|
}
|
|
}
|
|
return(produits)
|
|
}
|
|
|
|
# fonction de modif des formats dates à partir du retour d'un WS
|
|
change_format_date_unix <- function(dataframe) {
|
|
if (is.data.frame(dataframe)){
|
|
# recup des indices de colonnes de dates : commencent par 'da' ou 'DA'
|
|
li_ix_dates <- c(grep("^da", colnames(dataframe)))
|
|
if (length(li_ix_dates) == 0){
|
|
li_ix_dates <- c(grep("^DA", colnames(dataframe)))
|
|
}
|
|
# si existance de colonnes de dates :
|
|
if (length(li_ix_dates) > 0) {
|
|
for(j in li_ix_dates) {
|
|
# on recupere les valeurs non nulles
|
|
not_na <- c(which(!is.na(dataframe[,j])))
|
|
if(length(not_na) > 0) {
|
|
# on verifie que c'est bien un format UNIX
|
|
if ( dataframe[not_na[1],j] > 1*(10**8) ) {
|
|
# puis on modifie le format
|
|
tryCatch({
|
|
dataframe[,j] <- as.Date(as.POSIXct(dataframe[,j] / 1000, origin = "1970-01-01"))
|
|
},
|
|
error = function(e){
|
|
next
|
|
})
|
|
} else {
|
|
#print("Dates pas au format UNIX")
|
|
}
|
|
} else {
|
|
#print("Aucune date non nulle dans cette colonne")
|
|
}
|
|
}
|
|
return(dataframe)
|
|
} else {
|
|
print("Pas de colonne commençant par 'da'/'DA'")
|
|
}
|
|
} else {
|
|
print("l'objet n'est pas un dataframe")
|
|
}
|
|
}
|
|
### génération du rapport HTML ################################################
|
|
|
|
render_report = function(CHEP, TECH, date_imp) {
|
|
print(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''),
|
|
'/', CHEP, '_rapport_eCow5.html', sep = ""))
|
|
rmarkdown::render(
|
|
paste(substr(rep_exp, 1, nchar(rep_exp)-10), "eCow5_rapport_v3.Rmd", sep=''), params = list(
|
|
CHEP = CHEP,
|
|
TECH = TECH,
|
|
date_imp = date_imp
|
|
),
|
|
output_file = paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''),
|
|
'/', CHEP, '_rapport_eCow5.html', sep = "")
|
|
)
|
|
}
|
|
|
|
render_synthese = function(CHEP, TECH, date_imp) {
|
|
print(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''),
|
|
'/', CHEP, '_synthese_eCow5.html', sep = ""))
|
|
rmarkdown::render(
|
|
paste(substr(rep_exp, 1, nchar(rep_exp)-10), "eCow5_synthese.Rmd", sep=''), params = list(
|
|
CHEP = CHEP,
|
|
TECH = TECH,
|
|
date_imp = date_imp
|
|
),
|
|
output_file = paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''),
|
|
'/', CHEP, '_synthese_eCow5.html', sep = "")
|
|
)
|
|
}
|
|
|
|
# fonction de création du rapport pour la VN 2021 ####
|
|
|
|
# render_vn = function(CHEP, TECH) {
|
|
# rmarkdown::render(
|
|
# paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/", "test_VN.Rmd", sep=''),
|
|
# params = list(
|
|
# CHEP = CHEP,
|
|
# TECH = TECH
|
|
# ),
|
|
# output_file = paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/",
|
|
# CHEP, '_VN.html', sep = "")
|
|
# )
|
|
# }
|
|
|
|
|
|
################################################################################
|
|
### fonction du calcul total ###################################################
|
|
################################################################################
|
|
|
|
|
|
render_all_fic <- function(cheptel, tech, VN = FALSE) { # cheptel avec le FR, tech = abrev 5 lettres
|
|
CHEP <- cheptel # avec le FR
|
|
TECH <- tech
|
|
|
|
# creation du repertoire d'export
|
|
dir.create(path=paste(rep_exp, TECH, '/', CHEP, sep=''))
|
|
rep <- paste(rep_exp, TECH, '/' ,CHEP, sep='')
|
|
|
|
|
|
################################################################################
|
|
### calcul du classement vaches ################################################
|
|
################################################################################
|
|
|
|
OLD=Sys.time()
|
|
## r?cup des animaux de l'inventaire
|
|
old <- Sys.time()
|
|
|
|
inventaire <- get_inventaire(CHEP)
|
|
|
|
if (is.data.frame(inventaire) && nrow(inventaire) > 0 ) {
|
|
|
|
# modif du 28/03/2023 : ajout de la verif chepdet = CHEP
|
|
inventaire <- inventaire %>% filter(trim_str(chepdet) == CHEP)
|
|
|
|
# if ( inventaire$danais[1] > 1*(10**8) ) {
|
|
# inventaire$danais <- as.Date(as.POSIXct(inventaire$danais / 1000, origin="1970-01-01"))
|
|
# }
|
|
#inventaire <- change_format_date_unix(inventaire)
|
|
|
|
inventaire$danais <- as.Date(inventaire$danais, format = "%Y-%m-%d")
|
|
inventaire$mere <- trim_str(inventaire$mere)
|
|
inventaire$pere <- trim_str(inventaire$pere)
|
|
inventaire$anim <- trim_str(inventaire$anim)
|
|
|
|
inventaire$ds <- as.numeric(inventaire$ds)
|
|
inventaire$af <- as.numeric(inventaire$af)
|
|
inventaire$dmC <- as.numeric(inventaire$dmC)
|
|
|
|
# vaches actives
|
|
vaches <- subset(inventaire,
|
|
inventaire$sexbov == 2 & inventaire$nbdescendants > 0)
|
|
|
|
# recherche des meres dans les porteuses pour aller chercher
|
|
# les produits s'ils existent dans HBCANIM
|
|
|
|
porteuses <- subset(indite, !is.na(indite$MEREIPG)
|
|
& indite$MEREIPG %in% trim_str(vaches$anim))
|
|
donneuses <- subset(indite, !is.na(indite$MERECPB)
|
|
& indite$MERECPB %in% trim_str(vaches$anim))
|
|
# l'indicateur de donneuse d'embryon est renseign? apres dans --> vaches$ACINAC
|
|
|
|
vaches$age_days <- time_length(interval(vaches$danais, Sys.Date()), unit="days")
|
|
vaches$age_years <- round(vaches$age_days / 365, 1)
|
|
vaches$acinac <- NA
|
|
|
|
# liste de tous leurs produits
|
|
produits <- vaches[0,]
|
|
|
|
if (nrow(vaches) > 0 ) {
|
|
for (i in 1:nrow(vaches)){
|
|
# r?cup des produits dans HBCANIM
|
|
temp <- try(fromJSON(paste(reqMere, trim_str(vaches$anim[i]), sep='')), silent = TRUE)
|
|
if (inherits(temp, "try-error")) {
|
|
temp <- vaches[0,]
|
|
} else {
|
|
#temp <- fromJSON(paste(reqMere, trim_str(vaches$anim[i]), sep='')) # a voir : gerer les retours vides !!!!
|
|
produits <- rbind(produits, temp)
|
|
# on annote les donneuses
|
|
if( is.data.frame(subset(temp, temp$indite == 'O')) ) {
|
|
if (nrow(subset(temp, temp$indite == 'O')) > 0){
|
|
vaches$acinac[i] <- 'DONNEUSE'
|
|
}
|
|
}
|
|
# ajout d'un nom ? la vache si null
|
|
if (is.na(vaches$nobovi[i])) {
|
|
lettre <- subset(LETTRES, LETTRES$ANNEE == vaches$campn[i])
|
|
vaches$nobovi[i] <- paste(lettre$LETTRE[1], vaches$nutrav[i], sep='_')
|
|
}
|
|
}
|
|
}
|
|
} else {
|
|
print("AUCUNE VACHE ACTIVE DANS LE CHEPTEL")
|
|
}
|
|
|
|
|
|
# les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant
|
|
if (nrow(porteuses) > 0) {
|
|
for (i in 1:nrow(porteuses)) {
|
|
if (!(porteuses$ANIM[i] %in% trim_str(produits$anim))) {
|
|
|
|
temp <- appel_infos(porteuses$ANIM[i], hbcanim)
|
|
li_mere <- subset(vaches, vaches$anim == porteuses$MEREIPG[i])
|
|
|
|
if ( is.data.frame(temp) && nrow(temp) > 0 ) {
|
|
temp$mere[1] <- porteuses$MEREIPG[i]
|
|
temp[1, c(60:67, 86:103)] <- NA
|
|
if ( nrow(li_mere) > 0){
|
|
temp$danaismere[1] <- as.character(li_mere$danais[1])
|
|
}
|
|
temp$indite[1] <- 'O_corr'
|
|
|
|
produits <- rbind(produits, temp)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# modifs des types de donn?es, pour calcul par la suite
|
|
produits$danais <- as.Date(produits$danais, format = "%Y-%m-%d")
|
|
produits$dasort <- as.Date(produits$dasort, format = "%Y-%m-%d")
|
|
|
|
produits$mere <- trim_str(produits$mere)
|
|
produits$pere <- trim_str(produits$pere)
|
|
produits$anim <- trim_str(produits$anim)
|
|
|
|
produits$ravelamere <- as.numeric(produits$ravelamere)
|
|
produits$ivv <- as.numeric(produits$ivv)
|
|
produits$campn <- as.numeric(produits$campn)
|
|
|
|
produits$ponais <- as.numeric(produits$ponais)
|
|
produits$pat04m <- as.numeric(produits$pat04m)
|
|
produits$pat07m <- as.numeric(produits$pat07m)
|
|
|
|
produits$devsqe <- as.numeric(produits$devsqe)
|
|
produits$devmus <- as.numeric(produits$devmus)
|
|
produits$aptfon <- as.numeric(produits$aptfon)
|
|
|
|
# on ne garde que les TE port?s par une vache active du cheptel
|
|
PROD <- subset(produits, produits$indite != 'O')
|
|
|
|
# ajout des produits IPG
|
|
PROD <- merge(PROD, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F)
|
|
|
|
PROD <- PROD[order(PROD$danais, decreasing = F),]
|
|
PROD <- PROD[order(PROD$mere, decreasing = T),]
|
|
|
|
# correction des ravelamere des TE si possible
|
|
if (nrow(PROD) >0){
|
|
for (i in 1:nrow(PROD)) {
|
|
if (is.na(PROD$ravelamere[i])) {
|
|
if (!is.na(PROD$ravelamere[i+1]) & PROD$ravelamere[i+1] %in% c(1, 2)) {
|
|
PROD$ravelamere[i] <- 1
|
|
PROD$typemere[i] <- 'G'
|
|
} else if (!is.na(PROD$ravelamere[i+1]) & PROD$ravelamere[i+1] > 1) {
|
|
PROD$ravelamere[i] <- PROD$ravelamere[i+1] - 1
|
|
PROD$typemere[i] <- 'V'
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# age au velage de la mere
|
|
PROD$agevel <- round(time_length(interval(PROD$danaismere, PROD$danais),
|
|
unit="months"), 1)
|
|
|
|
# IVV : utilisation de la colonne deja presente de HBCANIM
|
|
|
|
for (i in 1:nrow(PROD)) {
|
|
if (PROD$indite[i] == 'O_corr') {
|
|
PROD$nobovi[i] <- paste('#', PROD$nobovi[i], sep='')
|
|
}
|
|
# repro
|
|
if (PROD$anim[i] %in% czhbc$ANIM
|
|
| (!is.na(PROD$NBPRODIPG[i]) & PROD$NBPRODIPG[i] > 0)
|
|
| (!is.na(PROD$nbdescendants[i]) & as.numeric(PROD$nbdescendants[i]) > 0)) {
|
|
PROD$repro[i] <- 'O'
|
|
} else {
|
|
PROD$repro[i] <- NA
|
|
PROD$nobovi[i] <- PROD$nobovi[i] %>% str_to_lower()
|
|
}
|
|
# mortalite
|
|
if (!is.na(PROD$dasort[i]) & !is.na(PROD$casort[i]) & PROD$casort[i] == 'M'
|
|
& time_length(interval(PROD$danais[i], PROD$dasort[i]), unit="days") < 211){
|
|
PROD$mortsev[i] <- 'O'
|
|
PROD$nobovi[i]=paste(PROD$nobovi[i], ' (MavS)', sep='')
|
|
} else {
|
|
PROD$mortsev[i] <- NA
|
|
}
|
|
# IVV
|
|
if (i > 1) {
|
|
# cas normaux
|
|
if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1])
|
|
& PROD$ravelamere[i] != 1
|
|
& PROD$ravelamere[i] == PROD$ravelamere[i-1] + 1
|
|
#& !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] != '2'
|
|
& !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) {
|
|
PROD$ivv[i] <- time_length(interval(PROD$danais[i-1], PROD$danais[i]),
|
|
unit="days")
|
|
# jumeaux
|
|
} else if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1])
|
|
& PROD$ravelamere[i] != 1
|
|
& PROD$ravelamere[i] == PROD$ravelamere[i-1]
|
|
& !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] == '2'
|
|
& !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) {
|
|
PROD$ivv[i] <- PROD$ivv[i-1]
|
|
# rang de v?lage manquant
|
|
} else if (!is.na(PROD$ravelamere[i]) & !is.na(PROD$ravelamere[i-1])
|
|
& PROD$ravelamere[i] != 1
|
|
& !is.na(PROD$cofgmumere[i]) & PROD$cofgmumere[i] != '2'
|
|
& !is.na(PROD$mere[i]) & PROD$mere[i] == PROD$mere[i-1]) {
|
|
PROD$ivv[i] <- round(time_length(interval(PROD$danais[i-1],
|
|
PROD$danais[i]),
|
|
unit="days")
|
|
/ (PROD$ravelamere[i] - PROD$ravelamere[i-1]), 0)
|
|
} else {
|
|
PROD$ivv[i] <- NA
|
|
}
|
|
}
|
|
}
|
|
|
|
# calcul des effets du cheptel : rang de velage et sexe du veau
|
|
effet <- PROD %>% group_by(typemere, sexbov) %>%
|
|
summarise(m_PN = round(mean(ponais, na.rm=T), 1),
|
|
m_p120 = round(mean(pat04m, na.rm=T), 1),
|
|
m_p210 = round(mean(pat07m, na.rm=T), 1))
|
|
effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_PN[1]
|
|
effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_p120[1]
|
|
effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_p210[1]
|
|
|
|
# calcul des effets du cheptel : sexe sur la repro
|
|
effetsexe <- PROD %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>%
|
|
summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1),
|
|
nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) )
|
|
rapport_MF <- round(subset(effetsexe,
|
|
effetsexe$sexbov == '1')$nbpp_med[1]
|
|
/ subset(effetsexe,
|
|
effetsexe$sexbov == '2')$nbpp_med[1], 0)
|
|
|
|
|
|
# report des effets sur les produits
|
|
|
|
for (i in 1:nrow(PROD)) {
|
|
if (PROD$sexbov[i] == '2') { #_______________________________________ FEMELLES
|
|
PROD$nbpp_corr[i] <- PROD$NBPRODIPG[i] * rapport_MF
|
|
if (!is.na(PROD$typemere[i]) & PROD$typemere[i] == 'G') { #_________genisses
|
|
if (!is.na(PROD$ponais[i])) {
|
|
PROD$pn_corr[i] <- (PROD$ponais[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_pn[1])
|
|
} else {
|
|
PROD$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PROD$pat04m[i])) {
|
|
PROD$p120_corr[i] <- (PROD$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_p120[1])
|
|
} else {
|
|
PROD$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PROD$pat07m[i])) {
|
|
PROD$p210_corr[i] <- (PROD$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_p210[1])
|
|
} else {
|
|
PROD$p210_corr[i] <- NA
|
|
}
|
|
} else { #________________________________________________ vaches ou inconnu
|
|
if (!is.na(PROD$ponais[i])) {
|
|
PROD$pn_corr[i] <- (PROD$ponais[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_pn[1])
|
|
} else {
|
|
PROD$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PROD$pat04m[i])) {
|
|
PROD$p120_corr[i] <- (PROD$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_p120[1])
|
|
} else {
|
|
PROD$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PROD$pat07m[i])) {
|
|
PROD$p210_corr[i] <- (PROD$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_p210[1])
|
|
} else {
|
|
PROD$p210_corr[i] <- NA
|
|
}
|
|
}
|
|
} else { #______________________________________________________________ MALES
|
|
PROD$nbpp_corr[i] <- PROD$NBPRODIPG[i]
|
|
if (!is.na(PROD$typemere[i]) & PROD$typemere[i] == 'G') { #____________________________________genisses
|
|
if (!is.na(PROD$ponais[i])) {
|
|
PROD$pn_corr[i] <- (PROD$ponais[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_pn[1])
|
|
} else {
|
|
PROD$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PROD$pat04m[i])) {
|
|
PROD$p120_corr[i] <- (PROD$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_p120[1])
|
|
} else {
|
|
PROD$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PROD$pat07m[i])) {
|
|
PROD$p210_corr[i] <- (PROD$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_p210[1])
|
|
} else {
|
|
PROD$p210_corr[i] <- NA
|
|
}
|
|
} else { #________________________________________________ vaches ou inconnu
|
|
if (!is.na(PROD$ponais[i])) {
|
|
PROD$pn_corr[i] <- (PROD$ponais[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_pn[1])
|
|
} else {
|
|
PROD$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PROD$pat04m[i])) {
|
|
PROD$p120_corr[i] <- (PROD$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_p120[1])
|
|
} else {
|
|
PROD$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PROD$pat07m[i])) {
|
|
PROD$p210_corr[i] <- (PROD$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_p210[1])
|
|
} else {
|
|
PROD$p210_corr[i] <- NA
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# calcul des donn?es ?labor?es par vache active
|
|
|
|
for (i in 1:nrow(vaches)) {
|
|
# _______________________________________________rappel des produits par vache
|
|
veaux <- PROD %>% filter(mere == vaches$anim[i])
|
|
|
|
# ___________________________________________calcul des infos utiles par vache
|
|
|
|
# calcul du poids adulte estim? et synthese pointage vache ___________________
|
|
if (!is.na(vaches$dmC[i])) {
|
|
vaches$ptgV[i] <- round(0.6 * vaches$dmC[i] + 0.15 * vaches$ds[i]
|
|
+ 0.25 * vaches$af[i], 1)
|
|
} else {
|
|
vaches$ptgV[i] <- NA
|
|
}
|
|
|
|
if (nrow(veaux) > 3){
|
|
vaches$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2)
|
|
alpha <- 1.62 - 0.01 * vaches$precocite[i]
|
|
} else {
|
|
vaches$precocite[i] <- NA
|
|
alpha <- 1.62
|
|
}
|
|
if (!is.na(vaches$pat24m[i])) {
|
|
vaches$pad[i] <- round((vaches$pat24m[i] - 50 * exp(-720 * alpha * 10**(-3)))
|
|
/ (1 - exp(-720 * alpha * 10**(-3))), 1)
|
|
} else if (!is.na(vaches$pat18m[i])) {
|
|
vaches$pad[i] <- round((vaches$pat18m[i] - 50 * exp(-540 * alpha * 10**(-3)))
|
|
/ (1 - exp(-540 * alpha * 10**(-3))), 1)
|
|
} else if (!is.na(vaches$pat12m[i])) {
|
|
vaches$pad[i] <- round((vaches$pat12m[i] - 50 * exp(-360 * alpha * 10**(-3)))
|
|
/ (1-exp(-360 * alpha * 10**(-3))), 1)
|
|
} else {
|
|
vaches$pad[i] <- NA
|
|
}
|
|
|
|
# calcul des perfs de repro et du temps productif ____________________________
|
|
|
|
vaches$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1)
|
|
|
|
if (1 %in% veaux$ravelamere) {
|
|
vaches$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1]
|
|
} else {
|
|
vaches$agevel1[i] <- NA
|
|
}
|
|
|
|
if (2 %in% veaux$ravelamere) {
|
|
vaches$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1]
|
|
} else {
|
|
vaches$ivv1[i] <- NA
|
|
}
|
|
if (3 %in% veaux$ravelamere) {
|
|
vaches$ivv2p[i] <- round(mean(subset(veaux,
|
|
veaux$ravelamere > 2)$ivv, na.rm=T), 1)
|
|
}
|
|
|
|
if (is.na(vaches$ivv1[i]) | (!is.na(vaches$ivv1[i]) & vaches$ivv1[i] < 390) ){
|
|
e2 <- 0
|
|
} else if (!is.na(vaches$ivv1[i]) & vaches$ivv1[i] >= 390) {
|
|
e2 <- vaches$ivv1[i] - 390
|
|
}
|
|
if (is.na(vaches$ivv2p[i]) | (!is.na(vaches$ivv2p[i]) & vaches$ivv2p[i] < 365) ){
|
|
e3 <- 0
|
|
} else if (!is.na(vaches$ivv2p[i]) & vaches$ivv2p[i] >= 365) {
|
|
e3 <- vaches$ivv1[i] - 365
|
|
}
|
|
if (time_length(interval(max(veaux$danais, na.rm=T),
|
|
Sys.Date()), unit="days") < 365) {
|
|
e4 <- 0
|
|
} else {
|
|
e4 <- time_length(interval(max(veaux$danais, na.rm=T),
|
|
Sys.Date()), unit="days") - 365
|
|
}
|
|
|
|
vaches$tempsprod[i] <- round( (vaches$age_days[i]
|
|
- ( vaches$agevel1[i] * 30.4
|
|
+ e2
|
|
+ e3 * (vaches$nbcampvel[i] - 2)
|
|
+ e4
|
|
)) / vaches$age_days[i] * 100, 1)
|
|
|
|
# calcul des donn?es synth?tiques sur les produits ___________________________
|
|
|
|
vaches$prol[i] <- round(nrow(veaux) / (vaches$nbcampvel[i]) * 100, 1)
|
|
vaches$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O'))
|
|
/ nrow(veaux)* 100, 1)
|
|
vaches$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O'))
|
|
/ nrow(veaux)* 100, 1)
|
|
vaches$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T)
|
|
vaches$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T)
|
|
vaches$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1'))
|
|
/ nrow(veaux)* 100, 1)
|
|
vaches$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') ))
|
|
/ nrow(veaux)* 100, 1)
|
|
vaches$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE)
|
|
+ 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1)
|
|
vaches$pn_m[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '1')$ponais, na.rm=T), 1)
|
|
vaches$p120_m[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '1')$pat04m, na.rm=T), 1)
|
|
vaches$p210_m[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '1')$pat07m, na.rm=T), 1)
|
|
vaches$pn_f[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '2')$ponais, na.rm=T), 1)
|
|
vaches$p120_f[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '2')$pat04m, na.rm=T), 1)
|
|
vaches$p210_f[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '2')$pat07m, na.rm=T), 1)
|
|
vaches$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1)
|
|
vaches$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1)
|
|
vaches$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1)
|
|
|
|
### convertion des NaN en NA
|
|
L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr',
|
|
'p210_m','p210_f','p210_corr')
|
|
for (j in L){
|
|
if (is.nan(vaches[i,j]) == TRUE){
|
|
vaches[i,j] <- NA
|
|
}
|
|
}
|
|
}
|
|
|
|
# calcul des stats, valeurs extremes et references pour la normalisation
|
|
|
|
stats_chep <- create_df(0,c('var', 'cond', 'min', 'q1', 'med',
|
|
'moy', 'q3', 'max', 'nbval', 'nas'))
|
|
|
|
stats_chep <- rbind(stats_chep,
|
|
get_stats(vaches, "vaches", "indisu"),
|
|
get_stats(vaches, "vaches", "agevel1"),
|
|
get_stats(vaches, "vaches", "ivv1"),
|
|
get_stats(vaches, "vaches", "ivv2p"),
|
|
get_stats(vaches, "vaches", "prol"),
|
|
get_stats(vaches, "vaches", "mort"),
|
|
get_stats(vaches, "vaches", "txrepros"),
|
|
get_stats(vaches, "vaches", "nbpp_corr"),
|
|
get_stats(vaches, "vaches", "txvf"),
|
|
get_stats(vaches, "vaches", "txmales"),
|
|
get_stats(vaches, "vaches", "ptgP"),
|
|
get_stats(vaches, "vaches", "pn_corr"),
|
|
get_stats(vaches, "vaches", "p120_corr"),
|
|
get_stats(vaches, "vaches", "p210_corr"),
|
|
get_stats(vaches, "vaches", "pad"),
|
|
get_stats(vaches, "vaches", "ptgV"),
|
|
get_stats(vaches, "vaches", "age_years"),
|
|
get_stats(vaches, "vaches", "tempsprod"),
|
|
get_stats(vaches, "vaches", "pn_m"),
|
|
get_stats(vaches, "vaches", "pn_f"),
|
|
get_stats(vaches, "vaches", "p120_m"),
|
|
get_stats(vaches, "vaches", "p120_f"),
|
|
get_stats(vaches, "vaches", "p210_m"),
|
|
get_stats(vaches, "vaches", "p210_f"),
|
|
get_stats(vaches, "vaches", "nbpp"))
|
|
|
|
#_______________________________calcul des valeurs normalis?es par vache
|
|
|
|
for (i in 1:nrow(vaches)) {
|
|
# ____________________________________________ perfs individuelles normalis?es
|
|
if (!is.na(vaches$agevel1[i])){
|
|
if (vaches$agevel1[i] > 48) {
|
|
vaches$agevel1_n[i] <- 0
|
|
} else if (vaches$agevel1[i] <= 48) {
|
|
vaches$agevel1_n[i] <- round(-2 * (10**-6)
|
|
* (vaches$agevel1[i] * 30.4) ** 2
|
|
+ 0.0027 * (vaches$agevel1[i] * 30.4)
|
|
+ 8 * (10 ** -15), 3)
|
|
|
|
} else {
|
|
vaches$agevel1_n[i] <- NA
|
|
}
|
|
} else {
|
|
vaches$agevel1_n[i] <- NA
|
|
}
|
|
|
|
if (is.na(vaches$ivv1[i])) {
|
|
vaches$ivv1_n[i] <- NA
|
|
} else if (vaches$ivv1[i] > 460) {
|
|
vaches$ivv1_n[i] <- 0
|
|
} else if (vaches$ivv1[i] < 390) {
|
|
vaches$ivv1_n[i] <- 1
|
|
} else {
|
|
vaches$ivv1_n[i] <- round(1 - abs(390 - vaches$ivv1[i]) / abs(390 - 460), 3)
|
|
}
|
|
|
|
if (is.na(vaches$ivv2p[i]) | is.nan(vaches$ivv2p[i])) {
|
|
vaches$ivv2p_n[i] <- NA
|
|
} else if (vaches$ivv2p[i] > 435) {
|
|
vaches$ivv2p_n[i] <- 0
|
|
} else if (vaches$ivv2p[i] < 365) {
|
|
vaches$ivv2p_n[i] <- 1
|
|
} else {
|
|
vaches$ivv2p_n[i] <- round(1 - abs(365 - vaches$ivv2p[i]) / abs(365 - 435), 3)
|
|
}
|
|
|
|
if (is.na(vaches$pad[i])) {
|
|
vaches$pad_n[i] <- NA
|
|
} else {
|
|
vaches$pad_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$pad')[,'max']
|
|
- vaches$pad[i])
|
|
/ abs(subset(stats_chep, var == 'vaches$pad')[,'max']
|
|
- subset(stats_chep, var == 'vaches$pad')[,'min'])), 3)
|
|
}
|
|
|
|
if (is.na(vaches$ptgV[i])) {
|
|
vaches$ptgv_n[i] <- NA
|
|
} else {
|
|
vaches$ptgv_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$ptgV')[,'max']
|
|
- vaches$ptgV[i])
|
|
/ abs(subset(stats_chep, var == 'vaches$ptgV')[,'max']
|
|
- subset(stats_chep, var == 'vaches$ptgV')[,'min'])), 3)
|
|
}
|
|
|
|
if (vaches$prol[i] >= 100) {
|
|
vaches$prol_n[i] <- 1
|
|
} else if (vaches$prol[i] < 50){
|
|
vaches$prol_n[i] <- 0
|
|
} else {
|
|
vaches$prol_n[i] <- round(1 - (abs(100 - vaches$prol[i]) / abs(100 - 50)), 3)
|
|
}
|
|
|
|
if (is.na(vaches$pn_corr[i])) {
|
|
vaches$pn_n[i] <- NA
|
|
} else if (40 < vaches$pn_corr[i] & vaches$pn_corr[i] < 50) {
|
|
vaches$pn_n[i] <- 1
|
|
} else if (22 > vaches$pn_corr[i] | vaches$pn_corr[i] > 68) {
|
|
vaches$pn_n[i] <- 0
|
|
} else if (22 < vaches$pn_corr[i] & vaches$pn_corr[i] < 40) {
|
|
vaches$pn_n[i] <- round(0.056 * (vaches$pn_corr[i] - 22), 3)
|
|
} else {
|
|
vaches$pn_n[i] <- round(1 - 0.056 * (vaches$pn_corr[i] - 50), 3)
|
|
}
|
|
|
|
vaches$txvf_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txvf')[,'max']
|
|
- vaches$txvf[i]) /
|
|
abs(subset(stats_chep, var == 'vaches$txvf')[,'max']
|
|
- subset(stats_chep, var == 'vaches$txvf')[,'min'])), 3)
|
|
vaches$txm_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txmales')[,'max']
|
|
- vaches$txmales[i])
|
|
/ abs(subset(stats_chep, var == 'vaches$txmales')[,'max']
|
|
- subset(stats_chep, var == 'vaches$txmales')[,'min'])), 3)
|
|
vaches$mort_n[i] <- round(1.0 * exp(-0.031 * vaches$mort[i]), 3)
|
|
vaches$txrepros_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$txrepros')[,'max']
|
|
- vaches$txrepros[i])
|
|
/ abs(subset(stats_chep, var == 'vaches$txrepros')[,'max']
|
|
- subset(stats_chep, var == 'vaches$txrepros')[,'min'])), 3)
|
|
vaches$nbpp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$nbpp_corr')[,'max']
|
|
- vaches$nbpp_c[i])
|
|
/ abs(subset(stats_chep, var == 'vaches$nbpp_corr')[,'max']
|
|
- subset(stats_chep, var == 'vaches$nbpp_corr')[,'min'])), 3)
|
|
vaches$ptgp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$ptgP')[,'max']
|
|
- vaches$ptgP[i])
|
|
/ abs(subset(stats_chep, var == 'vaches$ptgP')[,'max']
|
|
- subset(stats_chep, var == 'vaches$ptgP')[,'min'])), 3)
|
|
vaches$p120_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$p120_corr')[,'max']
|
|
- vaches$p120_c[i])
|
|
/ abs(subset(stats_chep, var == 'vaches$p120_corr')[,'max']
|
|
- subset(stats_chep, var == 'vaches$p120_corr')[,'min'])), 3)
|
|
vaches$p210_n[i] <- round(1 - (abs(subset(stats_chep, var == 'vaches$p210_corr')[,'max']
|
|
- vaches$p210_c[i])
|
|
/ abs(subset(stats_chep, var == 'vaches$p210_corr')[,'max']
|
|
- subset(stats_chep, var == 'vaches$p210_corr')[,'min'])), 3)
|
|
# __________________________________________________ calcul des notes carriere
|
|
somme <- 0
|
|
pond <- sum(Pcar[,c(2:16)])
|
|
for (j in c(190:204)){ # attention a la correspondance des numeros de colonnes !!!
|
|
# modif du 29/04/2024 : passage de 189:203 à 190:204
|
|
if (is.na(vaches[i,j])){
|
|
valperf <- 0
|
|
#mt_col <- mt_col + 1 # nb de colonnes sans valeur
|
|
pond <- pond - Pcar[1, (j - 189 + 1)]
|
|
} else {
|
|
valperf <- vaches[i, j] * Pcar[1, (j - 189 + 1)] # critere normalise X ponderation
|
|
}
|
|
somme <- somme + valperf # somme sur une ligne
|
|
}
|
|
SOMME_tot <- somme / pond * 10 # rapport en prenant que les criteres ayant une valeur
|
|
if (is.na(vaches$ptgp_n[i]) & is.na(vaches$p120_n[i]) & is.na(vaches$p210_n[i])){
|
|
vaches$ecowcarr[i] <- NA
|
|
} else {
|
|
vaches$ecowcarr[i] <- round(SOMME_tot * 100, 0)
|
|
}
|
|
}
|
|
vaches$rg_carr <- rank(1 / vaches$ecowcarr, na.last="keep")
|
|
|
|
|
|
##################################################### calcul des notes campagnes
|
|
|
|
campagnes <- PROD %>% distinct(mere, campn, ravelamere)
|
|
|
|
for (i in 1:nrow(campagnes)){
|
|
#y <- subset(VA,VA$ANIM==C$mereref[i]) # ligne de la mere dans VA
|
|
veaux <- subset(PROD, PROD$campn == campagnes$campn[i]
|
|
& PROD$mere == campagnes$mere[i]) # ligne(s) du ou des veaux dans PR
|
|
|
|
campagnes$pn_c[i] <- round(mean(veaux$pn_corr, na.rm=TRUE), 1)
|
|
campagnes$txvf[i] <- round(nrow(subset(veaux,
|
|
veaux$conais %in% c('1','2')))
|
|
/ nrow(veaux) * 100, 1)
|
|
campagnes$txm[i] <- round(nrow(subset(veaux, veaux$sexbov == '1'))
|
|
/ nrow(veaux) * 100, 1)
|
|
campagnes$ptgp[i] <- round(mean((0.75 * veaux$devmus
|
|
+ 0.25 * veaux$devsqe), na.rm=TRUE) ,1)
|
|
campagnes$p120_c[i] <- round(mean(veaux$p120_corr, na.rm=TRUE), 1)
|
|
campagnes$p210_c[i] <- round(mean(veaux$p210_corr, na.rm=TRUE), 1)
|
|
campagnes$prol[i] <- nrow(veaux) * 100
|
|
campagnes$ivv[i] <- veaux$ivv[1]
|
|
campagnes$mort[i] <- round(nrow(subset(veaux,veaux$mortsev == 'O'))
|
|
/ nrow(veaux) * 100, 1)
|
|
|
|
L <- c('ptgp','pn_c','p120_c','p210_c')
|
|
for (j in L){
|
|
if (is.nan(campagnes[i,j])){
|
|
campagnes[i,j] <- NA
|
|
}
|
|
}
|
|
|
|
if (nrow(veaux) == 1){
|
|
nv <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_')
|
|
} else if (nrow(veaux) == 2){
|
|
nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_')
|
|
nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_')
|
|
nv <- paste(nv1, nv2, sep=', ')
|
|
} else if (nrow(veaux) == 3){
|
|
nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_')
|
|
nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_')
|
|
nv3 <- paste(str_sub(veaux$anim[3], -4), trim_str(veaux$nobovi[3]), sep='_')
|
|
nv <- paste(nv1, nv2, nv3, sep=', ')
|
|
} else if (nrow(veaux) == 4){
|
|
nv1 <- paste(str_sub(veaux$anim[1], -4), trim_str(veaux$nobovi[1]), sep='_')
|
|
nv2 <- paste(str_sub(veaux$anim[2], -4), trim_str(veaux$nobovi[2]), sep='_')
|
|
nv3 <- paste(str_sub(veaux$anim[3], -4), trim_str(veaux$nobovi[3]), sep='_')
|
|
nv4 <- paste(str_sub(veaux$anim[4], -4), trim_str(veaux$nobovi[4]), sep='_')
|
|
nv <- paste(nv1, nv2, nv3, nv4, sep=', ')
|
|
}
|
|
if(is.na(veaux$nompere[1])){
|
|
if (is.na(veaux$pere[1])){
|
|
pere <- ''
|
|
} else {
|
|
pere <- str_sub(trim_str(veaux$pere[1]), -4)
|
|
}
|
|
} else {
|
|
pere <- trim_str(veaux$nompere[1])
|
|
}
|
|
campagnes$noms[i] <- paste(nv, pere, sep=' / ')
|
|
}
|
|
|
|
stats_chep <- rbind(stats_chep,
|
|
get_stats(campagnes,'campagnes','ivv'),
|
|
get_stats(campagnes,'campagnes','prol'),
|
|
get_stats(campagnes,'campagnes','mort'),
|
|
get_stats(campagnes,'campagnes','txvf'),
|
|
get_stats(campagnes,'campagnes','txm'),
|
|
get_stats(campagnes,'campagnes','ptgp'),
|
|
get_stats(campagnes,'campagnes','pn_c'),
|
|
get_stats(campagnes,'campagnes','p120_c'),
|
|
get_stats(campagnes,'campagnes','p210_c'))
|
|
|
|
for (i in 1:nrow(campagnes)){
|
|
# _____________________________________ calcul des perfs campagnes normalis?es
|
|
#pn
|
|
if (is.na(campagnes$pn_c[i])) {
|
|
campagnes$pn_n[i] <- NA
|
|
} else if (campagnes$pn_c[i] >= 40 & campagnes$pn_c[i] <= 50) {
|
|
campagnes$pn_n[i] <- 1
|
|
} else if (22 >= campagnes$pn_c[i] | campagnes$pn_c[i] >= 68) {
|
|
campagnes$pn_n[i] <- 0
|
|
} else if (22 < campagnes$pn_c[i] & campagnes$pn_c[i] < 40) {
|
|
campagnes$pn_n[i] <- round(0.056 * (campagnes$pn_c[i] - 22), 3)
|
|
} else {
|
|
campagnes$pn_n[i] <- round(1 - 0.056 * (campagnes$pn_c[i] - 50), 3)
|
|
}
|
|
|
|
campagnes$txvf_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$txvf')[,'max']
|
|
- campagnes$txvf[i])
|
|
/ abs(subset(stats_chep, var == 'campagnes$txvf')[,'max']
|
|
- subset(stats_chep, var == 'campagnes$txvf')[,'min'])), 3)
|
|
campagnes$txm_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$txm')[,'max']
|
|
- campagnes$txm[i])
|
|
/ abs(subset(stats_chep, var == 'campagnes$txm')[,'max']
|
|
- subset(stats_chep, var == 'campagnes$txm')[,'min'])), 3)
|
|
campagnes$ptgp_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$ptgp')[,'max']
|
|
- campagnes$ptgp[i])
|
|
/ abs(subset(stats_chep, var == 'campagnes$ptgp')[,'max']
|
|
- subset(stats_chep, var == 'campagnes$ptgp')[,'min'])), 3)
|
|
campagnes$p120_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$p120_c')[,'max']
|
|
- campagnes$p120_c[i])
|
|
/ abs(subset(stats_chep, var == 'campagnes$p120_c')[,'max']
|
|
- subset(stats_chep, var == 'campagnes$p120_c')[,'min'])), 3)
|
|
campagnes$p210_n[i] <- round(1 - (abs(subset(stats_chep, var == 'campagnes$p210_c')[,'max']
|
|
- campagnes$p210_c[i])
|
|
/ abs(subset(stats_chep, var == 'campagnes$p210_c')[,'max']
|
|
- subset(stats_chep, var == 'campagnes$p210_c')[,'min'])), 3)
|
|
|
|
#prol
|
|
if (is.na(campagnes$prol[i])) {
|
|
campagnes$prol_n[i] <- NA
|
|
} else if (campagnes$prol[i] == 100) {
|
|
campagnes$prol_n[i] <- 0.8
|
|
} else {
|
|
campagnes$prol_n[i] <- 1
|
|
}
|
|
|
|
campagnes$mort_n[i] <- round(1.0 * exp(-0.031 * campagnes$mort[i]), 3)
|
|
|
|
#ivv
|
|
if (is.na(campagnes$ravelamere[i]) | campagnes$ravelamere[i] == 1
|
|
| is.na(campagnes$ivv[i])) {
|
|
campagnes$ivv_n[i] <- NA
|
|
} else if (campagnes$ravelamere[i] == 2) {
|
|
if (!is.na(campagnes$ivv[i])){
|
|
if (campagnes$ivv[i] > 460) {
|
|
campagnes$ivv_n[i] <- 0
|
|
} else if (campagnes$ivv[i] < 390) {
|
|
campagnes$ivv_n[i] <- 1
|
|
} else {
|
|
campagnes$ivv_n[i] <- round(1 - abs(390 - campagnes$ivv[i]) / abs(390 - 460), 3)
|
|
}
|
|
}
|
|
} else {
|
|
if (!is.na(campagnes$ivv[i])) {
|
|
if (campagnes$ivv[i] > 435) {
|
|
campagnes$ivv_n[i] <- 0
|
|
} else if (campagnes$ivv[i] < 365) {
|
|
campagnes$ivv_n[i] <- 1
|
|
} else {
|
|
campagnes$ivv_n[i] <- round(1 - abs(365 - campagnes$ivv[i]) / abs(365 - 435), 3)
|
|
}
|
|
}
|
|
}
|
|
|
|
# _________________________________________________ calcul des notes campagnes
|
|
somme <- 0
|
|
pond <- sum(Pcamp[2,c(2:10)])
|
|
for (j in c(14:22)){ # attention a la correspondance des num?ros de colonnes !!!
|
|
if (is.na(campagnes[i,j])){
|
|
valperf <- 0
|
|
#mt_col <- mt_col + 1 # nb de colonnes sans valeur
|
|
pond <- pond - Pcamp[1, (j - 13 + 1)]
|
|
} else {
|
|
valperf <- campagnes[i, j] * Pcamp[1, (j - 13 + 1)] # critere normalise X ponderation
|
|
}
|
|
somme <- somme + valperf # somme sur une ligne
|
|
}
|
|
SOMME_tot <- somme / pond * 10 # rapport en prenant que les criteres ayant une valeur
|
|
if (is.na(campagnes$ptgp_n[i]) & is.na(campagnes$p120_n[i]) & is.na(campagnes$p210_n[i])){
|
|
campagnes$ecowcamp[i] <- round(SOMME_tot, 1)
|
|
} else {
|
|
campagnes$ecowcamp[i] <- round(SOMME_tot * 10, 0)
|
|
}
|
|
|
|
}
|
|
|
|
# remplissage de la table vaches avec les notes campagnes
|
|
|
|
for (i in 1:nrow(vaches)){
|
|
# moyenne notes campagnes
|
|
subcamp <- subset(campagnes, campagnes$mere == vaches$anim[i]
|
|
& campagnes$ecowcamp > 10)
|
|
if (nrow(subcamp)>0){
|
|
vaches$moyecowcamp[i] <- round(mean(subcamp$ecowcamp, na.rm=TRUE), 1)
|
|
} else {
|
|
vaches$moyecowcamp[i] <- NA
|
|
}
|
|
# vaches non class?es en minuscules
|
|
if (is.na(vaches$ecowcarr[i])) {
|
|
vaches$nobovi[i] <- vaches$nobovi[i] %>% str_to_lower()
|
|
}
|
|
# donneuses soulignees par un #
|
|
embr <- subset(PROD, PROD$mere == vaches$anim[i] & PROD$indite == 'O')
|
|
if (nrow(embr) > 0) {
|
|
vaches$nobovi[i] <- paste('#', vaches$nobovi[i], sep=' ')
|
|
}
|
|
}
|
|
vaches$rg_camp <- rank(1 / vaches$moyecowcamp, na.last='keep')
|
|
|
|
# creation du tableau CAMPAGNES
|
|
|
|
nbcol <- max(campagnes$ravelamere, na.rm = TRUE) # nombre de colonnes de rangs de v?lage ? cr?er
|
|
CAMP <- cbind('anim'=vaches$anim, create_df(nrow(vaches), c(1:nbcol)))
|
|
for (i in 1:nrow(CAMP)){
|
|
subcamp <- subset(campagnes, campagnes$mere == CAMP$anim[i])
|
|
for (j in 2:ncol(CAMP)){
|
|
veaux <- subset(subcamp, subcamp$ravelamere == j-1)
|
|
if (nrow(veaux) > 0) {
|
|
CAMP[i,j] <- paste(veaux$noms[1], veaux$ecowcamp[1], sep=' : ')
|
|
}
|
|
}
|
|
}
|
|
|
|
vaches <- merge(vaches, CAMP, by.x='anim', by.y='anim', all.x=T, all.y=T)
|
|
|
|
|
|
# selection des colonnes d'interet pour la table finale
|
|
tabfinal <- merge(vaches[,c('chepdet', 'anim', 'nobovi', 'nompere', 'indisu',
|
|
'tempsprod', 'age_years', 'ecowcarr', 'rg_carr',
|
|
'ptgV', 'agevel1', 'ivv1', 'ivv2p',
|
|
'prol', 'mort', 'txrepros', 'nbpp',
|
|
'txvf', 'pn_m', 'pn_f',
|
|
'p120_m', 'p120_f', 'p210_m', 'p210_f',
|
|
'ptgP',
|
|
'moyecowcamp', 'rg_camp')],
|
|
CAMP, by.x='anim', by.y='anim', all.x=T, all.y=T)
|
|
|
|
tabfinal <- tabfinal[order(tabfinal$rg_carr),]
|
|
tabfinal <- tabfinal %>% select(chepdet, everything())
|
|
|
|
colnames(tabfinal)=c("CHEPTEL", "NUM_VACHE", "NOM_VACHE", "PERE", "ISU",
|
|
"% VIE PRODUCTIVE", "AGE (annees)",
|
|
"note eCow CARRIERE (/1000)", "rang CARRIERE",
|
|
"pointage VACHE *m", "age 1er velage (m)", "IVV1 (j)",
|
|
"IVV2+ (j)", "prolificite (%)", "mortalite av.sevr (%)",
|
|
"% produits repros", "nb petits-produits",
|
|
"% velages tranquilles", "PN males (kg)",
|
|
"PN femelles (kg)", "P120 males (kg)", "P120 femelles (kg)",
|
|
"P210 males (kg)","P210 femelles (kg)",
|
|
"pointage PRODUITS *m", "Moyenne notes eCow CAMPAGNE (/100)",
|
|
"rang CAMPAGNE", c(1:nbcol))
|
|
|
|
write.table(tabfinal,
|
|
file = paste(rep, '/', CHEP, '_classement_eCow5.csv', sep = ""),
|
|
quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE,
|
|
sep = ";", qmethod = c("escape"), na = "")
|
|
|
|
new <- Sys.time() - old
|
|
print(paste('Calcul du classement ?Cow :', new, sep = ''))
|
|
|
|
|
|
|
|
# a revoir pour les petits cheptels
|
|
#render_vn(CHEP, TECH)
|
|
|
|
################################################################################
|
|
### calcul du resume cheptel ###################################################
|
|
################################################################################
|
|
|
|
# lecture du fichier des stats des adherents
|
|
detail_stats_chep <- read_delim(paste(rep_exp, "detail_stats_chep.csv", sep=''),
|
|
";", escape_double = FALSE,
|
|
locale = locale(decimal_mark = ",",
|
|
grouping_mark = ""), trim_ws = TRUE)
|
|
#detail_stats_chep$date_calc <- '2020-09-06'
|
|
# perfs dont l'unit? de calcul est la vache : ie toutes les vaches actives
|
|
# isu, age, temps prod, ptg adulte, agevel1, ivv1 et 2+
|
|
# perfs dont l'unit? de calcul est le produit : ie tous les produits issus de vaches actives
|
|
# prol, mort, tx de repros, nb de PP, tx de VF, PN, P120 et 210, ptg sevrage
|
|
|
|
|
|
## stats du cheptel a inserer dans la liste des adherents pour comparaison
|
|
|
|
stats_chep_bis <- detail_stats_chep[1,]
|
|
stats_chep_bis[1,] <- NA
|
|
|
|
stats_chep_bis$ADHHBC <- CHEP
|
|
|
|
stats_chep_bis$isu[1] <- round( mean(vaches$indisu, na.rm=T), 1)
|
|
stats_chep_bis$tps_prod[1] <- round( mean(vaches$tempsprod, na.rm=T), 1)
|
|
stats_chep_bis$age[1] <- round( mean(vaches$age_years, na.rm=T), 1)
|
|
stats_chep_bis$ptgv[1] <- round( mean(vaches$ptgV, na.rm=T), 1)
|
|
stats_chep_bis$agevel1[1] <- round( mean(vaches$agevel1, na.rm=T), 1)
|
|
stats_chep_bis$ivv1[1] <- round( mean(vaches$ivv1, na.rm=T), 1)
|
|
stats_chep_bis$ivv2p[1] <- round( mean(vaches$ivv2p, na.rm=T), 1)
|
|
|
|
stats_chep_bis$prol[1] <- round( nrow(PROD) / nrow(campagnes) * 100, 1)
|
|
stats_chep_bis$mort[1] <- round( nrow(subset(PROD, PROD$mortsev == 'O'))
|
|
/ nrow(PROD) * 100, 1)
|
|
stats_chep_bis$txvf[1] <- round( nrow(subset(PROD, PROD$conais %in% c('1','2')))
|
|
/ nrow(PROD) * 100, 1)
|
|
stats_chep_bis$tx_repros[1] <- round( nrow(subset(PROD, PROD$NBPRODIPG > 0))
|
|
/ nrow(PROD) * 100, 1)
|
|
stats_chep_bis$nbpp[1] <- sum(PROD$NBPRODIPG, na.rm=TRUE)
|
|
stats_chep_bis$ptgp[1] <- round( mean(0.75 * PROD$devmus + 0.25 * PROD$devsqe,
|
|
na.rm=TRUE), 1)
|
|
stats_chep_bis$pnm[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$ponais,
|
|
na.rm=TRUE), 1)
|
|
stats_chep_bis$pnf[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$ponais,
|
|
na.rm=TRUE), 1)
|
|
stats_chep_bis$p120m[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$pat04m,
|
|
na.rm=TRUE), 1)
|
|
stats_chep_bis$p120f[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$pat04m,
|
|
na.rm=TRUE), 1)
|
|
stats_chep_bis$p210m[1] <- round( mean(subset(PROD, PROD$sexbov == '1')$pat07m,
|
|
na.rm=TRUE), 1)
|
|
stats_chep_bis$p210f[1] <- round( mean(subset(PROD, PROD$sexbov == '2')$pat07m,
|
|
na.rm=TRUE), 1)
|
|
stats_chep_bis$date_calc[1] <- as.character(Sys.Date())
|
|
|
|
# on met a jour le fichier des stats des adh
|
|
#____________________________ prevoir une ?tape de verif de VALEURS ABERRENTES !
|
|
|
|
detail_stats_chep <- subset(detail_stats_chep, detail_stats_chep$ADHHBC != CHEP)
|
|
|
|
detail_stats_chep <- rbind(detail_stats_chep, stats_chep_bis)
|
|
|
|
write.table(detail_stats_chep,
|
|
file = paste(rep_exp, "detail_stats_chep.csv", sep = ""),
|
|
quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE,
|
|
sep = ";", qmethod = c("escape"),na = "")
|
|
|
|
|
|
## stats du cheptel avec distribution des adh?rents et des vaches
|
|
rownames(stats_chep) <- stats_chep$var
|
|
|
|
res_chep <- stats_chep[c('vaches$indisu', 'vaches$tempsprod', 'vaches$age_years',
|
|
'vaches$ptgV','vaches$agevel1', 'vaches$ivv1',
|
|
'vaches$ivv2p', 'vaches$prol', 'vaches$mort',
|
|
'vaches$txrepros', 'vaches$nbpp', 'vaches$txvf',
|
|
'vaches$pn_m', 'vaches$pn_f', 'vaches$p120_m',
|
|
'vaches$p120_f', 'vaches$p210_m', 'vaches$p210_f',
|
|
'vaches$ptgP'),
|
|
c('moy', 'min', 'q1', 'med', 'q3', 'max')]
|
|
|
|
# creation d'un table contenant la distribution des cheptels pour chaque variable
|
|
stats_adh <- data.frame(matrix(NA, ncol = 7,nrow = 19))
|
|
colnames(stats_adh) <- c("var", "moy_c", "min_c", "Q1_c", "med_c", "Q3_c", "max_c" )
|
|
stats_adh[,1] <- c('isu','tps_prod','age','ptgv','agevel1','ivv1','ivv2p',
|
|
'prol','mort','tx_repros','nbpp','txvf',
|
|
'pnm','pnf','p120m','p120f','p210m','p210f','ptgp')
|
|
|
|
# remplissage de la table
|
|
for (i in 1:nrow(stats_adh)){
|
|
stats_adh$moy_c[i] <- round(mean(unlist(detail_stats_chep[,i + 1]),
|
|
na.rm = TRUE), 1)
|
|
stats_adh$min_c[i] <- round(min(detail_stats_chep[,i + 1], na.rm = TRUE), 1)
|
|
stats_adh$Q1_c[i] <- round(quantile(detail_stats_chep[,i + 1],
|
|
probs = 0.25, na.rm = TRUE), 1)
|
|
stats_adh$med_c[i] <- round(quantile(detail_stats_chep[,i + 1],
|
|
probs = 0.50, na.rm = TRUE), 1)
|
|
stats_adh$Q3_c[i] <- round(quantile(detail_stats_chep[,i + 1],
|
|
probs = 0.75,na.rm = TRUE), 1)
|
|
stats_adh$max_c[i] <- round(max(detail_stats_chep[,i + 1], na.rm = TRUE), 1)
|
|
}
|
|
|
|
# on fusionne distribution des adherents et des vaches du cheptel d'?tude
|
|
STATS <- cbind(stats_adh, t(stats_chep_bis[, c(2 : (ncol(stats_chep_bis) - 1))]))
|
|
|
|
STATS <- cbind(STATS, res_chep)
|
|
|
|
STATS$var <- c("ISU", "% vie productive", "age (annees)",
|
|
"pointage VACHE *m", "age 1er velage (m)", "IVV1 (j)", "IVV2+ (j)",
|
|
"prolificite (%)", "mortalite av.sevr (%)", "% produits repros",
|
|
"nb petits-produits", "% velages tranquilles", "PN males (kg)",
|
|
"PN femelles (kg)", "P120 males (kg)", "P120 femelles (kg)",
|
|
"P210 males (kg)", "P210 femelles (kg)", "pointage PRODUITS *m")
|
|
colnames(STATS) <- c('Variable', 'Moyenne_ADH', 'Min_ADH', 'Q1_ADH',
|
|
'Mediane_ADH', 'Q3_ADH', 'Max_ADH', 'Moyenne_cheptel',
|
|
'Moyenne_vaches', 'Min_vaches', 'Q1_vaches',
|
|
'Mediane_vaches', 'Q3_vaches', 'Max_vaches')
|
|
|
|
write.table(STATS,
|
|
file = paste(rep, '/', CHEP, '_ResChep_eCow5.csv', sep = ""),
|
|
quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE,
|
|
sep = ";", qmethod = c("escape"), na = "")
|
|
|
|
################################################################################
|
|
### remont?e des perfs des taureaux marquants ##################################
|
|
################################################################################
|
|
|
|
# on r?cupere les peres des animaux actifs
|
|
# on regarde s'ils ont un nombre raisonnable de produits, ie moins de 275
|
|
# si c'est la cas, on r?cupere tous les produits puis on trie ceux n?s dans le cheptel
|
|
|
|
## update du 13dec2021 apres mise en prod du WS sur la production d'un animal dans un cheptel particulier
|
|
|
|
peres <- inventaire %>%
|
|
filter(trim_str(chna) == CHEP & !is.na(pere)) %>%
|
|
distinct(pere, nompere) %>% add_column('naisseur' = NA)
|
|
|
|
if (nrow(peres) > 0) {
|
|
for (i in 1:nrow(peres)) {
|
|
li_anim <- chgt_infos(trim_str(peres$pere[i]))
|
|
if (is.data.frame(li_anim)) {
|
|
peres$naisseur[i] <- li_anim$nomnais[1]
|
|
}
|
|
}
|
|
|
|
prod_peres <- inventaire[0,]
|
|
pp_peres <- inventaire[0,]
|
|
|
|
for (i in 1 : nrow(peres)) {
|
|
animal <- peres$pere[i]
|
|
cat("\n", animal, peres$nompere[i])
|
|
try({
|
|
produits <- get_produits_in_chep(animal, CHEP) # loc update
|
|
if (is.data.frame(produits) == TRUE) { #__________________________________
|
|
produits <- produits %>% filter(trim_str(chna) == CHEP)
|
|
prod_peres <- rbind(prod_peres, produits)
|
|
for (j in 1:nrow(produits)) {
|
|
if (produits$sexbov[j] == '2' & as.numeric(produits$nbdescendants[j]) > 0) {
|
|
pp <- get_produits_vache(trim_str(produits$anim[j]))
|
|
if (is.data.frame(pp) == TRUE) { #______________________________
|
|
pp <- pp %>% filter(trim_str(chna) == CHEP)
|
|
pp_peres <- rbind(pp_peres, pp)
|
|
}
|
|
}
|
|
}
|
|
} else { #________________________________________________________________
|
|
cat("\n", "Aucune donn?e charg?e")
|
|
}
|
|
})
|
|
}
|
|
|
|
if (nrow(prod_peres) > 0) {
|
|
if (!is.na(prod_peres$danais[1]) & nchar(as.character(prod_peres$danais[1])) > 10) {
|
|
prod_peres$danais <- as.Date(substr(as.POSIXct(prod_peres$danais / 1000,
|
|
origin = "1970-01-01"), 1, 10),
|
|
format = "%Y-%m-%d",
|
|
origin = "1970-01-01")
|
|
} else {
|
|
prod_peres$danais <- as.Date(prod_peres$danais,
|
|
format = "%Y-%m-%d")
|
|
}
|
|
sortis <- subset(prod_peres, !is.na(prod_peres$dasort))
|
|
if (nrow(sortis) > 0 && nchar(as.character(sortis$dasort[1])) > 10) {
|
|
prod_peres$dasort <- as.Date(substr(as.POSIXct(prod_peres$dasort / 1000,
|
|
origin = "1970-01-01"), 1, 10),
|
|
format = "%Y-%m-%d",
|
|
origin = "1970-01-01")
|
|
} else {
|
|
prod_peres$dasort <- as.Date(prod_peres$dasort,
|
|
format = "%Y-%m-%d")
|
|
}
|
|
if (!is.na(prod_peres$danaismere[1]) & nchar(as.character(prod_peres$danaismere[1])) > 10) {
|
|
prod_peres$danaismere <- as.Date(substr(as.POSIXct(prod_peres$danaismere / 1000,
|
|
origin = "1970-01-01"), 1, 10),
|
|
format = "%Y-%m-%d",
|
|
origin = "1970-01-01")
|
|
} else {
|
|
prod_peres$danaismere <- as.Date(prod_peres$danaismere,
|
|
format = "%Y-%m-%d")
|
|
}
|
|
|
|
prod_peres$mere <- trim_str(prod_peres$mere)
|
|
prod_peres$pere <- trim_str(prod_peres$pere)
|
|
prod_peres$anim <- trim_str(prod_peres$anim)
|
|
prod_peres$ds <- as.numeric(prod_peres$ds)
|
|
prod_peres$af <- as.numeric(prod_peres$af)
|
|
prod_peres$dmC <- as.numeric(prod_peres$dmC)
|
|
|
|
# liste de tous leurs produitsdir
|
|
produitsdir <- prod_peres #%>% filter(chna == CHEP) # _________________________ filtre a reflechir ?????
|
|
|
|
# vachestot actives
|
|
vachestot <- subset(prod_peres,
|
|
prod_peres$sexbov == '2' & prod_peres$nbdescendants > 0 )
|
|
|
|
# les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant
|
|
if (nrow(porteuses) > 0) {
|
|
for (i in 1:nrow(porteuses)) {
|
|
if (!(porteuses$ANIM[i] %in% trim_str(produitsdir$anim))) {
|
|
|
|
temp <- appel_infos(porteuses$ANIM[i], hbcanim)
|
|
li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i])
|
|
|
|
if ( is.data.frame(temp) && nrow(temp) > 0 ) {
|
|
temp$mere[1] <- porteuses$MEREIPG[i]
|
|
temp[1, c(60:67, 86:103)] <- NA
|
|
if ( nrow(li_mere) > 0){
|
|
temp$danaismere[1] <- as.character(li_mere$danais[1])
|
|
}
|
|
temp$indite[1] <- 'O_corr'
|
|
|
|
tryCatch({
|
|
produitsdir <- rbind(produitsdir, temp[,colnames(produitsdir)]) #-------------------------------- tryCatch à supp
|
|
},
|
|
error = function(e) e)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# modifs des types de donn?es, pour calcul par la suite
|
|
produitsdir$danais <- as.Date(produitsdir$danais, format = "%Y-%m-%d")
|
|
produitsdir$dasort <- as.Date(produitsdir$dasort, format = "%Y-%m-%d")
|
|
|
|
produitsdir$mere <- trim_str(produitsdir$mere)
|
|
produitsdir$pere <- trim_str(produitsdir$pere)
|
|
produitsdir$anim <- trim_str(produitsdir$anim)
|
|
|
|
produitsdir$ravelamere <- as.numeric(produitsdir$ravelamere)
|
|
produitsdir$ivv <- as.numeric(produitsdir$ivv)
|
|
produitsdir$campn <- as.numeric(produitsdir$campn)
|
|
produitsdir$nbdescendants <- as.numeric(produitsdir$nbdescendants)
|
|
|
|
produitsdir$ponais <- as.numeric(produitsdir$ponais)
|
|
produitsdir$pat04m <- as.numeric(produitsdir$pat04m)
|
|
produitsdir$pat07m <- as.numeric(produitsdir$pat07m)
|
|
|
|
produitsdir$devsqe <- as.numeric(produitsdir$devsqe)
|
|
produitsdir$devmus <- as.numeric(produitsdir$devmus)
|
|
produitsdir$aptfon <- as.numeric(produitsdir$aptfon)
|
|
|
|
# on ne garde que les TE port?s par une vache active du cheptel
|
|
PRODDIR <- subset(produitsdir, produitsdir$indite != 'O')
|
|
|
|
# ajout des produitsdir IPG
|
|
PRODDIR <- merge(PRODDIR, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F)
|
|
|
|
PRODDIR <- PRODDIR[order(PRODDIR$danais, decreasing = F),]
|
|
PRODDIR <- PRODDIR[order(PRODDIR$mere, decreasing = T),]
|
|
|
|
# correction des ravelamere des TE si possible
|
|
for (i in 1:nrow(PRODDIR)) {
|
|
if (is.na(PRODDIR$ravelamere[i])) {
|
|
if (!is.na(PRODDIR$ravelamere[i+1]) & PRODDIR$ravelamere[i+1] %in% c(1, 2)) {
|
|
PRODDIR$ravelamere[i] <- 1
|
|
PRODDIR$typemere[i] <- 'G'
|
|
} else if (!is.na(PRODDIR$ravelamere[i+1]) & PRODDIR$ravelamere[i+1] > 1) {
|
|
PRODDIR$ravelamere[i] <- PRODDIR$ravelamere[i+1] - 1
|
|
PRODDIR$typemere[i] <- 'V'
|
|
}
|
|
}
|
|
}
|
|
|
|
# age au velage de la mere
|
|
PRODDIR$agevel <- round(time_length(interval(PRODDIR$danaismere, PRODDIR$danais),
|
|
unit="months"), 1)
|
|
|
|
# IVV : utilisation de la colonne deja pr?sente de HBCANIM
|
|
|
|
for (i in 1:nrow(PRODDIR)) {
|
|
if (PRODDIR$indite[i] == 'O_corr') {
|
|
PRODDIR$nobovi[i] <- paste('#', PRODDIR$nobovi[i], sep='')
|
|
}
|
|
# repro
|
|
if (PRODDIR$anim[i] %in% czhbc$ANIM
|
|
| (!is.na(PRODDIR$NBPRODIPG[i]) & PRODDIR$NBPRODIPG[i] > 0)
|
|
| (!is.na(PRODDIR$nbdescendants[i])
|
|
& as.numeric(PRODDIR$nbdescendants[i]) > 0)) {
|
|
PRODDIR$repro[i] <- 'O'
|
|
} else {
|
|
PRODDIR$repro[i] <- NA
|
|
PRODDIR$nobovi[i] <- PRODDIR$nobovi[i] %>% str_to_lower()
|
|
}
|
|
# mortalite
|
|
if (!is.na(PRODDIR$dasort[i]) & !is.na(PRODDIR$casort[i])
|
|
& PRODDIR$casort[i] == 'M'
|
|
& time_length(interval(PRODDIR$danais[i], PRODDIR$dasort[i]),
|
|
unit="days") < 211){
|
|
PRODDIR$mortsev[i] <- 'O'
|
|
PRODDIR$nobovi[i]=paste(PRODDIR$nobovi[i], ' (MavS)', sep='')
|
|
} else {
|
|
PRODDIR$mortsev[i] <- NA
|
|
}
|
|
# IVV
|
|
if (i > 1) {
|
|
# cas normaux
|
|
if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1])
|
|
& PRODDIR$ravelamere[i] != 1
|
|
& PRODDIR$ravelamere[i] == PRODDIR$ravelamere[i-1] + 1
|
|
#& !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] != '2'
|
|
& !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) {
|
|
PRODDIR$ivv[i] <- time_length(interval(PRODDIR$danais[i-1], PRODDIR$danais[i]),
|
|
unit="days")
|
|
# jumeaux
|
|
} else if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1])
|
|
& PRODDIR$ravelamere[i] != 1
|
|
& PRODDIR$ravelamere[i] == PRODDIR$ravelamere[i-1]
|
|
& !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] == '2'
|
|
& !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) {
|
|
PRODDIR$ivv[i] <- PRODDIR$ivv[i-1]
|
|
# rang de v?lage manquant
|
|
} else if (!is.na(PRODDIR$ravelamere[i]) & !is.na(PRODDIR$ravelamere[i-1])
|
|
& PRODDIR$ravelamere[i] != 1
|
|
& !is.na(PRODDIR$cofgmumere[i]) & PRODDIR$cofgmumere[i] != '2'
|
|
& !is.na(PRODDIR$mere[i]) & PRODDIR$mere[i] == PRODDIR$mere[i-1]) {
|
|
PRODDIR$ivv[i] <- round(time_length(interval(PRODDIR$danais[i-1],
|
|
PRODDIR$danais[i]),
|
|
unit="days")
|
|
/ (PRODDIR$ravelamere[i]
|
|
- PRODDIR$ravelamere[i-1]), 0)
|
|
} else {
|
|
PRODDIR$ivv[i] <- NA
|
|
}
|
|
}
|
|
}
|
|
|
|
# calcul des effets du cheptel : rang de velage et sexe du veau
|
|
effet <- PRODDIR %>% group_by(typemere, sexbov) %>%
|
|
summarise(m_PN = round(mean(ponais, na.rm=T), 1),
|
|
m_p120 = round(mean(pat04m, na.rm=T), 1),
|
|
m_p210 = round(mean(pat07m, na.rm=T), 1))
|
|
effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_PN[1]
|
|
effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_p120[1]
|
|
effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_p210[1]
|
|
|
|
# calcul des effets du cheptel : sexe sur la repro
|
|
effetsexe <- PRODDIR %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>%
|
|
summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1),
|
|
nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) )
|
|
rapport_MF <- round(subset(effetsexe,
|
|
effetsexe$sexbov == '1')$nbpp_med[1]
|
|
/ subset(effetsexe,
|
|
effetsexe$sexbov == '2')$nbpp_med[1], 0)
|
|
|
|
|
|
# report des effets sur les produitsdir
|
|
|
|
for (i in 1:nrow(PRODDIR)) {
|
|
if (PRODDIR$sexbov[i] == '2') { #____________________________________ FEMELLES
|
|
PRODDIR$nbpp_corr[i] <- PRODDIR$NBPRODIPG[i] * rapport_MF
|
|
if (!is.na(PRODDIR$typemere[i]) & PRODDIR$typemere[i] == 'G') { #____genisses
|
|
if (!is.na(PRODDIR$ponais[i])) {
|
|
PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_pn[1])
|
|
} else {
|
|
PRODDIR$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODDIR$pat04m[i])) {
|
|
PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_p120[1])
|
|
} else {
|
|
PRODDIR$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODDIR$pat07m[i])) {
|
|
PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_p210[1])
|
|
} else {
|
|
PRODDIR$p210_corr[i] <- NA
|
|
}
|
|
} else { #_____________________________________________ vachestot ou inconnu
|
|
if (!is.na(PRODDIR$ponais[i])) {
|
|
PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_pn[1])
|
|
} else {
|
|
PRODDIR$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODDIR$pat04m[i])) {
|
|
PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_p120[1])
|
|
} else {
|
|
PRODDIR$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODDIR$pat07m[i])) {
|
|
PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_p210[1])
|
|
} else {
|
|
PRODDIR$p210_corr[i] <- NA
|
|
}
|
|
}
|
|
} else { #______________________________________________________________ MALES
|
|
PRODDIR$nbpp_corr[i] <- PRODDIR$NBPRODIPG[i]
|
|
if (!is.na(PRODDIR$typemere[i]) & PRODDIR$typemere[i] == 'G') { #_________________________________genisses
|
|
if (!is.na(PRODDIR$ponais[i])) {
|
|
PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_pn[1])
|
|
} else {
|
|
PRODDIR$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODDIR$pat04m[i])) {
|
|
PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_p120[1])
|
|
} else {
|
|
PRODDIR$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODDIR$pat07m[i])) {
|
|
PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_p210[1])
|
|
} else {
|
|
PRODDIR$p210_corr[i] <- NA
|
|
}
|
|
} else { #_____________________________________________ vachestot ou inconnu
|
|
if (!is.na(PRODDIR$ponais[i])) {
|
|
PRODDIR$pn_corr[i] <- (PRODDIR$ponais[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_pn[1])
|
|
} else {
|
|
PRODDIR$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODDIR$pat04m[i])) {
|
|
PRODDIR$p120_corr[i] <- (PRODDIR$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_p120[1])
|
|
} else {
|
|
PRODDIR$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODDIR$pat07m[i])) {
|
|
PRODDIR$p210_corr[i] <- (PRODDIR$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_p210[1])
|
|
} else {
|
|
PRODDIR$p210_corr[i] <- NA
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if (nrow(vachestot) > 0) {
|
|
# recherche des meres dans les porteuses pour aller chercher
|
|
# les produitstot s'ils existent dans HBCANIM
|
|
|
|
porteuses <- subset(indite, !is.na(indite$MEREIPG)
|
|
& indite$MEREIPG %in% trim_str(vachestot$anim))
|
|
donneuses <- subset(indite, !is.na(indite$MERECPB)
|
|
& indite$MERECPB %in% trim_str(vachestot$anim))
|
|
# l'indicateur de donneuse d'embryon est renseign? apr?s dans --> vachestot$ACINAC
|
|
|
|
for (i in 1:nrow(vachestot)) {
|
|
if (is.na(vachestot$dasort[i])){
|
|
vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], Sys.Date()), unit="days")
|
|
} else {
|
|
vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], vachestot$dasort[i]), unit="days")
|
|
}
|
|
}
|
|
|
|
vachestot$age_years <- round(vachestot$age_days / 365, 1)
|
|
|
|
# liste de tous leurs produitstot
|
|
produitstot <- pp_peres #%>% filter(chna == CHEP) # ___________________________ filtre a reflechir ?????
|
|
|
|
# les veaux port?s sont rajout?s aux produits si non r?cup?r?s avant
|
|
if (nrow(porteuses) > 0) {
|
|
for (i in 1:nrow(porteuses)) {
|
|
if (!(porteuses$ANIM[i] %in% trim_str(produitstot$anim))) {
|
|
|
|
temp <- appel_infos(porteuses$ANIM[i], hbcanim)
|
|
li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i])
|
|
|
|
if ( is.data.frame(temp) && nrow(temp) > 0 ) {
|
|
temp$mere[1] <- porteuses$MEREIPG[i]
|
|
temp[1, c(60:67, 86:103)] <- NA
|
|
if ( nrow(li_mere) > 0){
|
|
temp$danaismere[1] <- as.character(li_mere$danais[1])
|
|
}
|
|
temp$indite[1] <- 'O_corr'
|
|
|
|
produitstot <- rbind(produitstot, temp[,colnames(produitstot)])
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# modifs des types de donn?es, pour calcul par la suite
|
|
produitstot$danais <- as.Date(produitstot$danais, format = "%Y-%m-%d")
|
|
produitstot$dasort <- as.Date(produitstot$dasort, format = "%Y-%m-%d")
|
|
|
|
produitstot$mere <- trim_str(produitstot$mere)
|
|
produitstot$pere <- trim_str(produitstot$pere)
|
|
produitstot$anim <- trim_str(produitstot$anim)
|
|
|
|
produitstot$ravelamere <- as.numeric(produitstot$ravelamere)
|
|
produitstot$ivv <- as.numeric(produitstot$ivv)
|
|
produitstot$campn <- as.numeric(produitstot$campn)
|
|
produitstot$nbdescendants <- as.numeric(produitstot$nbdescendants)
|
|
|
|
produitstot$ponais <- as.numeric(produitstot$ponais)
|
|
produitstot$pat04m <- as.numeric(produitstot$pat04m)
|
|
produitstot$pat07m <- as.numeric(produitstot$pat07m)
|
|
|
|
produitstot$devsqe <- as.numeric(produitstot$devsqe)
|
|
produitstot$devmus <- as.numeric(produitstot$devmus)
|
|
produitstot$aptfon <- as.numeric(produitstot$aptfon)
|
|
|
|
# on ne garde que les TE port?s par une vache active du cheptel
|
|
PRODTOT <- subset(produitstot, produitstot$indite != 'O')
|
|
|
|
# ajout des produitstot IPG
|
|
PRODTOT <- merge(PRODTOT, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F)
|
|
|
|
PRODTOT <- PRODTOT[order(PRODTOT$danais, decreasing = F),]
|
|
PRODTOT <- PRODTOT[order(PRODTOT$mere, decreasing = T),]
|
|
|
|
# correction des ravelamere des TE si possible
|
|
for (i in 1:nrow(PRODTOT)) {
|
|
if (is.na(PRODTOT$ravelamere[i])) {
|
|
if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] %in% c(1, 2)) {
|
|
PRODTOT$ravelamere[i] <- 1
|
|
PRODTOT$typemere[i] <- 'G'
|
|
} else if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] > 1) {
|
|
PRODTOT$ravelamere[i] <- PRODTOT$ravelamere[i+1] - 1
|
|
PRODTOT$typemere[i] <- 'V'
|
|
}
|
|
}
|
|
}
|
|
|
|
# age au velage de la mere
|
|
PRODTOT$agevel <- round(time_length(interval(PRODTOT$danaismere, PRODTOT$danais),
|
|
unit="months"), 1)
|
|
|
|
# IVV : utilisation de la colonne deja presente de HBCANIM
|
|
|
|
for (i in 1:nrow(PRODTOT)) {
|
|
if (PRODTOT$indite[i] == 'O_corr') {
|
|
PRODTOT$nobovi[i] <- paste('#', PRODTOT$nobovi[i], sep='')
|
|
}
|
|
# repro
|
|
if (PRODTOT$anim[i] %in% czhbc$ANIM
|
|
| (!is.na(PRODTOT$NBPRODIPG[i]) & PRODTOT$NBPRODIPG[i] > 0)
|
|
| (!is.na(PRODTOT$nbdescendants[i])
|
|
& as.numeric(PRODTOT$nbdescendants[i]) > 0)) {
|
|
PRODTOT$repro[i] <- 'O'
|
|
} else {
|
|
PRODTOT$repro[i] <- NA
|
|
PRODTOT$nobovi[i] <- PRODTOT$nobovi[i] %>% str_to_lower()
|
|
}
|
|
# mortalite
|
|
if (!is.na(PRODTOT$dasort[i]) & !is.na(PRODTOT$casort[i])
|
|
& PRODTOT$casort[i] == 'M'
|
|
& time_length(interval(PRODTOT$danais[i], PRODTOT$dasort[i]),
|
|
unit="days") < 211){
|
|
PRODTOT$mortsev[i] <- 'O'
|
|
PRODTOT$nobovi[i]=paste(PRODTOT$nobovi[i], ' (MavS)', sep='')
|
|
} else {
|
|
PRODTOT$mortsev[i] <- NA
|
|
}
|
|
# IVV
|
|
if (i > 1) {
|
|
# cas normaux
|
|
if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1])
|
|
& PRODTOT$ravelamere[i] != 1
|
|
& PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + 1
|
|
#& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2'
|
|
& !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) {
|
|
PRODTOT$ivv[i] <- time_length(interval(PRODTOT$danais[i-1],
|
|
PRODTOT$danais[i]),
|
|
unit="days")
|
|
# jumeaux
|
|
} else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1])
|
|
& PRODTOT$ravelamere[i] != 1
|
|
& PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1]
|
|
& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] == '2'
|
|
& !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) {
|
|
PRODTOT$ivv[i] <- PRODTOT$ivv[i-1]
|
|
# rang de v?lage manquant
|
|
} else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1])
|
|
& PRODTOT$ravelamere[i] != 1
|
|
& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2'
|
|
& !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) {
|
|
PRODTOT$ivv[i] <- round(time_length(interval(PRODTOT$danais[i-1],
|
|
PRODTOT$danais[i]),
|
|
unit="days")
|
|
/ (PRODTOT$ravelamere[i]
|
|
- PRODTOT$ravelamere[i-1]), 0)
|
|
} else {
|
|
PRODTOT$ivv[i] <- NA
|
|
}
|
|
}
|
|
}
|
|
|
|
# calcul des effets du cheptel : rang de velage et sexe du veau
|
|
effet <- PRODTOT %>% group_by(typemere, sexbov) %>%
|
|
summarise(m_PN = round(mean(ponais, na.rm=T), 1),
|
|
m_p120 = round(mean(pat04m, na.rm=T), 1),
|
|
m_p210 = round(mean(pat07m, na.rm=T), 1))
|
|
effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_PN[1]
|
|
effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_p120[1]
|
|
effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_p210[1]
|
|
|
|
# calcul des effets du cheptel : sexe sur la repro
|
|
effetsexe <- PRODTOT %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>%
|
|
summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1),
|
|
nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) )
|
|
rapport_MF <- round(subset(effetsexe,
|
|
effetsexe$sexbov == '1')$nbpp_med[1]
|
|
/ subset(effetsexe,
|
|
effetsexe$sexbov == '2')$nbpp_med[1], 0)
|
|
|
|
|
|
# report des effets sur les produitstot
|
|
|
|
for (i in 1:nrow(PRODTOT)) {
|
|
if (PRODTOT$sexbov[i] == '2') { #___________________________________ FEMELLES
|
|
PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] * rapport_MF
|
|
if (!is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #___genisses
|
|
if (!is.na(PRODTOT$ponais[i])) {
|
|
PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_pn[1])
|
|
} else {
|
|
PRODTOT$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat04m[i])) {
|
|
PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_p120[1])
|
|
} else {
|
|
PRODTOT$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat07m[i])) {
|
|
PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_p210[1])
|
|
} else {
|
|
PRODTOT$p210_corr[i] <- NA
|
|
}
|
|
} else { #________________________________________________ vachestot ou inconnu
|
|
if (!is.na(PRODTOT$ponais[i])) {
|
|
PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_pn[1])
|
|
} else {
|
|
PRODTOT$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat04m[i])) {
|
|
PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_p120[1])
|
|
} else {
|
|
PRODTOT$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat07m[i])) {
|
|
PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_p210[1])
|
|
} else {
|
|
PRODTOT$p210_corr[i] <- NA
|
|
}
|
|
}
|
|
} else { #______________________________________________________________ MALES
|
|
PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i]
|
|
if ( !is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #_________________________________genisses
|
|
if (!is.na(PRODTOT$ponais[i])) {
|
|
PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_pn[1])
|
|
} else {
|
|
PRODTOT$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat04m[i])) {
|
|
PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_p120[1])
|
|
} else {
|
|
PRODTOT$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat07m[i])) {
|
|
PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_p210[1])
|
|
} else {
|
|
PRODTOT$p210_corr[i] <- NA
|
|
}
|
|
} else { #_____________________________________________ vachestot ou inconnu
|
|
if (!is.na(PRODTOT$ponais[i])) {
|
|
PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_pn[1])
|
|
} else {
|
|
PRODTOT$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat04m[i])) {
|
|
PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_p120[1])
|
|
} else {
|
|
PRODTOT$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat07m[i])) {
|
|
PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_p210[1])
|
|
} else {
|
|
PRODTOT$p210_corr[i] <- NA
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# calcul des donn?es ?labor?es par vache active
|
|
|
|
for (i in 1:nrow(vachestot)) {
|
|
# ___________________________________________rappel des produitstot par vache
|
|
veaux <- PRODTOT %>% filter(mere == vachestot$anim[i])
|
|
|
|
# ___________________________________________calcul des infos utiles par vache
|
|
|
|
# calcul du poids adulte estim? et synth?se pointage vache ___________________
|
|
if (!is.na(vachestot$dmC[i])) {
|
|
vachestot$ptgV[i] <- round(0.6 * vachestot$dmC[i] + 0.15 * vachestot$ds[i]
|
|
+ 0.25 * vachestot$af[i], 1)
|
|
} else {
|
|
vachestot$ptgV[i] <- NA
|
|
}
|
|
|
|
if (nrow(veaux) > 3){
|
|
vachestot$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2)
|
|
alpha <- 1.62 - 0.01 * vachestot$precocite[i]
|
|
} else {
|
|
vachestot$precocite[i] <- NA
|
|
alpha <- 1.62
|
|
}
|
|
if (!is.na(vachestot$pat24m[i])) {
|
|
vachestot$pad[i] <- round((vachestot$pat24m[i] - 50 * exp(-720 * alpha * 10**(-3)))
|
|
/ (1 - exp(-720 * alpha * 10**(-3))), 1)
|
|
} else if (!is.na(vachestot$pat18m[i])) {
|
|
vachestot$pad[i] <- round((vachestot$pat18m[i] - 50 * exp(-540 * alpha * 10**(-3)))
|
|
/ (1 - exp(-540 * alpha * 10**(-3))), 1)
|
|
} else if (!is.na(vachestot$pat12m[i])) {
|
|
vachestot$pad[i] <- round((vachestot$pat12m[i] - 50 * exp(-360 * alpha * 10**(-3)))
|
|
/ (1-exp(-360 * alpha * 10**(-3))), 1)
|
|
} else {
|
|
vachestot$pad[i] <- NA
|
|
}
|
|
|
|
# calcul des perfs de repro et du temps productif ____________________________
|
|
|
|
vachestot$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1)
|
|
|
|
if (1 %in% veaux$ravelamere) {
|
|
vachestot$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1]
|
|
} else {
|
|
vachestot$agevel1[i] <- NA
|
|
}
|
|
|
|
if (2 %in% veaux$ravelamere) {
|
|
vachestot$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1]
|
|
} else {
|
|
vachestot$ivv1[i] <- NA
|
|
}
|
|
if (3 %in% veaux$ravelamere) {
|
|
vachestot$ivv2p[i] <- round(mean(subset(veaux,
|
|
veaux$ravelamere > 2)$ivv, na.rm=T), 1)
|
|
}
|
|
|
|
if (is.na(vachestot$ivv1[i]) | (!is.na(vachestot$ivv1[i])
|
|
& vachestot$ivv1[i] < 390) ){
|
|
e2 <- 0
|
|
} else if (!is.na(vachestot$ivv1[i]) & vachestot$ivv1[i] >= 390) {
|
|
e2 <- vachestot$ivv1[i] - 390
|
|
}
|
|
if (is.na(vachestot$ivv2p[i]) | (!is.na(vachestot$ivv2p[i])
|
|
& vachestot$ivv2p[i] < 365) ){
|
|
e3 <- 0
|
|
} else if (!is.na(vachestot$ivv2p[i]) & vachestot$ivv2p[i] >= 365) {
|
|
e3 <- vachestot$ivv1[i] - 365
|
|
}
|
|
if (is.na(vachestot$dasort[i])) {
|
|
if (time_length(interval(max(veaux$danais, na.rm=T),
|
|
Sys.Date()), unit="days") < 365) {
|
|
e4 <- 0
|
|
} else {
|
|
e4 <- time_length(interval(max(veaux$danais, na.rm=T),
|
|
Sys.Date()), unit="days") - 365
|
|
}
|
|
} else if (!is.na(vachestot$dasort[i])) {
|
|
if (time_length(interval(max(veaux$danais, na.rm=T),
|
|
vachestot$dasort[i]), unit="days") < 365) {
|
|
e4 <- 0
|
|
} else {
|
|
e4 <- time_length(interval(max(veaux$danais, na.rm=T),
|
|
vachestot$dasort[i]), unit="days") - 365
|
|
}
|
|
}
|
|
|
|
vachestot$tempsprod[i] <- round( (vachestot$age_days[i]
|
|
- ( vachestot$agevel1[i] * 30.4
|
|
+ e2
|
|
+ e3 * (vachestot$nbcampvel[i] - 2)
|
|
+ e4
|
|
)) / vachestot$age_days[i] * 100, 1)
|
|
|
|
# calcul des donn?es synthetiques sur les produitstot ___________________________
|
|
|
|
vachestot$prol[i] <- round(nrow(veaux) / (vachestot$nbcampvel[i]) * 100, 1)
|
|
vachestot$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O'))
|
|
/ nrow(veaux)* 100, 1)
|
|
vachestot$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O'))
|
|
/ nrow(veaux)* 100, 1)
|
|
vachestot$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T)
|
|
vachestot$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T)
|
|
vachestot$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1'))
|
|
/ nrow(veaux)* 100, 1)
|
|
vachestot$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') ))
|
|
/ nrow(veaux)* 100, 1)
|
|
vachestot$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE)
|
|
+ 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1)
|
|
vachestot$pn_m[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '1')$ponais, na.rm=T), 1)
|
|
vachestot$p120_m[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '1')$pat04m, na.rm=T), 1)
|
|
vachestot$p210_m[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '1')$pat07m, na.rm=T), 1)
|
|
vachestot$pn_f[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '2')$ponais, na.rm=T), 1)
|
|
vachestot$p120_f[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '2')$pat04m, na.rm=T), 1)
|
|
vachestot$p210_f[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '2')$pat07m, na.rm=T), 1)
|
|
vachestot$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1)
|
|
vachestot$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1)
|
|
vachestot$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1)
|
|
|
|
### convertion des NaN en NA
|
|
L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr',
|
|
'p210_m','p210_f','p210_corr')
|
|
for (j in L){
|
|
if (is.nan(vachestot[i,j]) == TRUE){
|
|
vachestot[i,j] <- NA
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
# calcul des stats par pere ____________________________________________________
|
|
|
|
stats_peres <- PRODDIR %>% group_by(pere) %>%
|
|
summarise(nb_prod_in_chep = n()) %>% filter(nb_prod_in_chep >=5)
|
|
|
|
stats_peres <- stats_peres %>%
|
|
add_column(utilgen = NA, prol = NA, mort = NA, txrepros = NA, nbpp = NA,
|
|
txvf = NA, pnm = NA, pnf = NA, p120m = NA, p120f = NA, p210m = NA,
|
|
p210f = NA, dmsev = NA, dssev = NA,
|
|
nbfilles_avecprod = NA, pctfilles_avecprod = NA,
|
|
isu_fillestot = NA, age_sort_fillestot = NA,
|
|
agevel1_fillestot = NA, ivv1_fillestot = NA, ivv2p_fillestot = NA,
|
|
vieprod_fillestot = NA, dmad_fillestot = NA, dsad_fillestot = NA,
|
|
afad_fillestot = NA, nbprod_fillestot = NA, txrepros_fillestot = NA,
|
|
nbpp_fillestot = NA, prol_fillestot = NA, mort_fillestot = NA,
|
|
txvf_fillestot = NA,
|
|
nbfillesact_avecprod = NA, pctfillesact_avecprod = NA,
|
|
isu_fillesact = NA, age_sort_fillesact = NA,
|
|
agevel1_fillesact = NA, ivv1_fillesact = NA, ivv2p_fillesact = NA,
|
|
vieprod_fillesact = NA, dmad_fillesact = NA, dsad_fillesact = NA,
|
|
afad_fillesact = NA, nbprod_fillesact = NA, txrepros_fillesact = NA,
|
|
nbpp_fillesact = NA, prol_fillesact = NA, mort_fillesact = NA,
|
|
txvf_fillesact = NA, nbfilles_renouv = NA)
|
|
|
|
for (i in 1:nrow(stats_peres)) {
|
|
# stats sur la prod directe __________________________________________________
|
|
li_prod <- subset(PRODDIR, PRODDIR$pere == stats_peres$pere[i])
|
|
|
|
stats_peres$utilgen[i] <- round(nrow(subset(li_prod,
|
|
li_prod$ravelamere == 1))
|
|
/ nrow(li_prod) * 100, 1)
|
|
stats_peres$prol[i] <- round(nrow(li_prod)
|
|
/ nrow(li_prod %>% distinct(danais, mere))
|
|
* 100, 1)
|
|
stats_peres$mort[i] <- round(nrow(subset(li_prod, li_prod$mortsev == 'O'))
|
|
/ nrow(li_prod) * 100, 1)
|
|
stats_peres$txrepros[i] <- round(nrow(subset(li_prod, li_prod$repro == 'O'))
|
|
/ nrow(subset(li_prod,
|
|
is.na(li_prod$mortsev))) * 100, 1)
|
|
stats_peres$nbpp[i] <- sum(li_prod$nbdescendants)
|
|
stats_peres$txvf[i] <- round(nrow(subset(li_prod, li_prod$conais %in% c('1','2')))
|
|
/ nrow(li_prod) * 100, 1)
|
|
stats_peres$pnm[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '1')$ponais, na.rm=T),1)
|
|
stats_peres$pnf[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '2')$ponais, na.rm=T),1)
|
|
stats_peres$p120m[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '1')$pat04m, na.rm=T),1)
|
|
stats_peres$p120f[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '2')$pat04m, na.rm=T),1)
|
|
stats_peres$p210m[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '1')$pat07m, na.rm=T),1)
|
|
stats_peres$p210f[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '2')$pat07m, na.rm=T),1)
|
|
stats_peres$dmsev[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '1')$devmus, na.rm=T),1)
|
|
stats_peres$dssev[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '2')$devsqe, na.rm=T),1)
|
|
|
|
# stats sur la prod par les filles ___________________________________________
|
|
li_filles <- subset(vachestot, vachestot$pere == stats_peres$pere[i])
|
|
|
|
# modif du 30/04/2024
|
|
if (nrow(li_filles) > 0){
|
|
stats_peres$nbfilles_avecprod[i] <- nrow(li_filles)
|
|
stats_peres$pctfilles_avecprod[i] <- round(nrow(li_filles)
|
|
/ nrow(subset(li_prod,
|
|
li_prod$sexbov == '2'))
|
|
* 100, 1)
|
|
}
|
|
|
|
if (nrow(li_filles) >= 3) {
|
|
stats_peres$isu_fillestot[i] <- round(mean(li_filles$indisu, na.rm=T),1)
|
|
stats_peres$age_sort_fillestot[i] <- round(mean(li_filles$age_years, na.rm=T),1)
|
|
stats_peres$agevel1_fillestot[i] <- round(mean(li_filles$agevel1, na.rm=T),1)
|
|
stats_peres$vieprod_fillestot[i] <- round(mean(li_filles$tempsprod, na.rm=T),1)
|
|
stats_peres$ivv1_fillestot[i] <- round(mean(li_filles$ivv1, na.rm=T),1)
|
|
stats_peres$ivv2p_fillestot[i] <- round(mean(li_filles$ivv2p, na.rm=T),1)
|
|
|
|
stats_peres$dmad_fillestot[i] <- round(mean(li_filles$dmC, na.rm=T),1)
|
|
stats_peres$dsad_fillestot[i] <- round(mean(li_filles$ds, na.rm=T),1)
|
|
stats_peres$afad_fillestot[i] <- round(mean(li_filles$af, na.rm=T),1)
|
|
|
|
stats_peres$prol_fillestot[i] <- round(mean(li_filles$prol, na.rm=T),1)
|
|
stats_peres$mort_fillestot[i] <- round(mean(li_filles$mort, na.rm=T),1)
|
|
stats_peres$txvf_fillestot[i] <- round(mean(li_filles$txvf, na.rm=T),1)
|
|
|
|
stats_peres$nbprod_fillestot[i] <- round(sum(li_filles$nbdescendants),1)
|
|
stats_peres$txrepros_fillestot[i] <- round(mean(li_filles$txrepros, na.rm=T),1)
|
|
stats_peres$nbpp_fillestot[i] <- round(sum(li_filles$nbpp),1)
|
|
}
|
|
|
|
# stats sur la prod par les filles actives ___________________________________
|
|
li_filles_act <- subset(vachestot, vachestot$pere == stats_peres$pere[i]
|
|
& is.na(vachestot$dasort))
|
|
|
|
# modif du 30/04/2024
|
|
if (nrow(li_filles_act) > 0) {
|
|
stats_peres$nbfillesact_avecprod[i] <- nrow(li_filles_act)
|
|
stats_peres$pctfillesact_avecprod[i] <- round(nrow(li_filles_act)
|
|
/ nrow(subset(li_prod,
|
|
li_prod$sexbov == '2'))
|
|
* 100, 1)
|
|
}
|
|
|
|
if (nrow(li_filles_act) >= 3) {
|
|
stats_peres$isu_fillesact[i] <- round(mean(li_filles_act$indisu, na.rm=T),1)
|
|
stats_peres$age_sort_fillesact[i] <- round(mean(li_filles_act$age_years, na.rm=T),1)
|
|
stats_peres$agevel1_fillesact[i] <- round(mean(li_filles_act$agevel1, na.rm=T),1)
|
|
stats_peres$vieprod_fillesact[i] <- round(mean(li_filles_act$tempsprod, na.rm=T),1)
|
|
stats_peres$ivv1_fillesact[i] <- round(mean(li_filles_act$ivv1, na.rm=T),1)
|
|
stats_peres$ivv2p_fillesact[i] <- round(mean(li_filles_act$ivv2p, na.rm=T),1)
|
|
|
|
stats_peres$dmad_fillesact[i] <- round(mean(li_filles_act$dmC, na.rm=T),1)
|
|
stats_peres$dsad_fillesact[i] <- round(mean(li_filles_act$ds, na.rm=T),1)
|
|
stats_peres$afad_fillesact[i] <- round(mean(li_filles_act$af, na.rm=T),1)
|
|
|
|
stats_peres$prol_fillesact[i] <- round(mean(li_filles_act$prol, na.rm=T),1)
|
|
stats_peres$mort_fillesact[i] <- round(mean(li_filles_act$mort, na.rm=T),1)
|
|
stats_peres$txvf_fillesact[i] <- round(mean(li_filles_act$txvf, na.rm=T),1)
|
|
|
|
stats_peres$nbprod_fillesact[i] <- round(sum(li_filles_act$nbdescendants),1)
|
|
stats_peres$txrepros_fillesact[i] <- round(mean(li_filles_act$txrepros, na.rm=T),1)
|
|
stats_peres$nbpp_fillesact[i] <- round(sum(li_filles_act$nbpp),1)
|
|
}
|
|
#filles a venir
|
|
nbfr <- nrow(subset(inventaire,
|
|
inventaire$pere == stats_peres$pere[i]
|
|
& inventaire$nbdescendants == 0
|
|
& inventaire$sexbov == '2'))
|
|
if (nbfr > 0 ){
|
|
stats_peres$nbfilles_renouv[i] <- nbfr
|
|
}
|
|
}
|
|
|
|
stats_peres <- merge(peres, stats_peres, all.x=F, all.y=T)
|
|
|
|
write.table(stats_peres,
|
|
file = paste(rep, '/', CHEP, '_ResTaureaux_eCow5.csv', sep = ""),
|
|
quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE,
|
|
sep = ";", qmethod = c("escape"), na = "")
|
|
|
|
|
|
################################################################################
|
|
### remontee des lignees femelles ##############################################
|
|
################################################################################
|
|
|
|
hbcgene_coltypes <- cols(anim = col_character(), nobovi = col_character(),
|
|
nomnais = col_character(), qualifco = col_character(),
|
|
pere = col_character(), mere = col_character(),
|
|
dcre = col_character(), danais = col_character(),
|
|
ifnais = col_integer(), crsevs = col_integer(),
|
|
dmsevs = col_integer(), dssevs = col_integer(),
|
|
alaits = col_integer(), isevre = col_integer(),
|
|
ivmate = col_integer(), iqmqms = col_integer(),
|
|
iabjbs = col_integer(), avelag = col_integer(),
|
|
indisu = col_integer(),
|
|
cdisev = col_number())
|
|
|
|
## on remonte vers les fondatrices
|
|
|
|
femelles <- inventaire %>% filter(sexbov == '2')
|
|
femelles[] <- lapply(femelles, function(x) if(is.logical(x)) as.character(x) else x)
|
|
|
|
old <- Sys.time()
|
|
|
|
t_travail <- femelles
|
|
t_temp = t_final <- inventaire[0,]
|
|
|
|
line_mere <- inventaire[0,]
|
|
#line_mere$iqmqms = line_mere$iabjbs <- NA
|
|
|
|
# mise en commentaire : 07/03/2023
|
|
# t_travail[] <- lapply(t_travail, function(x) if(is.Date(x)) as.character(x) else x)
|
|
# t_final[] <- lapply(t_final, function(x) if(is.Date(x)) as.character(x) else x)
|
|
# t_temp[] <- lapply(t_temp, function(x) if(is.Date(x)) as.character(x) else x)
|
|
|
|
t_travail[] <- lapply(t_travail, function(x) if(is.logical(x)) as.character(x) else x)
|
|
t_final[] <- lapply(t_final, function(x) if(is.logical(x)) as.character(x) else x)
|
|
t_temp[] <- lapply(t_temp, function(x) if(is.logical(x)) as.character(x) else x)
|
|
|
|
nbl <- nrow(t_travail)
|
|
nb_tours <- 0
|
|
|
|
while (nbl > 0) {
|
|
for (i in 1:nrow(t_travail)) {
|
|
if (!is.na(t_travail$mere[i])) {
|
|
if ((trim_str(t_travail$mere[i]) %in% trim_str(t_final$anim))
|
|
| (trim_str(t_travail$mere[i]) %in% trim_str(t_travail$anim))
|
|
| (trim_str(t_travail$mere[i]) %in% trim_str(t_temp$anim))) {
|
|
#print(paste0(as.character(i), "D?ja list?e"))
|
|
} else {
|
|
#print(t_travail$mere[i])
|
|
line_mere <- chgt_infos(trim_str(t_travail$mere[i]))
|
|
if (is.data.frame(line_mere)) {
|
|
if (nrow(line_mere) > 0 ) {
|
|
|
|
# ajout du 07/03/2023
|
|
line_mere <- line_mere[, intersect(names(line_mere), names(femelles))]
|
|
line_mere[] <- lapply(line_mere, function(x) if(is.logical(x)) as.character(x) else x)
|
|
for ( x in colnames(line_mere) ) {
|
|
line_mere[,x] <- eval(call( paste0("as.", class(femelles[,x])), line_mere[,x]) )
|
|
}
|
|
|
|
if (ncol(line_mere) > 22) {
|
|
# attribution a line_mere les memes types de col que inventaire
|
|
# afin de permettre la jointure sans erreur de type
|
|
|
|
# modif : mise en commentaire 07/03/2023
|
|
# line_mere$iqmqms = line_mere$iabjbs <- NA
|
|
# line_mere <- line_mere[, colnames(t_final)]
|
|
# line_mere[] <- mapply(FUN = as, line_mere, sapply(t_final, class), SIMPLIFY = FALSE)
|
|
|
|
if ( !is.na(line_mere$chna) & trim_str(line_mere$chna) == CHEP) {
|
|
t_temp <- bind_rows(t_temp, line_mere)
|
|
} else {
|
|
#print("N?e ailleurs")
|
|
t_final <- bind_rows(t_final, line_mere)
|
|
}
|
|
} else {
|
|
#print("Ligne de Hbcgene")
|
|
# attribution a line_mere les types de col definis plus haut
|
|
# afin de permettre la jointure sans erreur de type
|
|
|
|
# modif : mise en commentaire 07/03/2023
|
|
# line_mere <- type.convert(line_mere, col_types = hbcgene_coltypes)
|
|
# line_mere$nobovi <- as.character(line_mere$nobovi)
|
|
|
|
#cat(i, class(line_mere$indite), class(t_final$indite)) # pb de types
|
|
t_final <- bind_rows(t_final, line_mere)
|
|
}
|
|
}
|
|
} else {
|
|
#print("Retour vide du WS")
|
|
}
|
|
}
|
|
} else {
|
|
#print("Pas de mere")
|
|
}
|
|
} # for
|
|
t_final <- bind_rows(t_final, t_travail)
|
|
t_travail <- t_temp
|
|
t_temp <- t_temp[0,]
|
|
nbl <- nrow(t_travail)
|
|
nb_tours <- nb_tours+1
|
|
print(paste("Nombre de g?n?rations depuis les animaux actifs : ", nb_tours, sep=''))
|
|
} # while
|
|
|
|
inv_asc <- t_final
|
|
|
|
fondatrices <- subset(inv_asc, is.na(t_final$mere)
|
|
| trim_str(t_final$chna) != CHEP
|
|
| is.na(t_final$chna)
|
|
| !(trim_str(inv_asc$mere) %in% trim_str(inv_asc$anim)) ) # modif du 27/03/2023
|
|
|
|
new <- Sys.time()-old
|
|
cat("Remont?e des lign?es :", round(new, 1) , "sec")
|
|
|
|
# on redescendant vers tous les animaux n?s dans le cheptel issus des fondatrices
|
|
# on met de c?t? les vaches ayant produits a leur tour dans le cheptel
|
|
# ainsi que les males ayant produit (peu importe ou)
|
|
|
|
old <- Sys.time()
|
|
|
|
t_travail <- fondatrices
|
|
t_travail$fondatrice <- t_travail$anim
|
|
t_temp = t_final <- inventaire[0,]
|
|
t_final <- t_final %>% add_column(fondatrice = NA, iqmqms = NA, iabjbs = NA)
|
|
t_temp <- t_temp %>% add_column(fondatrice = NA, iqmqms = NA, iabjbs = NA)
|
|
|
|
t_travail[] <- lapply(t_travail, function(x) if(is.logical(x)) as.character(x) else x)
|
|
t_final[] <- lapply(t_final, function(x) if(is.logical(x)) as.character(x) else x)
|
|
t_temp[] <- lapply(t_temp, function(x) if(is.logical(x)) as.character(x) else x)
|
|
# mise en commentaire : 07/03/2023
|
|
# t_travail[] <- lapply(t_travail, function(x) if(is.Date(x)) as.character(x) else x)
|
|
# t_final[] <- lapply(t_final, function(x) if(is.Date(x)) as.character(x) else x)
|
|
# t_temp[] <- lapply(t_temp, function(x) if(is.Date(x)) as.character(x) else x)
|
|
|
|
nbl <- nrow(t_travail)
|
|
nb_tours <- 0
|
|
|
|
while (nbl > 0) {
|
|
for (i in 1:nrow(t_travail)) {
|
|
cat(nbl, i, t_travail$anim[i], t_travail$nobovi[i], '\n')
|
|
produits <- try(appel_infos(trim_str(t_travail$anim[i]), reqMere))
|
|
if (!is.null(produits)) {
|
|
|
|
# MAJ du 07/03/2023
|
|
produits <- produits[, intersect(names(produits), names(femelles))]
|
|
produits[] <- lapply(produits, function(x) if(is.logical(x)) as.character(x) else x)
|
|
for ( x in colnames(produits) ) {
|
|
produits[,x] <- eval(call( paste0("as.", class(femelles[,x])), produits[,x]) )
|
|
}
|
|
|
|
# modif : mise en commentaire 07/03/2023
|
|
# produits$iqmqms = produits$iabjbs = produits$fondatrice <- NA
|
|
# produits <- produits[,colnames(t_final)]
|
|
# produits[] <- mapply(FUN = as, produits, sapply(t_final, class), SIMPLIFY = FALSE)
|
|
# produits[] <- lapply(produits, function(x) if(is.logical(x)) as.character(x) else x)
|
|
# produits[] <- lapply(produits, function(x) if(is.Date(x)) as.character(x) else x)
|
|
|
|
produits <- subset(produits, trim_str(produits$chna) == CHEP)
|
|
if (length(produits) > 0 & nrow(produits) > 0){
|
|
produits$fondatrice <- t_travail$fondatrice[i]
|
|
t_final <- bind_rows(t_final, produits)
|
|
repros <- subset(produits, produits$nbdescendants > 0
|
|
& produits$sexbov == '2')
|
|
if (nrow(repros) > 0) {
|
|
t_temp <- bind_rows(t_temp, repros)
|
|
}
|
|
}
|
|
}
|
|
} # for
|
|
t_final <- bind_rows(t_final, t_travail)
|
|
t_travail <- t_temp
|
|
t_temp <- t_temp[0,]
|
|
nbl <- nrow(t_travail)
|
|
nb_tours <- nb_tours+1
|
|
print(paste("Nombre de g?n?rations apras les fondatrices : ", nb_tours, sep=''))
|
|
} # while
|
|
|
|
inv_desc <- t_final
|
|
|
|
# doublons ???
|
|
inv_desc <- inv_desc[-which(duplicated(inv_desc$anim)),]
|
|
if (nrow(inv_desc) == 0 ){
|
|
inv_desc <- t_final
|
|
}
|
|
|
|
# modif du 07/03/2023
|
|
# pb du nombre de produits non ramenés par WS en appellant la mère
|
|
# inv_asc_not_in_desc <- inv_asc %>% filter( !(trim_str(anim) %in% trim_str(inv_desc$anim)) )
|
|
# if ( nrow(inv_asc_not_in_desc) > 0) {
|
|
# inv_desc <- bind_rows(inv_desc, inv_asc_not_in_desc)
|
|
# }
|
|
|
|
new <- Sys.time()-old
|
|
cat("Remont?e des lign?es :", round(new, 1))
|
|
|
|
# vaches tot
|
|
vachestot <- inv_desc %>% filter(sexbov == '2' & nbdescendants > 0)
|
|
produitstot <- subset(inv_desc, trim_str(inv_desc$mere) %in% trim_str(vachestot$anim))
|
|
|
|
if (nrow(vachestot) > 0) {
|
|
# recherche des meres dans les porteuses pour aller chercher
|
|
# les produitstot s'ils existent dans HBCANIM
|
|
|
|
porteuses <- subset(indite, !is.na(indite$MEREIPG)
|
|
& indite$MEREIPG %in% trim_str(vachestot$anim))
|
|
donneuses <- subset(indite, !is.na(indite$MERECPB)
|
|
& indite$MERECPB %in% trim_str(vachestot$anim))
|
|
# l'indicateur de donneuse d'embryon est renseign? apres dans --> vachestot$ACINAC
|
|
|
|
if ( is.numeric(vachestot$danais[1]) & vachestot$danais[1] > 1*(10**8) ) {
|
|
vachestot$danais <- as.Date(as.POSIXct(vachestot$danais / 1000, origin="1970-01-01"))
|
|
vachestot$dasort <- as.Date(as.POSIXct(vachestot$dasort / 1000, origin="1970-01-01"))
|
|
}
|
|
|
|
for (i in 1:nrow(vachestot)) {
|
|
if (is.na(vachestot$dasort[i])){
|
|
vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], Sys.Date()), unit="days")
|
|
} else {
|
|
vachestot$age_days[i] <- time_length(interval(vachestot$danais[i], vachestot$dasort[i]), unit="days")
|
|
}
|
|
}
|
|
|
|
vachestot$age_years <- round(vachestot$age_days / 365, 1)
|
|
|
|
# les veaux port?s sont rajout?s aux produitstot si non r?cup?r?s avant ________ non appliqu? car raisonnement sur lign?es
|
|
# if (nrow(porteuses) > 0) {
|
|
# for (i in 1:nrow(porteuses)) {
|
|
# if (!(porteuses$ANIM[i] %in% trim_str(produitstot$anim))) {
|
|
#
|
|
# temp <- appel_infos(porteuses$ANIM[i], hbcanim) # a voir : gerer les retours vides !!!!
|
|
# li_mere <- subset(vachestot, vachestot$anim == porteuses$MEREIPG[i])
|
|
#
|
|
# temp$mere[1] <- porteuses$MEREIPG[i]
|
|
# temp[1, c(60:67, 86:103)] <- NA
|
|
# temp$danaismere[1] <- as.character(li_mere$danais[1])
|
|
# temp$indite[1] <- 'O_corr'
|
|
#
|
|
# produitstot <- rbind(produitstot, temp)
|
|
# }
|
|
# }
|
|
# }
|
|
|
|
# modifs des types de donn?es, pour calcul par la suite
|
|
if ( is.numeric(produitstot$danais[1]) & produitstot$danais[1] > 1*(10**8) ) {
|
|
produitstot$danais <- as.Date(as.POSIXct(produitstot$danais / 1000, origin="1970-01-01"))
|
|
produitstot$dasort <- as.Date(as.POSIXct(produitstot$dasort / 1000, origin="1970-01-01"))
|
|
produitstot$danaismere <- as.Date(as.POSIXct(produitstot$danaismere / 1000, origin="1970-01-01"))
|
|
}
|
|
|
|
test_date <- produitstot %>% filter( !is.na(danaismere) )
|
|
if (nrow(test_date) > 0){
|
|
if ( is.numeric(test_date$danaismere[1]) & test_date$danaismere[1] > 1*(10**8) ) {
|
|
produitstot$danaismere <- as.Date(as.POSIXct(produitstot$danaismere / 1000, origin="1970-01-01"))
|
|
}
|
|
}
|
|
|
|
produitstot$danais <- as.Date(produitstot$danais, format = "%Y-%m-%d")
|
|
produitstot$dasort <- as.Date(produitstot$dasort, format = "%Y-%m-%d")
|
|
|
|
produitstot$mere <- trim_str(produitstot$mere)
|
|
produitstot$pere <- trim_str(produitstot$pere)
|
|
produitstot$anim <- trim_str(produitstot$anim)
|
|
|
|
produitstot$ravelamere <- as.numeric(produitstot$ravelamere)
|
|
produitstot$ivv <- as.numeric(produitstot$ivv)
|
|
produitstot$campn <- as.numeric(produitstot$campn)
|
|
produitstot$nbdescendants <- as.numeric(produitstot$nbdescendants)
|
|
|
|
produitstot$ponais <- as.numeric(produitstot$ponais)
|
|
produitstot$pat04m <- as.numeric(produitstot$pat04m)
|
|
produitstot$pat07m <- as.numeric(produitstot$pat07m)
|
|
|
|
produitstot$devsqe <- as.numeric(produitstot$devsqe)
|
|
produitstot$devmus <- as.numeric(produitstot$devmus)
|
|
produitstot$aptfon <- as.numeric(produitstot$aptfon)
|
|
|
|
# on ne garde que les TE port?s par une vache active du cheptel
|
|
PRODTOT <- subset(produitstot, produitstot$indite != 'O')
|
|
|
|
# ajout des produitstot IPG
|
|
PRODTOT <- merge(PRODTOT, parentsIPG, by.x='anim', by.y='ANIM', all.x=T, all.y=F)
|
|
|
|
PRODTOT <- PRODTOT[order(PRODTOT$danais, decreasing = F),]
|
|
PRODTOT <- PRODTOT[order(PRODTOT$mere, decreasing = T),]
|
|
|
|
# correction des ravelamere des TE si possible
|
|
for (i in 1:nrow(PRODTOT)) {
|
|
if (is.na(PRODTOT$ravelamere[i])) {
|
|
if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] %in% c(1, 2)) {
|
|
PRODTOT$ravelamere[i] <- 1
|
|
PRODTOT$typemere[i] <- 'G'
|
|
} else if (!is.na(PRODTOT$ravelamere[i+1]) & PRODTOT$ravelamere[i+1] > 1) {
|
|
PRODTOT$ravelamere[i] <- PRODTOT$ravelamere[i+1] - 1
|
|
PRODTOT$typemere[i] <- 'V'
|
|
}
|
|
}
|
|
}
|
|
|
|
# age au velage de la mere
|
|
PRODTOT$agevel <- round(time_length(interval(PRODTOT$danaismere, PRODTOT$danais),
|
|
unit="months"), 1)
|
|
|
|
# IVV : utilisation de la colonne deja pr?sente de HBCANIM
|
|
|
|
for (i in 1:nrow(PRODTOT)) {
|
|
if (PRODTOT$indite[i] == 'O_corr') {
|
|
PRODTOT$nobovi[i] <- paste('#', PRODTOT$nobovi[i], sep='')
|
|
}
|
|
# repro
|
|
if (PRODTOT$anim[i] %in% czhbc$ANIM
|
|
| (!is.na(PRODTOT$NBPRODIPG[i]) & PRODTOT$NBPRODIPG[i] > 0)
|
|
| (!is.na(PRODTOT$nbdescendants[i])
|
|
& as.numeric(PRODTOT$nbdescendants[i]) > 0)) {
|
|
PRODTOT$repro[i] <- 'O'
|
|
} else {
|
|
PRODTOT$repro[i] <- NA
|
|
PRODTOT$nobovi[i] <- PRODTOT$nobovi[i] %>% str_to_lower()
|
|
}
|
|
# mortalite
|
|
if (!is.na(PRODTOT$dasort[i]) & !is.na(PRODTOT$casort[i])
|
|
& PRODTOT$casort[i] == 'M'
|
|
& time_length(interval(PRODTOT$danais[i], PRODTOT$dasort[i]),
|
|
unit="days") < 211){
|
|
PRODTOT$mortsev[i] <- 'O'
|
|
PRODTOT$nobovi[i]=paste(PRODTOT$nobovi[i], ' (MavS)', sep='')
|
|
} else {
|
|
PRODTOT$mortsev[i] <- NA
|
|
}
|
|
# IVV
|
|
if (i > 1) {
|
|
# cas normaux
|
|
if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1])
|
|
& PRODTOT$ravelamere[i] != 1
|
|
& PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1] + 1
|
|
#& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2'
|
|
& !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) {
|
|
PRODTOT$ivv[i] <- time_length(interval(PRODTOT$danais[i-1],
|
|
PRODTOT$danais[i]),
|
|
unit="days")
|
|
# jumeaux
|
|
} else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1])
|
|
& PRODTOT$ravelamere[i] != 1
|
|
& PRODTOT$ravelamere[i] == PRODTOT$ravelamere[i-1]
|
|
& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] == '2'
|
|
& !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) {
|
|
PRODTOT$ivv[i] <- PRODTOT$ivv[i-1]
|
|
# rang de v?lage manquant
|
|
} else if (!is.na(PRODTOT$ravelamere[i]) & !is.na(PRODTOT$ravelamere[i-1])
|
|
& PRODTOT$ravelamere[i] != 1
|
|
& !is.na(PRODTOT$cofgmumere[i]) & PRODTOT$cofgmumere[i] != '2'
|
|
& !is.na(PRODTOT$mere[i]) & PRODTOT$mere[i] == PRODTOT$mere[i-1]) {
|
|
PRODTOT$ivv[i] <- round(time_length(interval(PRODTOT$danais[i-1],
|
|
PRODTOT$danais[i]),
|
|
unit="days")
|
|
/ (PRODTOT$ravelamere[i]
|
|
- PRODTOT$ravelamere[i-1]), 0)
|
|
} else {
|
|
PRODTOT$ivv[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$ivv[i]) & PRODTOT$ivv[i] < 280) {
|
|
PRODTOT$ivv[i] <- NA
|
|
}
|
|
}
|
|
}
|
|
|
|
# calcul des effets du cheptel : rang de velage et sexe du veau
|
|
effet <- PRODTOT %>% group_by(typemere, sexbov) %>%
|
|
summarise(m_PN = round(mean(ponais, na.rm=T), 1),
|
|
m_p120 = round(mean(pat04m, na.rm=T), 1),
|
|
m_p210 = round(mean(pat07m, na.rm=T), 1))
|
|
effet$diff_pn <- effet$m_PN - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_PN[1]
|
|
effet$diff_p120 <- effet$m_p120 - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_p120[1]
|
|
effet$diff_p210 <- effet$m_p210 - subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$m_p210[1]
|
|
|
|
# calcul des effets du cheptel : sexe sur la repro
|
|
effetsexe <- PRODTOT %>% filter(NBPRODIPG > 0) %>% group_by(sexbov) %>%
|
|
summarise(nbpp = round(mean(NBPRODIPG, na.rm=T), 1),
|
|
nbpp_med = round(median(NBPRODIPG, na.rm=T), 1) )
|
|
rapport_MF <- round(subset(effetsexe,
|
|
effetsexe$sexbov == '1')$nbpp_med[1]
|
|
/ subset(effetsexe,
|
|
effetsexe$sexbov == '2')$nbpp_med[1], 0)
|
|
|
|
|
|
# report des effets sur les produitstot
|
|
|
|
for (i in 1:nrow(PRODTOT)) {
|
|
if (PRODTOT$sexbov[i] == '2') { #___________________________________ FEMELLES
|
|
PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i] * rapport_MF
|
|
if (!is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #___genisses
|
|
if (!is.na(PRODTOT$ponais[i])) {
|
|
PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_pn[1])
|
|
} else {
|
|
PRODTOT$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat04m[i])) {
|
|
PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_p120[1])
|
|
} else {
|
|
PRODTOT$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat07m[i])) {
|
|
PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'G')$diff_p210[1])
|
|
} else {
|
|
PRODTOT$p210_corr[i] <- NA
|
|
}
|
|
} else { #________________________________________________ vachestot ou inconnu
|
|
if (!is.na(PRODTOT$ponais[i])) {
|
|
PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_pn[1])
|
|
} else {
|
|
PRODTOT$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat04m[i])) {
|
|
PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_p120[1])
|
|
} else {
|
|
PRODTOT$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat07m[i])) {
|
|
PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '2'
|
|
& effet$typemere == 'V')$diff_p210[1])
|
|
} else {
|
|
PRODTOT$p210_corr[i] <- NA
|
|
}
|
|
}
|
|
} else { #______________________________________________________________ MALES
|
|
PRODTOT$nbpp_corr[i] <- PRODTOT$NBPRODIPG[i]
|
|
if ( !is.na(PRODTOT$typemere[i]) & PRODTOT$typemere[i] == 'G') { #_________________________________genisses
|
|
if (!is.na(PRODTOT$ponais[i])) {
|
|
PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_pn[1])
|
|
} else {
|
|
PRODTOT$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat04m[i])) {
|
|
PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_p120[1])
|
|
} else {
|
|
PRODTOT$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat07m[i])) {
|
|
PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'G')$diff_p210[1])
|
|
} else {
|
|
PRODTOT$p210_corr[i] <- NA
|
|
}
|
|
} else { #_____________________________________________ vachestot ou inconnu
|
|
if (!is.na(PRODTOT$ponais[i])) {
|
|
PRODTOT$pn_corr[i] <- (PRODTOT$ponais[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_pn[1])
|
|
} else {
|
|
PRODTOT$pn_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat04m[i])) {
|
|
PRODTOT$p120_corr[i] <- (PRODTOT$pat04m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_p120[1])
|
|
} else {
|
|
PRODTOT$p120_corr[i] <- NA
|
|
}
|
|
if (!is.na(PRODTOT$pat07m[i])) {
|
|
PRODTOT$p210_corr[i] <- (PRODTOT$pat07m[i]
|
|
+ subset(effet, effet$sexbov == '1'
|
|
& effet$typemere == 'V')$diff_p210[1])
|
|
} else {
|
|
PRODTOT$p210_corr[i] <- NA
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# calcul des donn?es ?labor?es par vache active
|
|
|
|
for (i in 1:nrow(vachestot)) {
|
|
# ___________________________________________rappel des produitstot par vache
|
|
veaux <- PRODTOT %>% filter(mere == trim_str(vachestot$anim[i]))
|
|
|
|
# ___________________________________________calcul des infos utiles par vache
|
|
|
|
# calcul du poids adulte estim? et synthese pointage vache ___________________
|
|
if (!is.na(vachestot$dmC[i])) {
|
|
vachestot$ptgV[i] <- round(0.6 * vachestot$dmC[i] + 0.15 * vachestot$ds[i]
|
|
+ 0.25 * vachestot$af[i], 1)
|
|
} else {
|
|
vachestot$ptgV[i] <- NA
|
|
}
|
|
|
|
if (nrow(veaux) > 3){
|
|
vachestot$precocite[i] <- round(mean((veaux$devsqe - veaux$devmus), na.rm=TRUE), 2)
|
|
alpha <- 1.62 - 0.01 * vachestot$precocite[i]
|
|
} else {
|
|
vachestot$precocite[i] <- NA
|
|
alpha <- 1.62
|
|
}
|
|
if (!is.na(vachestot$pat24m[i])) {
|
|
vachestot$pad[i] <- round((as.numeric(vachestot$pat24m[i]) - 50 * exp(-720 * alpha * 10**(-3)))
|
|
/ (1 - exp(-720 * alpha * 10**(-3))), 1)
|
|
} else if (!is.na(vachestot$pat18m[i])) {
|
|
vachestot$pad[i] <- round((as.numeric(vachestot$pat18m[i]) - 50 * exp(-540 * alpha * 10**(-3)))
|
|
/ (1 - exp(-540 * alpha * 10**(-3))), 1)
|
|
} else if (!is.na(vachestot$pat12m[i])) {
|
|
vachestot$pad[i] <- round((as.numeric(vachestot$pat12m[i]) - 50 * exp(-360 * alpha * 10**(-3)))
|
|
/ (1-exp(-360 * alpha * 10**(-3))), 1)
|
|
} else {
|
|
vachestot$pad[i] <- NA
|
|
}
|
|
|
|
# calcul des perfs de repro et du temps productif ____________________________
|
|
|
|
vachestot$nbcampvel[i] <- (max(veaux$campn) - min(veaux$campn) + 1)
|
|
|
|
if (1 %in% veaux$ravelamere) {
|
|
vachestot$agevel1[i] <- subset(veaux, veaux$ravelamere == 1)$agevel[1]
|
|
} else {
|
|
vachestot$agevel1[i] <- NA
|
|
}
|
|
|
|
if (2 %in% veaux$ravelamere) {
|
|
vachestot$ivv1[i] <- subset(veaux, veaux$ravelamere == 2)$ivv[1]
|
|
} else {
|
|
vachestot$ivv1[i] <- NA
|
|
}
|
|
if (3 %in% veaux$ravelamere) {
|
|
vachestot$ivv2p[i] <- round(mean(subset(veaux,
|
|
veaux$ravelamere > 2)$ivv, na.rm=T), 1)
|
|
}
|
|
|
|
if (is.na(vachestot$ivv1[i]) | (!is.na(vachestot$ivv1[i])
|
|
& vachestot$ivv1[i] < 390) ){
|
|
e2 <- 0
|
|
} else if (!is.na(vachestot$ivv1[i]) & vachestot$ivv1[i] >= 390) {
|
|
e2 <- vachestot$ivv1[i] - 390
|
|
}
|
|
if (is.na(vachestot$ivv2p[i]) | (!is.na(vachestot$ivv2p[i])
|
|
& vachestot$ivv2p[i] < 365) ){
|
|
e3 <- 0
|
|
} else if (!is.na(vachestot$ivv2p[i]) & vachestot$ivv2p[i] >= 365) {
|
|
e3 <- vachestot$ivv1[i] - 365
|
|
}
|
|
if (is.na(vachestot$dasort[i])) {
|
|
if (time_length(interval(max(veaux$danais, na.rm=T),
|
|
Sys.Date()), unit="days") < 365) {
|
|
e4 <- 0
|
|
} else {
|
|
e4 <- time_length(interval(max(veaux$danais, na.rm=T),
|
|
Sys.Date()), unit="days") - 365
|
|
}
|
|
} else if (!is.na(vachestot$dasort[i])) {
|
|
if (time_length(interval(max(veaux$danais, na.rm=T),
|
|
vachestot$dasort[i]), unit="days") < 365) {
|
|
e4 <- 0
|
|
} else {
|
|
e4 <- time_length(interval(max(veaux$danais, na.rm=T),
|
|
vachestot$dasort[i]), unit="days") - 365
|
|
}
|
|
}
|
|
|
|
vachestot$tempsprod[i] <- round( (vachestot$age_days[i]
|
|
- ( vachestot$agevel1[i] * 30.4
|
|
+ e2
|
|
+ e3 * (vachestot$nbcampvel[i] - 2)
|
|
+ e4
|
|
)) / vachestot$age_days[i] * 100, 1)
|
|
|
|
# calcul des donn?es synthetiques sur les produitstot ___________________________
|
|
|
|
vachestot$prol[i] <- round(nrow(veaux) / (vachestot$nbcampvel[i]) * 100, 1)
|
|
vachestot$mort[i] <- round(nrow(subset(veaux, veaux$mortsev == 'O'))
|
|
/ nrow(veaux)* 100, 1)
|
|
vachestot$txrepros[i] <- round(nrow(subset(veaux, veaux$repro == 'O'))
|
|
/ nrow(veaux)* 100, 1)
|
|
vachestot$nbpp[i] <- sum(veaux$NBPRODIPG, na.rm=T)
|
|
vachestot$nbpp_corr[i] <- sum(veaux$nbpp_corr, na.rm=T)
|
|
vachestot$txmales[i] <- round(nrow(subset(veaux, veaux$sexbov == '1'))
|
|
/ nrow(veaux)* 100, 1)
|
|
vachestot$txvf[i] <- round(nrow(subset(veaux, veaux$conais %in% c('1','2') ))
|
|
/ nrow(veaux)* 100, 1)
|
|
vachestot$ptgP[i] <- round(0.75 * mean(veaux$devmus, na.rm=TRUE)
|
|
+ 0.25 * mean(veaux$devsqe, na.rm=TRUE), 1)
|
|
vachestot$pn_m[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '1')$ponais, na.rm=T), 1)
|
|
vachestot$p120_m[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '1')$pat04m, na.rm=T), 1)
|
|
vachestot$p210_m[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '1')$pat07m, na.rm=T), 1)
|
|
vachestot$pn_f[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '2')$ponais, na.rm=T), 1)
|
|
vachestot$p120_f[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '2')$pat04m, na.rm=T), 1)
|
|
vachestot$p210_f[i] <- round(mean(subset(veaux,
|
|
veaux$sexbov == '2')$pat07m, na.rm=T), 1)
|
|
vachestot$pn_corr[i] <- round(mean(veaux$pn_corr, na.rm=T), 1)
|
|
vachestot$p120_corr[i] <- round(mean(veaux$p120_corr, na.rm=T), 1)
|
|
vachestot$p210_corr[i] <- round(mean(veaux$p210_corr, na.rm=T), 1)
|
|
|
|
### convertion des NaN en NA
|
|
L <- c('ptgP','pn_m','pn_f','pn_corr','p120_m','p120_f','p120_corr',
|
|
'p210_m','p210_f','p210_corr')
|
|
for (j in L){
|
|
if (is.nan(vachestot[i,j]) == TRUE){
|
|
vachestot[i,j] <- NA
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# calcul des stats par fondatrice ______________________________________________
|
|
|
|
stats_lignees <- PRODTOT %>% group_by(fondatrice) %>%
|
|
summarise(nb_desc_in_chep = n()) %>% filter(nb_desc_in_chep >=5)
|
|
|
|
stats_lignees <- stats_lignees %>%
|
|
add_column(utilgen = NA, prol = NA, mort = NA, txrepros = NA, nbpp = NA,
|
|
txvf = NA, pnm = NA, pnf = NA, p120m = NA, p120f = NA, p210m = NA,
|
|
p210f = NA, dmsev = NA, dssev = NA,
|
|
nbfem_avecprod = NA, pctfem_avecprod = NA,
|
|
isu_femtot = NA, age_sort_femtot = NA,
|
|
agevel1_femtot = NA, ivv1_femtot = NA, ivv2p_femtot = NA,
|
|
vieprod_femtot = NA, dmad_femtot = NA, dsad_femtot = NA,
|
|
afad_femtot = NA, nbprod_femtot = NA, txrepros_femtot = NA,
|
|
nbpp_femtot = NA, prol_femtot = NA, mort_femtot = NA,
|
|
txvf_femtot = NA,
|
|
nbfemact_avecprod = NA, pctfemact_avecprod = NA,
|
|
isu_femact = NA, age_sort_femact = NA,
|
|
agevel1_femact = NA, ivv1_femact = NA, ivv2p_femact = NA,
|
|
vieprod_femact = NA, dmad_femact = NA, dsad_femact = NA,
|
|
afad_femact = NA, nbprod_femact = NA, txrepros_femact = NA,
|
|
nbpp_femact = NA, prol_femact = NA, mort_femact = NA,
|
|
txvf_femact = NA, nbfem_renouv = NA)
|
|
|
|
for (i in 1:nrow(stats_lignees)) {
|
|
# stats sur la prod directe __________________________________________________
|
|
li_prod <- subset(PRODTOT, PRODTOT$fondatrice == stats_lignees$fondatrice[i])
|
|
|
|
stats_lignees$utilgen[i] <- round(nrow(subset(li_prod,
|
|
li_prod$ravelamere == 1))
|
|
/ nrow(li_prod) * 100, 1)
|
|
stats_lignees$prol[i] <- round(nrow(li_prod)
|
|
/ nrow(li_prod %>% distinct(danais, mere))
|
|
* 100, 1)
|
|
stats_lignees$mort[i] <- round(nrow(subset(li_prod, li_prod$mortsev == 'O'))
|
|
/ nrow(li_prod) * 100, 1)
|
|
stats_lignees$txrepros[i] <- round(nrow(subset(li_prod, li_prod$repro == 'O'))
|
|
/ nrow(subset(li_prod,
|
|
is.na(li_prod$mortsev))) * 100, 1)
|
|
stats_lignees$nbpp[i] <- sum(li_prod$nbdescendants)
|
|
stats_lignees$txvf[i] <- round(nrow(subset(li_prod, li_prod$conais %in% c('1','2')))
|
|
/ nrow(li_prod) * 100, 1)
|
|
stats_lignees$pnm[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '1')$ponais, na.rm=T),1)
|
|
stats_lignees$pnf[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '2')$ponais, na.rm=T),1)
|
|
stats_lignees$p120m[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '1')$pat04m, na.rm=T),1)
|
|
stats_lignees$p120f[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '2')$pat04m, na.rm=T),1)
|
|
stats_lignees$p210m[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '1')$pat07m, na.rm=T),1)
|
|
stats_lignees$p210f[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '2')$pat07m, na.rm=T),1)
|
|
stats_lignees$dmsev[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '1')$devmus, na.rm=T),1)
|
|
stats_lignees$dssev[i] <- round(mean(subset(li_prod,
|
|
li_prod$sexbov == '2')$devsqe, na.rm=T),1)
|
|
|
|
# stats sur la prod par les fem ___________________________________________
|
|
li_fem <- subset(vachestot, vachestot$fondatrice == stats_lignees$fondatrice[i])
|
|
|
|
# modif du 30/04/2024
|
|
if (nrow(li_fem) > 0) {
|
|
stats_lignees$nbfem_avecprod[i] <- nrow(li_fem)
|
|
stats_lignees$pctfem_avecprod[i] <- round(nrow(li_fem)
|
|
/ nrow(subset(li_prod,
|
|
li_prod$sexbov == '2'))
|
|
* 100, 1)
|
|
}
|
|
|
|
if (nrow(li_fem) >= 3) {
|
|
stats_lignees$isu_femtot[i] <- round(mean(li_fem$indisu, na.rm=T),1)
|
|
stats_lignees$age_sort_femtot[i] <- round(mean(li_fem$age_years, na.rm=T),1)
|
|
stats_lignees$agevel1_femtot[i] <- round(mean(li_fem$agevel1, na.rm=T),1)
|
|
stats_lignees$vieprod_femtot[i] <- round(mean(li_fem$tempsprod, na.rm=T),1)
|
|
stats_lignees$ivv1_femtot[i] <- round(mean(li_fem$ivv1, na.rm=T),1)
|
|
stats_lignees$ivv2p_femtot[i] <- round(mean(as.numeric(li_fem$ivv2p), na.rm=T),1)
|
|
|
|
stats_lignees$dmad_femtot[i] <- round(mean(li_fem$dmC, na.rm=T),1)
|
|
stats_lignees$dsad_femtot[i] <- round(mean(li_fem$ds, na.rm=T),1)
|
|
stats_lignees$afad_femtot[i] <- round(mean(li_fem$af, na.rm=T),1)
|
|
|
|
stats_lignees$prol_femtot[i] <- round(mean(li_fem$prol, na.rm=T),1)
|
|
stats_lignees$mort_femtot[i] <- round(mean(li_fem$mort, na.rm=T),1)
|
|
stats_lignees$txvf_femtot[i] <- round(mean(li_fem$txvf, na.rm=T),1)
|
|
|
|
stats_lignees$nbprod_femtot[i] <- round(sum(li_fem$nbdescendants),1)
|
|
stats_lignees$txrepros_femtot[i] <- round(mean(li_fem$txrepros, na.rm=T),1)
|
|
stats_lignees$nbpp_femtot[i] <- round(sum(li_fem$nbpp),1)
|
|
}
|
|
|
|
# stats sur la prod par les fem actives ___________________________________
|
|
li_fem_act <- subset(vachestot, vachestot$fondatrice == stats_lignees$fondatrice[i]
|
|
& is.na(vachestot$dasort))
|
|
|
|
# modif du 30/04/2024
|
|
if (nrow(li_fem_act) > 0) {
|
|
stats_lignees$nbfemact_avecprod[i] <- nrow(li_fem_act)
|
|
stats_lignees$pctfemact_avecprod[i] <- round(nrow(li_fem_act)
|
|
/ nrow(subset(li_prod,
|
|
li_prod$sexbov == '2'))
|
|
* 100, 1)
|
|
}
|
|
|
|
if (nrow(li_fem_act) >= 3) {
|
|
stats_lignees$isu_femact[i] <- round(mean(li_fem_act$indisu, na.rm=T),1)
|
|
stats_lignees$age_sort_femact[i] <- round(mean(li_fem_act$age_years, na.rm=T),1)
|
|
stats_lignees$agevel1_femact[i] <- round(mean(li_fem_act$agevel1, na.rm=T),1)
|
|
stats_lignees$vieprod_femact[i] <- round(mean(li_fem_act$tempsprod, na.rm=T),1)
|
|
stats_lignees$ivv1_femact[i] <- round(mean(li_fem_act$ivv1, na.rm=T),1)
|
|
stats_lignees$ivv2p_femact[i] <- round(mean(as.numeric(li_fem_act$ivv2p), na.rm=T),1)
|
|
|
|
stats_lignees$dmad_femact[i] <- round(mean(li_fem_act$dmC, na.rm=T),1)
|
|
stats_lignees$dsad_femact[i] <- round(mean(li_fem_act$ds, na.rm=T),1)
|
|
stats_lignees$afad_femact[i] <- round(mean(li_fem_act$af, na.rm=T),1)
|
|
|
|
stats_lignees$prol_femact[i] <- round(mean(li_fem_act$prol, na.rm=T),1)
|
|
stats_lignees$mort_femact[i] <- round(mean(li_fem_act$mort, na.rm=T),1)
|
|
stats_lignees$txvf_femact[i] <- round(mean(li_fem_act$txvf, na.rm=T),1)
|
|
|
|
stats_lignees$nbprod_femact[i] <- round(sum(li_fem_act$nbdescendants),1)
|
|
stats_lignees$txrepros_femact[i] <- round(mean(li_fem_act$txrepros, na.rm=T),1)
|
|
stats_lignees$nbpp_femact[i] <- round(sum(li_fem_act$nbpp),1)
|
|
}
|
|
# filles a venir
|
|
nbfr <- nrow(subset(inv_desc,
|
|
inv_desc$fondatrice == stats_lignees$fondatrice[i]
|
|
& inv_desc$nbdescendants == 0
|
|
& inv_desc$sexbov == '2'
|
|
& inv_desc$actif == '1'))
|
|
if (nbfr > 0) {
|
|
stats_lignees$nbfem_renouv[i] <- nbfr
|
|
}
|
|
}
|
|
|
|
fondatrices$anim <- trim_str(fondatrices$anim)
|
|
stats_lignees$fondatrice <- trim_str(stats_lignees$fondatrice)
|
|
stats_lignees <- merge(fondatrices[,c('anim', 'nobovi', 'danais', 'nomnais')],
|
|
stats_lignees, by.x='anim', by.y='fondatrice', all.x=F, all.y=T)
|
|
|
|
write.table(stats_lignees,
|
|
file = paste(rep, '/', CHEP, '_ResLigneesF_eCow5.csv', sep = ""),
|
|
quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE,
|
|
sep = ";", qmethod = c("escape"), na = "")
|
|
|
|
################################################################################
|
|
### trac? des lign?es sur PDF __________________________________________________
|
|
################################################################################
|
|
|
|
# modif 27/03/2023 :
|
|
# déduction campagne en cours pour garder les femelles de renouvellement
|
|
# sans les laitonnes de la campagne en cours
|
|
camp_actuelle = ifelse(month(Sys.Date()) %in% c('08','09','10','11','12'),
|
|
year(Sys.Date()) + 1,
|
|
year(Sys.Date()))
|
|
|
|
fem_tot <- inv_desc %>% filter(sexbov == '2' & campn < camp_actuelle & (nbdescendants > 0 | actif == '1'))
|
|
|
|
# modif 27/03/2023 :
|
|
# modif de la valeur "actif" pour mettre en rouge les vaches actives ailleurs
|
|
fem_tot$actif <- ifelse(fem_tot$actif == '1' & trim_str(fem_tot$chepdet) == CHEP, '1', '0')
|
|
|
|
fem_tot$anim <- trim_str(fem_tot$anim)
|
|
fem_tot$mere <- trim_str(fem_tot$mere)
|
|
fem_tot$pere <- trim_str(fem_tot$pere)
|
|
for (i in 1:nrow(fem_tot)) {
|
|
if (fem_tot$indite[i] == 'O') {
|
|
fem_tot$nobovi[i] <- paste(fem_tot$nobovi[i], ' (TE)', sep='')
|
|
}
|
|
if (fem_tot$nbdescendants[i] == 0) {
|
|
fem_tot$nobovi[i] <- fem_tot$nobovi[i] %>% tolower()
|
|
}
|
|
if (fem_tot$corabo[i] == '38'){
|
|
fem_tot$corabo[i] <- 'CHAROLAISE'
|
|
} else {
|
|
fem_tot$corabo[i] <- 'CROISEE'
|
|
}
|
|
if (fem_tot$sexbov[i] == '2') {
|
|
fem_tot$sexbov[i] <- 'female'
|
|
} else if (fem_tot$sexbov[i] == '1'){
|
|
fem_tot$sexbov[i] <- 'male'}
|
|
if (is.na(fem_tot$nobovi[i])){
|
|
fem_tot$nobovi[i] <- paste(str_sub(fem_tot$anim[i], -4),
|
|
subset(LETTRES, LETTRES$ANNEE == fem_tot$campn[i])[1,'LETTRE'], sep='_')
|
|
}
|
|
}
|
|
|
|
cla_rg <- tabfinal[,c('NUM_VACHE', 'rang CARRIERE')]
|
|
nbvcla <- nrow(subset(cla_rg, !is.na(cla_rg$`rang CARRIERE`)))
|
|
for(i in 1:nrow(cla_rg)) {
|
|
if (!is.na(cla_rg$`rang CARRIERE`[i])){
|
|
cla_rg$`rang CARRIERE`[i] <- paste('eCow : ', cla_rg$`rang CARRIERE`[i], ' / ', nbvcla, sep='')
|
|
} else {
|
|
cla_rg$`rang CARRIERE`[i] <- 'eCow : NC'
|
|
}
|
|
}
|
|
|
|
sub_ped <- fem_tot[,c('anim', 'pere', 'mere', 'sexbov', 'corabo', 'campn', 'actif', 'nobovi')]
|
|
sub_ped <- merge(sub_ped, cla_rg, by.x='anim', by.y='NUM_VACHE', all.x=T, all.y=T)
|
|
colnames(sub_ped)=c('Indiv','Sire','Dam','Sex','Breed','Born','Affected','Nom','ecowcarr')
|
|
|
|
Pedig <- prePed(sub_ped)
|
|
for(i in 1:nrow(Pedig)) {
|
|
if (is.na(Pedig$ecowcarr[i])){
|
|
Pedig$ecowcarr[i] <- ''
|
|
}
|
|
if (!is.na(Pedig$Sex[i]) & Pedig$Sex[i] == 'male'){
|
|
toro <- subset(inv_desc, trim_str(inv_desc$pere) == Pedig$Indiv[i])
|
|
Pedig$Nom[i] <- toro$nompere[1]
|
|
}
|
|
if (!is.na(Pedig$Sex[i]) & Pedig$Sex[i] == 'female' & is.na(Pedig$Nom[i]) ){
|
|
mom <- subset(inv_desc, trim_str(inv_desc$mere) == Pedig$Indiv[i])
|
|
Pedig$Nom[i] <- mom$nommere[1]
|
|
}
|
|
}
|
|
|
|
img=readPNG("C:/Users/LJeannot/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/IMPORTS_R/HBC-Logo.png")
|
|
|
|
dir.create(path=paste(rep, "/", CHEP, '_pdf_ligneesF', sep=''))
|
|
sousrep=paste(rep, "/" ,CHEP, '_pdf_ligneesF', sep='')
|
|
|
|
fondatrices$anim <- trim_str(fondatrices$anim)
|
|
fondatrices <- subset(fondatrices, (fondatrices$nbdescendants > 0 | is.na(fondatrices$nbdescendants))
|
|
& fondatrices$anim %in% trim_str(fem_tot$fondatrice))
|
|
|
|
if (nrow(fondatrices) > 0) {
|
|
for (i in 1:nrow(fondatrices)) {
|
|
print(fondatrices$anim[i])
|
|
sPed <- subPed(Pedig, keep=fondatrices$anim[i], prevGen=0, succGen=10)
|
|
taille <- nrow(sPed)
|
|
print(taille)
|
|
nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv))
|
|
nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2)))
|
|
tx <- round(nb / nbt * 100, 1)
|
|
tx2 <- round(nbt / nrow(vaches) * 100, 1)
|
|
|
|
if (taille <= 20) {ecr <- 0.5}
|
|
else if (taille > 20 & taille <= 50) {ecr <- 0.4}
|
|
else if (taille > 50 & taille <= 100){ecr <- 0.3}
|
|
else if (taille > 100 & taille <= 150){ecr <- 0.2}
|
|
else {ecr <- 0.1}
|
|
|
|
for (j in 1:nrow(sPed)) {
|
|
#sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4)
|
|
#sPed$Sire[j]=str_sub(sPed$Sire[j],-4)
|
|
#sPed$Dam[j]=str_sub(sPed$Dam[j],-4)
|
|
sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n')
|
|
}
|
|
tryCatch(
|
|
expr = {
|
|
if (nrow(sPed) > 1 & nbt > 0) {
|
|
nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], '.pdf', sep='')
|
|
pdf(file = paste(sousrep, "/", nom, sep=""),
|
|
width = 29.5, height = 21, pointsize = 50)
|
|
pedplot(sPed,
|
|
label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures
|
|
symbolsize=0.6,
|
|
pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? a droite
|
|
cex=ecr, # taille d'?criture
|
|
branch=0.8, # lignes verticales adoucies
|
|
srt=-90, # angle d'orientation du texte
|
|
mar=c(2, 2, 2, 5), # marges
|
|
lwd=5, # epaisseur des traits --> ne marche pas
|
|
col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == '1', "orange", "red")))
|
|
corners <- par("usr")
|
|
par(xpd=TRUE)
|
|
text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0,
|
|
paste(paste(CHEP, vaches$nomdete[1], sep=' - '),
|
|
paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'),
|
|
srt=270, cex=0.8, col='dark red', font=2)
|
|
text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1,
|
|
c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'),
|
|
srt=270, cex=0.3)
|
|
text(x=corners[2] + corners[2] / 15, y=mean(corners[3:4]), adj=0.5,
|
|
paste('Les vaches actives de cette lignee representent ',tx2,"% des vaches en production du cheptel.",sep=''),
|
|
srt=270, cex=0.5, col='dark green')
|
|
text(x=corners[2] + corners[2] / 20, y=mean(corners[3:4]), adj=0.5,
|
|
paste('Synthese eCow : ',tx,"% des vaches actives de cette lignee appartiennent a la moitie superieure classee du cheptel.",sep=''),
|
|
srt=270, cex=0.5, col='dark green', font=2)
|
|
grid.raster(img, x=0.05, y=0.1, width=0.05)
|
|
dev.off()
|
|
}
|
|
|
|
if (taille >= 80){
|
|
z <- subset(fem_tot, fem_tot$mere == fondatrices$anim[i])
|
|
if (nrow(z) > 1){
|
|
for (k in 1:nrow(z)){
|
|
sPed <- subPed(Pedig, keep=z$anim[k], prevGen=0, succGen=10)
|
|
taille <- nrow(sPed)
|
|
|
|
nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv))
|
|
nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2)))
|
|
tx <- round(nb / nbt * 100,1)
|
|
tx2 <- round(nbt / nrow(vaches) * 100, 1)
|
|
|
|
if (taille <= 20) {ecr <- 0.5}
|
|
else if (taille > 20 & taille <= 50) {ecr <- 0.4}
|
|
else if (taille > 50 & taille <= 100){ecr <- 0.3}
|
|
else if (taille > 100 & taille <= 150){ecr <- 0.2}
|
|
else {ecr <- 0.1}
|
|
|
|
for (j in 1:nrow(sPed)){
|
|
#sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4)
|
|
#sPed$Sire[j]=str_sub(sPed$Sire[j],-4)
|
|
#sPed$Dam[j]=str_sub(sPed$Dam[j],-4)
|
|
sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n')
|
|
}
|
|
|
|
if (nrow(sPed) > 1 & nbt > 0){
|
|
nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i], '_sl_', z$anim[k], '.pdf', sep='')
|
|
pdf(file = paste(sousrep, "/", nom, sep=""),
|
|
width = 29.5, height = 21, pointsize = 50)
|
|
pedplot(sPed,
|
|
label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures
|
|
symbolsize=0.6,
|
|
pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? a droite
|
|
cex=ecr, # taille d'?criture
|
|
branch=0.8, # lignes verticales adoucies
|
|
srt=-90, # angle d'orientation du texte
|
|
mar=c(2,2,2,5), # marges
|
|
lwd=5, # epaisseur des traits --> ne marche pas
|
|
col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red")))
|
|
corners <- par("usr")
|
|
par(xpd=TRUE)
|
|
text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0,
|
|
paste(paste(CHEP, vaches$nomdete[1], sep=' - '),
|
|
paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'),
|
|
srt=270, cex=0.8, col='dark red', font=2)
|
|
text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0,
|
|
paste('Sous-lignee : fille', z$nobovi[k], str_sub(z$anim[k], -4), sep=' '),
|
|
srt=270, cex=0.6, col='dark red', font=1)
|
|
text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1,
|
|
c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'),
|
|
srt=270, cex=0.3)
|
|
text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5,
|
|
paste('Les vaches actives de cette sous-lignee representent ',
|
|
tx2, "% des vaches en production du cheptel.", sep=''),
|
|
srt=270, cex=0.5, col='dark green')
|
|
text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5,
|
|
paste('Synthese eCow : ', tx,
|
|
"% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''),
|
|
srt=270, cex=0.5, col='dark green', font=2)
|
|
grid.raster(img, x=0.05, y=0.1, width=0.05)
|
|
dev.off()
|
|
|
|
|
|
if (taille >= 80){
|
|
a <- subset(fem_tot, fem_tot$mere == z$anim[k])
|
|
if (nrow(a) > 1){
|
|
for (n in 1:nrow(a)){
|
|
sPed <- subPed(Pedig, keep=a$anim[n], prevGen=0, succGen=10)
|
|
taille <- nrow(sPed)
|
|
|
|
nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv))
|
|
nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2)))
|
|
tx <- round(nb / nbt * 100, 1)
|
|
tx2 <- round(nbt / nrow(vaches) * 100, 1)
|
|
|
|
if (taille <= 20) {ecr <- 0.5}
|
|
else if (taille > 20 & taille <= 50) {ecr <- 0.4}
|
|
else if (taille > 50 & taille <= 100){ecr <- 0.3}
|
|
else if (taille > 100 & taille <= 150){ecr <- 0.2}
|
|
else {ecr <- 0.1}
|
|
|
|
for (j in 1:nrow(sPed)){
|
|
#sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4)
|
|
#sPed$Sire[j]=str_sub(sPed$Sire[j],-4)
|
|
#sPed$Dam[j]=str_sub(sPed$Dam[j],-4)
|
|
sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j],-4), sPed$Nom[j], sep='\n')
|
|
}
|
|
|
|
if (nrow(sPed) > 1 & nbt > 0){
|
|
nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i],
|
|
'_ssl_', z$anim[k], '_', a$anim[n], '.pdf',sep='')
|
|
pdf(file = paste(sousrep,"/",nom,sep=""),
|
|
width = 29.5, height = 21, pointsize = 50)
|
|
pedplot(sPed,
|
|
label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures
|
|
symbolsize=0.6,
|
|
pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? ? droite
|
|
cex=ecr, # taille d'?criture
|
|
branch=0.8, # lignes verticales adoucies
|
|
srt=-90, # angle d'orientation du texte
|
|
mar=c(2,2,2,5), # marges
|
|
lwd=5, # epaisseur des traits --> ne marche pas
|
|
col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red")))
|
|
corners <- par("usr")
|
|
par(xpd=TRUE)
|
|
text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0,
|
|
paste(paste(CHEP, vaches$nomdete[1], sep=' - '),
|
|
paste('Lignee :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'),
|
|
srt=270, cex=0.8, col='dark red', font=2)
|
|
text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0,
|
|
paste('Sous-lignee : petite-fille',a$nobovi[n], str_sub(a$anim[n],-4),sep=' '),
|
|
srt=270, cex=0.6, col='dark red', font=1)
|
|
text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1,
|
|
c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'),
|
|
srt=270, cex=0.3)
|
|
text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5,
|
|
paste('Les vaches actives de cette sous-lignee representent ',
|
|
tx2, "% des vaches en production du cheptel.", sep=''),
|
|
srt=270, cex=0.5, col='dark green')
|
|
text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5,
|
|
paste('Synthese eCow : ', tx,
|
|
"% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''),
|
|
srt=270, cex=0.5, col='dark green', font=2)
|
|
grid.raster(img, x=0.05, y=0.1, width=0.05)
|
|
dev.off()
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
}
|
|
}
|
|
} else {
|
|
w <- subset(fem_tot, fem_tot$mere == z$anim[1])
|
|
if (nrow(w) > 1){
|
|
for (m in 1:nrow(w)){
|
|
sPed <- subPed(Pedig, keep=w$anim[m], prevGen=0, succGen=10)
|
|
taille <- nrow(sPed)
|
|
|
|
nbt <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv))
|
|
nb <- nrow(subset(vaches, vaches$anim %in% sPed$Indiv & vaches$rg_carr <= (nbvcla / 2)))
|
|
tx <- round(nb / nbt * 100, 1)
|
|
tx2 <- round(nbt / nrow(vaches) * 100, 1)
|
|
|
|
if (taille <= 20) {ecr <- 0.5}
|
|
else if (taille > 20 & taille <= 50) {ecr <- 0.4}
|
|
else if (taille > 50 & taille <= 100){ecr <- 0.3}
|
|
else if (taille > 100 & taille <= 150){ecr <- 0.2}
|
|
else {ecr <- 0.1}
|
|
|
|
for (j in 1:nrow(sPed)){
|
|
#sPed$Indiv[j]=str_sub(sPed$Indiv[j],-4)
|
|
#sPed$Sire[j]=str_sub(sPed$Sire[j],-4)
|
|
#sPed$Dam[j]=str_sub(sPed$Dam[j],-4)
|
|
sPed$Nom[j] <- paste(str_sub(sPed$Indiv[j], -4), sPed$Nom[j], sep='\n')
|
|
}
|
|
|
|
if (nrow(sPed) > 1 & nbt > 0){
|
|
nom <- paste(fondatrices$anim[i], '_', fondatrices$nobovi[i],
|
|
'_ssl_', w$anim[m], '.pdf', sep='')
|
|
pdf(file = paste(sousrep, "/", nom, sep=""),
|
|
width = 29.5, height = 21, pointsize = 50)
|
|
pedplot(sPed,
|
|
label=c('Nom','ecowcarr'), # nom des champs a afficher sous les figures
|
|
symbolsize=0.6,
|
|
pos=1, # 1 --> centr? mais un peu superpos?, 4 --> pas superpos? mais align? ? droite
|
|
cex=ecr, # taille d'?criture
|
|
branch=0.8, # lignes verticales adoucies
|
|
srt=-90, # angle d'orientation du texte
|
|
mar=c(2,2,2,5), # marges
|
|
lwd=5, # epaisseur des traits --> ne marche pas
|
|
col=ifelse(sPed$Sex == 'male', "blue", ifelse(sPed$Affected == 1, "orange", "red")))
|
|
corners <- par("usr")
|
|
par(xpd=TRUE)
|
|
text(x=corners[2] + corners[2] / 8, y=corners[4], adj=0,
|
|
paste(paste(CHEP, vaches$nomdete[1], sep=' - '),
|
|
paste('Lign?e :', fondatrices$nobovi[i], fondatrices$anim[i], sep=' '), sep='\n'),
|
|
srt=270, cex=0.8, col='dark red', font=2)
|
|
text(x=corners[2] + corners[2] / 12, y=corners[4], adj=0,
|
|
paste('Sous-lignee : petite-fille', w$nobovi[m], str_sub(w$anim[m], -4), sep=' '),
|
|
srt=270, cex=0.6, col='dark red', font=1)
|
|
text(x=corners[2] + corners[2] / 8, y=corners[3], adj=1,
|
|
c('LEGENDE :\nBLEU : males\nJAUNE : vaches actives\nROUGE : vaches non actives'),
|
|
srt=270, cex=0.3)
|
|
text(x=corners[2] + corners[2] / 16, y=mean(corners[3:4]), adj=0.5,
|
|
paste('Les vaches actives de cette sous-lignee representent ',
|
|
tx2, "% des vaches en production du cheptel.", sep=''),
|
|
srt=270, cex=0.5, col='dark green')
|
|
text(x=corners[2] + corners[2] / 22, y=mean(corners[3:4]), adj=0.5,
|
|
paste('Synthese eCow : ', tx,
|
|
"% des vaches actives de cette sous-lignee appartiennent a la moitie superieure classee du cheptel.", sep=''),
|
|
srt=270, cex=0.5, col='dark green', font=2)
|
|
grid.raster(img, x=0.05, y=0.1, width=0.05)
|
|
dev.off()
|
|
}
|
|
}
|
|
}
|
|
|
|
}
|
|
}
|
|
},
|
|
error = function(erreur) {
|
|
print("Erreur")
|
|
}
|
|
)
|
|
}
|
|
}
|
|
|
|
contenu <- as.data.frame(list.files(paste0(rep, "/", CHEP, '_pdf_ligneesF')))
|
|
|
|
if (nrow(contenu) > 0) {
|
|
staple_pdf(input_directory = sousrep,
|
|
input_files = NULL,
|
|
output_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''),
|
|
overwrite = TRUE)
|
|
|
|
rotate_pdf(page_rotation = 270,
|
|
input_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''),
|
|
output_filepath = paste(rep, '/', CHEP, "_ArbreLigneesF_eCow5.pdf", sep=''),
|
|
overwrite = TRUE)
|
|
}
|
|
|
|
unlink(paste(rep, '/', CHEP, '_pdf_ligneesF', sep=''), recursive=TRUE)
|
|
|
|
new=Sys.time()-old
|
|
print(paste('Trac? des lign?es femelles :',new,sep=''))
|
|
|
|
|
|
### g?n?ration du rapport HTML ################################################
|
|
|
|
# a revoir pour les petits cheptels
|
|
render_report(CHEP, TECH, date_imp)
|
|
|
|
render_synthese(CHEP, TECH, date_imp)
|
|
|
|
# temps total
|
|
NEW <- Sys.time() - OLD
|
|
print(paste("Temps total d'execution :", NEW, sep=''))
|
|
} else {
|
|
print("inventaire vide")
|
|
}
|
|
}
|
|
|
|
|
|
################################################################################
|
|
### saisie des cheptels ? sortir ###############################################
|
|
################################################################################
|
|
|
|
# CHEP <- 'FR63119077' # avec le FR
|
|
# TECH <- 'GADES'
|
|
#
|
|
# render_all_fic(CHEP, TECH)
|
|
#
|
|
#
|
|
# render_report(CHEP, TECH, date_imp)
|
|
# render_synthese(CHEP, TECH, date_imp)
|
|
|
|
|
|
################################################################################
|
|
### requete sur les cheptels ? rechercher pr?vus en tourn?e ####################
|
|
################################################################################
|
|
|
|
# dept_tech <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/IMPORTS_R/dept_tech.csv",
|
|
# ";", escape_double = FALSE, locale = locale(encoding = "ISO-8859-1"),
|
|
# trim_ws = TRUE)
|
|
#
|
|
#
|
|
# itic <- "https://dga.jouy.inra.fr/HbcWebServices/webresources/hbcitic/finddatefieldbynamedquery/Hbcitic.findByPrevejo/"
|
|
# date_req <- Sys.Date()
|
|
# li_dates <- seq(as.Date(Sys.Date()), as.Date(Sys.Date()+21), by="days")
|
|
#
|
|
# itineraires <- fromJSON(paste(itic, "2021-06-11", sep=''))[0,]
|
|
#
|
|
# for (i in 1:length(li_dates)){
|
|
# it <- fromJSON(paste(itic, li_dates[i], sep=''))
|
|
# itineraires <- bind_rows(itineraires, it)
|
|
# }
|
|
#
|
|
# li_erreurs <- c()
|
|
# for (i in 1:nrow(itineraires)) {
|
|
# CHEP <- paste('FR', substr(itineraires$nuchep[i],1,8) , sep='')
|
|
# if (itineraires$codoper[i] %in% c('ERLAM', 'STBIL', 'FRROB', 'JEAUC', 'GADES', 'ETJON', 'LOCDG', 'ANHUV')) {
|
|
# TECH <- itineraires$codoper[i]
|
|
# } else {
|
|
# li_tech <- subset(dept_tech, dept_tech$num == substr(itineraires$nuchep[i], 1, 2))
|
|
# TECH <- li_tech$tech1[1]
|
|
# }
|
|
# cat(CHEP, TECH, '\n')
|
|
# if (dir.exists(path=paste(rep_exp, TECH, '/', CHEP, sep='')) == FALSE
|
|
# | file.exists(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''),
|
|
# '/', CHEP, '_synthese_eCow5.html', sep = "")) == FALSE) {
|
|
# # tryCatch(
|
|
# # expr = {
|
|
# render_all_fic(CHEP, TECH)
|
|
# # },
|
|
# # error = function(e) {
|
|
# # cat('ERREUR CALCUL', CHEP, '\n')
|
|
# # append(li_erreurs, CHEP)
|
|
# # })
|
|
# #render_all_fic(CHEP, TECH)
|
|
# }
|
|
# }
|
|
# print(li_erreurs)
|
|
|
|
|
|
################################################################################
|
|
### requete sur les cheptels d'une liste d?finie ###############################
|
|
################################################################################
|
|
options(timeout = 1200)
|
|
|
|
li_chep <- c(
|
|
"FR63118167"
|
|
)
|
|
|
|
TECH <- 'VN2025'
|
|
|
|
li_erreurs <- c()
|
|
for (i in 1:length(li_chep)) {
|
|
CHEP <- li_chep[i]
|
|
cat(CHEP, TECH, '\n')
|
|
if (dir.exists(path=paste(rep_exp, TECH, '/', CHEP, sep='')) == FALSE
|
|
| file.exists(paste(paste(rep_exp, TECH, '/' ,CHEP, sep=''),
|
|
'/', CHEP, '_synthese_eCow5.html', sep = "")) == FALSE) {
|
|
tryCatch(
|
|
expr = {
|
|
render_all_fic(CHEP, TECH)
|
|
},
|
|
error = function(e) {
|
|
cat('ERREUR CALCUL', CHEP)
|
|
li_erreurs[[(length(li_erreurs) + 1)]] <- CHEP
|
|
})
|
|
render_all_fic(CHEP, TECH)
|
|
}
|
|
}
|
|
|
|
|
|
adh_avril2024 <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/Bureau/adhhbc_20240429.csv",
|
|
delim = ";", escape_double = FALSE, trim_ws = TRUE)
|
|
adh_avril2024$export <- NA
|
|
|
|
for (i in 1:nrow(adh_avril2024)){
|
|
|
|
CHEP <- adh_avril2024$CHEP[i]
|
|
TECH <- adh_avril2024$TECH[i]
|
|
cat(CHEP, TECH, '\n')
|
|
|
|
tryCatch(
|
|
expr = {
|
|
render_all_fic(CHEP, TECH)
|
|
},
|
|
error = function(e){
|
|
cat('ERREUR CALCUL', CHEP, "\n")
|
|
adh_avril2024$export[i] <- "ERREUR"
|
|
}
|
|
)
|
|
|
|
}
|
|
|
|
|
|
################################################################################
|
|
### requete ? partir d'un fichier de cheptels et techs ########################
|
|
################################################################################
|
|
|
|
#
|
|
# li_spec <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/Bureau/pre_engagement_VN2023_14juin.csv",
|
|
# ";", escape_double = FALSE, trim_ws = TRUE)
|
|
#
|
|
# li_erreurs <- c()
|
|
#
|
|
# for (i in 1:nrow(li_spec)) {
|
|
# CHEP <- li_spec$cheptel[i]
|
|
# TECH <- li_spec$tech[i]
|
|
# cat(CHEP, TECH, '\n')
|
|
# tryCatch(
|
|
# expr = {
|
|
# render_all_fic(CHEP, TECH)
|
|
# },
|
|
# error = function(e) {
|
|
# cat('ERREUR CALCUL', CHEP)
|
|
# li_erreurs[[(length(li_erreurs) + 1)]] <- CHEP
|
|
# })
|
|
# #render_all_fic(CHEP, TECH)
|
|
# }
|
|
|
|
|
|
################################################################################
|
|
### SCRIPT d'ARCHIVAGE des VIEUX FICHIERS/DOSSIERS #############################
|
|
################################################################################
|
|
|
|
|
|
# # contenu du dossier EXPORT
|
|
# li_doc_rep <- as.data.frame(list.files(path = rep_exp))
|
|
#
|
|
# #contenu des dossiers TECH
|
|
# li_doc_sousrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[2,1], sep = '')))
|
|
# #contenu des dossiers CHEPTEL
|
|
# li_doc_ssrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[2,1], '/', li_doc_sousrep[1,1], sep = '')))
|
|
#
|
|
# auj <- Sys.time()
|
|
#
|
|
# nb_fic_supp <- 0
|
|
# nb_fic_archive <- 0
|
|
#
|
|
# for (i in 2:nrow(li_doc_rep)) {
|
|
# # contenu des dossiers TECH
|
|
# li_doc_sousrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[i,1], sep = '')))
|
|
# for (j in 1:nrow(li_doc_sousrep)) {
|
|
# # contenu des dossiers CHEPTEL
|
|
# li_doc_ssrep <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = '')))
|
|
#
|
|
# dc <- file.info(paste(rep_exp, li_doc_rep[i,1], '/',li_doc_sousrep[j,1], '/',li_doc_ssrep[1,1], sep = ''))$ctime
|
|
# #cat(dc, '\n')
|
|
#
|
|
# if (is.na(dc)) { # si dossier vide, on le supprime
|
|
# print('VIDE')
|
|
# print(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''))
|
|
# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''), recursive = TRUE)
|
|
# nb_fic_supp <- nb_fic_supp + 1
|
|
#
|
|
# } else if (time_length(interval(dc, auj), "days") > 180) { # sinon on l'archive
|
|
# print('VIEUX')
|
|
# print(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''))
|
|
# nb_fic_archive <- nb_fic_archive + 1
|
|
#
|
|
# # on supprime les fichiers html et pdf (car volumineux)
|
|
# if (file.exists(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_ArbreLigneesF_eCow5.pdf', sep = ''))) {
|
|
# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_ArbreLigneesF_eCow5.pdf', sep = ''), recursive = TRUE)
|
|
# }
|
|
# if (file.exists(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_rapport_eCow5.html', sep = ''))) {
|
|
# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_rapport_eCow5.html', sep = ''), recursive = TRUE)
|
|
# }
|
|
# if (file.exists(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_synthese_eCow5.html', sep = ''))) {
|
|
# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], '/', li_doc_sousrep[j,1], '_synthese_eCow5.html', sep = ''), recursive = TRUE)
|
|
# }
|
|
#
|
|
# # on archive les fichiers csv en dehors du fichier export ------------------------------------- date à modifier !!!!!!!!!!!!!!!
|
|
# dir.create(paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/archives_EXPORTS_R/20231205/", li_doc_sousrep[j,1], sep=''))
|
|
# li_doc_ssrep2 <- as.data.frame(list.files(path = paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = '')))
|
|
# for (k in 1:nrow(li_doc_ssrep2)) {
|
|
# filesstrings::file.move(paste(rep_exp, li_doc_rep[i,1], '/',li_doc_sousrep[j,1], '/',li_doc_ssrep2[k,1], sep = ''),
|
|
# paste("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/archives_EXPORTS_R/20231205/", li_doc_sousrep[j,1], sep=''))
|
|
# }
|
|
# unlink(paste(rep_exp, li_doc_rep[i,1], '/', li_doc_sousrep[j,1], sep = ''), recursive = TRUE)
|
|
#
|
|
# }
|
|
# }
|
|
# print(paste("NB fichiers supprimes : ", nb_fic_supp, sep=''))
|
|
# print(paste("NB fichiers archives : ", nb_fic_archive))
|
|
# }
|
|
|
|
|
|
################################################################################
|
|
### Fonction de recuperation des classements eCow pour la Vente Nationale 2022 ###
|
|
################################################################################
|
|
|
|
|
|
li_vn <- read_delim("C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/VN/VN2025_liste_meres.csv", delim = ";")
|
|
|
|
li_vn$NOM_MERE = li_vn$AGE = li_vn$nb_VA_tot = li_vn$nb_VA_cla = li_vn$rg <- NA
|
|
# clsst = data.frame(matrix(NA, ncol = 6, nrow = 1))
|
|
# colnames(clsst) = c('ANIM', 'NOBOVI', 'AGE', 'nb_VA_tot', 'nb_VA_cla', 'rg')
|
|
|
|
for(i in 1:nrow(li_vn)){
|
|
print(i)
|
|
CHEP = li_vn$CHEPDET[i]
|
|
#TECH = li_vn$TECH[i]
|
|
ANIM = li_vn$MERE[i]
|
|
## si le fichier existe
|
|
pathVN = "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/eCow5/EXPORTS_2/VN2025" #paste(rep_exp, TECH, '/', CHEP, sep='')
|
|
if (dir.exists(path = pathVN) == TRUE
|
|
& file.exists(paste(pathVN, '/', CHEP,'/', CHEP, '_classement_eCow5.csv', sep = "")) == TRUE) {
|
|
## si il est assez recent : < 3 mois
|
|
if( file.info(paste(pathVN, '/', CHEP,'/', CHEP, '_classement_eCow5.csv', sep = ""))$ctime > "2022-03-27") {
|
|
# on va chercher les infos
|
|
recup <- read_delim( paste(pathVN, '/', CHEP, '/', CHEP, '_classement_eCow5.csv', sep = ""),
|
|
delim = ";", escape_double = FALSE,
|
|
locale = locale(decimal_mark = ","),
|
|
trim_ws = TRUE)
|
|
li_vn$nb_VA_tot[i] = nrow(recup)
|
|
x = subset(recup, recup$NUM_VACHE == ANIM)
|
|
cla = subset(recup, !is.na(recup$`rang CARRIERE`))
|
|
if(nrow(x) > 0){
|
|
li_vn$NOM_MERE[i] = x$NOM_VACHE[1]
|
|
li_vn$AGE[i] = x$`AGE (annees)`[1]
|
|
li_vn$rg[i] = x$`rang CARRIERE`[1]
|
|
li_vn$nb_VA_cla[i] = nrow(cla)
|
|
} else {
|
|
li_vn$rg[i] = 'abs'
|
|
}
|
|
} else {
|
|
print("else0")
|
|
## sinon on le genere
|
|
# tryCatch(
|
|
# expr = {
|
|
# render_all_fic(CHEP, TECH)
|
|
# },
|
|
# error = function(e) {
|
|
# cat('ERREUR CALCUL', CHEP, '\n')
|
|
# })
|
|
# ## puis on va chercher le fichier
|
|
# recup <- read_delim( paste( paste(rep_exp, TECH, '/' ,CHEP, sep=''),
|
|
# '/', CHEP, '_classement_eCow5.csv', sep = ""),
|
|
# delim = ";", escape_double = FALSE,
|
|
# locale = locale(decimal_mark = ","),
|
|
# trim_ws = TRUE)
|
|
# li_vn$nb_VA_tot[i] = nrow(recup)
|
|
# x = subset(recup, recup$NUM_VACHE == ANIM)
|
|
# cla = subset(recup, !is.na(recup$`rang CARRIERE`))
|
|
# if(nrow(x) > 0){
|
|
# li_vn$NOBOVI[i] = x$NOM_VACHE[1]
|
|
# li_vn$AGE[i] = x$`AGE (annees)`[1]
|
|
# li_vn$rg[i] = x$`rang CARRIERE`[1]
|
|
# li_vn$nb_VA_cla[i] = nrow(cla)
|
|
# } else {
|
|
# li_vn$rg[i] = 'abs'
|
|
# }
|
|
}
|
|
|
|
} else {
|
|
print("else1")
|
|
## sinon on genere le fichier
|
|
# tryCatch(
|
|
# expr = {
|
|
# render_all_fic(CHEP, TECH)
|
|
# },
|
|
# error = function(e) {
|
|
# cat('ERREUR CALCUL', CHEP, '\n')
|
|
# })
|
|
# ## puis on va chercher le fichier
|
|
# recup <- read_delim( paste( paste(rep_exp, TECH, '/' ,CHEP, sep=''),
|
|
# '/', CHEP, '_classement_eCow5.csv', sep = ""),
|
|
# delim = ";", escape_double = FALSE,
|
|
# locale = locale(decimal_mark = ","),
|
|
# trim_ws = TRUE)
|
|
# li_vn$nb_VA_tot[i] = nrow(recup)
|
|
# x = subset(recup, recup$NUM_VACHE == ANIM)
|
|
# cla = subset(recup, !is.na(recup$`rang CARRIERE`))
|
|
# if(nrow(x) > 0){
|
|
# li_vn$NOBOVI[i] = x$NOM_VACHE[1]
|
|
# li_vn$AGE[i] = x$`AGE (annees)`[1]
|
|
# li_vn$rg[i] = x$`rang CARRIERE`[1]
|
|
# li_vn$nb_VA_cla[i] = nrow(cla)
|
|
# } else {
|
|
# li_vn$rg[i] = 'abs'
|
|
# }
|
|
}
|
|
}
|
|
|
|
write.table(li_vn,
|
|
file = "C:/Users/LJEANNOT/OneDrive - HERD BOOK CHAROLAIS/2_HBC/07_PROJETS/ECOW/VN/VN2025_eCow_MERES.csv",
|
|
quote = FALSE, dec = ",", row.names = FALSE, col.names = TRUE,
|
|
sep = ";", qmethod = c("escape"), na = "")
|