coopR: Fonctions R pour la Coop

#' @title  table Intervalle de croissance
#'
#' @description Cette fonction construit la table des periodes (ou Intervalle) de croissance entre deux mesures d'une placette et en calcul des accroissements. Utilise le dernier inventaire realise lors de la campagne de debut de periode et le 1e de la campagne de fin de periode (a priori, sans intervention entre les deux et fait sur une surface identique). Definit egalement l'ordre des inventaires sur toutes la series des mesures. A l'exception de l'accroissement en surface terri?re et de la densité, basé sur le cumul des ?volutions de chaque tiges, les accroissements des variables (RDI, H0, D0,...) correspondent ? la diff?rence entre l'?tat final et l'?tat initial)
#'
#' @param Peupl : table issu de la fonction peuplement_ch (format de mesure2 avec les donn?es dendrom?triques). Si on utilise la table de type mesure2 directement, la fonction identifie les p?riodes de croissance sans calcul? les ?volution de grandeur de peuplement.
#' @param Arb : table de type arbre issu de la fonction load_xls_to_R_ch(format = "R") ou de load_bdd_to_R_ch (inventaire individualise sur liste), qui si on veut des accroissements en G de la placette par somme d'accroissement individuel et les donnees de la mortalite (calculable que pour les suivis sur listes).
#' @param EI : vecteur, nom des variables qu'on veut conserver pour definir l'etat initial (par defaut si present : RDI, H0_ch, age)
#' @param evolution : vecteur, nom des variables dont on veut l'evolution par difference entre les variables peuplements de debut et fin de periode (par defaut si present : H0_ch, D0_ch)
#' @note : a priori, les deux inventaires entourant une periode ont ete fait a priori dans les meme conditions (meme suivi, meme surface, pas d'intervention entre les deux).
#' Si les variables demandes dans EI et evolution ne sont pas presente dans la table Peupl, le programme tourne quand meme.
#' @return table avec les periodes de croissances encadre par deux inventaires et, si c'est demande et possible, les accroissements et la mortalite.
#' @infos plus d infos a ajouter...
#'
#'
#' @author Quentin Girard
#' @references Protocole Coop chene... document d Ingrid et Claudine
#'
#' @seealso  peuplement_ch, load_xls_to_R_ch, load_bdd_to_R_ch
#' @examples
#' a venir
#'
#' @keywords function
#'
#' @include coopR-package.R
#' @family coopR
#' @export

accroissement_peuplement_ch <- function(Peupl = NULL, Arb = NULL, EI = c("RDI_ch", "H0_ch","age"), evolution = c("H0_ch", "D0_ch")){
# v?rification des entr?es
  if (is.null(Peupl)) {
    stop("Peupl doit ?tre renseign?")
  } else if (!is.data.frame(Peupl)) {
    stop("Peupl doit ?tre un data.frame")
  } else if (length(setdiff(c("id_unite", "no_mesure", "av_ap_id", "ordre_inv", "an_vegetation", "surf_inv", "suivi"), names(Peupl))) != 0) {
    stop("Il manque des colonnes dans Peupl (obligatoires: 'id_unite', 'no_mesure', 'av_ap_id', 'ordre_inv', 'an_vegetation', 'surf_inv', 'suivi')")
  }

# verifications des demandes
  if (length(setdiff(EI, names(Peupl))) != 0) {
    warning("Vous demandez les valeurs initiales de ", list(setdiff(EI, names(Peupl))), " mais ils ne sont pas present dans la table d'entree. Ils ne seront pas renvoyes")
    EI <- intersect(EI, names(Peupl))
  }
  if (length(setdiff(evolution, names(Peupl))) != 0) {
    warning("Vous demandez les evolution de ", list(setdiff(evolution, names(Peupl))), " mais ils ne sont pas present dans la table d'entree. Ces accroissements ne seront pas calcule")
    evolution <- intersect(evolution, names(Peupl))
  }

# jonction des inventaires qui se suivent a partir de ordre_inv
  Peupl$lien1 <- Peupl$ordre_inv
  Peupl$lien2 <- Peupl$ordre_inv + 1
  #Peupl$ordre_inv.f <- Peupl$ordre_inv + 1
  Output <- merge(Peupl,#[,c("id_unite", "no_mesure", "av_ap_id", "ordre_inv", "ordre_inv.f", "an_vegetation", "surf_inv", "suivi", EI, evolution)],
                  Peupl[-which(names(Peupl) == "lien2")],#[,c("id_unite", "no_mesure", "av_ap_id", "ordre_inv",                "an_vegetation",             "suivi",     evolution)],
                 # by.x = c("id_unite", "ordre_inv.f"), by.y = c("id_unite", "ordre_inv"), suffixes = c(".i", ".f"))
                  by.x = c("id_unite", "lien2"), by.y = c("id_unite", "lien1"), suffixes = c(".i", ".f"))
  # dans cette table, selection des periodes ou intervalles (soit deux inventaires qui se suivent et qui n'ont pas le meme no_mesure)
  Output <- subset(Output, no_mesure.i != no_mesure.f)
  flag <- nrow(Output)
  # Attention, cas o? il manque un inventaire avant ou apr?s intervention !
  Output <- subset(Output, av_ap_id.i != 1) # si l'inventaire initial est avant intervention (c'est qu'il manque un inventaire apr?s)
  Output <- subset(Output, av_ap_id.f != 2) # si l'inventaire final est apr?s intervention (c'est qu'il manque un inventaire avant)
  Output <- subset(Output, no_mesure.f == no_mesure.i +1) # si il y a une mesure interm?diaire qui n'est pas renseign?e
  if (flag != nrow(Output)) {
    warning("Il manque au moins un inventaire avant ou apr?s intervention, voire une campagne de mesure. La p?riode associ?e n'est pas pr?sente dans la sortie")
  }

  Output$duree <- Output$an_vegetation.f - Output$an_vegetation.i
  if (nrow(subset(Output, suivi.i     != suivi.f)) != 0) {
    warning("Au moins une periode est entouree de deux inventaires fait selon une methode differente (classe ou liste)")
  }
# calcul d'accroissement par difference
  for (val in evolution) {
    Output[,paste("evol.", val, sep = "")] <- (Output[,paste(val, ".f", sep = "")] - Output[,paste(val, ".i", sep = "")]) / Output$duree
  }
  #Output <- Output[,-which(names(Output) %in% c("suivi.f", "an_vegetation.f", paste(evolution, ".f", sep = "")))]
  # variable conserv?e
  Output <- Output[,c("id_unite", "duree",
                      paste(c("no_mesure", "ordre_inv", "an_vegetation", "surf_inv", "suivi", EI), ".i", sep = ""),
                      paste(c("no_mesure", "ordre_inv", "surf_inv", "suivi"), ".f", sep = ""),
                      paste("evol.", evolution, sep = ""))]
  cat("Les variables finissant par '.i' correspondent ? l'?tat initial \n")
  cat("Les variables finissant par '.f' correspondent ? l'?tat final \n")
  cat("Les variables commen?ant par 'evol.' sont les diff?rences entre la valeur en fin et en d?but de periode, ramen?e ? l'ann?e \n")

# calcul de l'accroissement de G par cumul et de la mortalite (uniquement pour des suivi sur liste et que si on a la table Arb)
  if (is.null(Arb)) {
    warning("Arb n'est pas renseign?e. Les donn?es sur la mortalit? et l'accroissement en G ne seront pas calcul?es")
  } else if (!is.data.frame(Arb)) {
    warning("Arb doit etre un data.frame. Les donn?es sur la mortalit? et l'accroissement en G ne seront pas calcul?es")
  } else if (length(setdiff(c("co_ech","statut_av_id","eclairci_realise_id","id_unite",
                              "no_mesure","no_arbre","etat_san_id","c130"), names(Arb))) !=0) {
    warning("Il manque des colonnes dans Arb (les donn?es sur la mortalit? et l'accroissement en G ne seront pas calcul?es). Colonnes obligatoires : 'co_ech','statut_av_id','eclairci_realise_id','id_unite','no_mesure','no_arbre','etat_san_id','c130'")
  } else {
    # jonction entre les inventaires de debut et les arbres correspondant
    acc.i <- merge(subset(Output, suivi.i == "liste", select = c(id_unite,no_mesure.i, no_mesure.f, surf_inv.i, duree)),
                   subset(Arb, co_ech %in% c(-1,0:3) & statut_av_id != 4 & eclairci_realise_id == 0),
                   by.x = c("id_unite", "no_mesure.i"), by.y = c("id_unite", "no_mesure"))
    acc.f <- merge(subset(Output, suivi.i == "liste", select = c(id_unite, no_mesure.i, no_mesure.f)),
                   subset(Arb, co_ech != 9, select = c(id_unite, no_mesure, no_arbre, co_ech, etat_san_id, statut_av_id, c130)),
                   by.x = c("id_unite", "no_mesure.f"), by.y = c("id_unite", "no_mesure"))
    # jonction entre les inventaires de fin et les arbres correspodant
    acc <- merge(acc.i, acc.f, by = c("id_unite", "no_mesure.i", "no_mesure.f", "no_arbre"), suffixes = c(".i",".f"), all = T)
    # calcul ac130 et evolution des tiges
    acc$ac130     <- with(acc, ifelse(co_ech.f == 4 & is.na(c130.f),  0, (c130.f - c130.i) / duree))
    acc$ag130     <- with(acc, (2 * (duree*ac130) * c130.i + (duree*ac130)^2) / (duree * 40000 * pi))
    acc$recru     <- with(acc, ifelse(is.na(duree), T, F))
    acc$mort      <- with(acc, ifelse(!is.na(duree) & co_ech.f == 4, T, F))
    acc$regresse  <- with(acc, ifelse(!is.na(duree) & co_ech.f != 4 & statut_av_id.f == 4, T, F))
    acc$maintien  <- with(acc, ifelse(!is.na(duree) & co_ech.f != 4 & !statut_av_id.f == 4, T, F))
# somme et taux par placette
    if (nrow(acc) != 0) {
      acc_plac      <- summaryBy(ag130 + mort + regresse + maintien + recru ~ id_unite + no_mesure.i + no_mesure.f,
                                 acc, FUN = sum, na.rm = T, keep.name = T)
        acc_plac$tx.mortalite  <- acc_plac$mort / (acc_plac$mort + acc_plac$regresse + acc_plac$maintien)
        acc_plac$tx.regression <- acc_plac$regresse / (acc_plac$mort + acc_plac$regresse + acc_plac$maintien)
        acc_plac$tx.maintien   <- acc_plac$maintien / (acc_plac$mort + acc_plac$regresse + acc_plac$maintien)
        acc_plac$tx.recru      <- acc_plac$recru / (acc_plac$mort + acc_plac$regresse + acc_plac$maintien)
        acc_plac$ab.Gha_tot    <- acc_plac$ag130
      Output <- merge(Output,
                      acc_plac[,c("id_unite","no_mesure.i","no_mesure.f","tx.mortalite","tx.regression","tx.maintien","tx.recru","ab.Gha_tot")],
                      by = c("id_unite","no_mesure.i","no_mesure.f"), all.x = T)
      Output$ab.Gha_tot <- Output$ab.Gha_tot * 10000 / Output$surf_inv.i
      cat("Nouvelle variable tx.mortalite : taux de mortalite dans l'etage principal sur toute la duree de la periode \n")
      cat("Nouvelle variable tx.regresse : taux de tiges de l'etage principal regressant dans le sous-etage sur toute la duree de la periode \n")
      cat("Nouvelle variable tx.maintien : taux de tiges de l'etage principal restant dans cette strate (1 - mortalite - regression) sur toute la duree de la periode \n")
      cat("Nouvelle variable tx.recru : taux de tiges passant du sous-etage a l'etage principal sur toute la duree de la periode \n")
      cat("Nouvelle variable ab.Gha_tot : accroissement courant annuel en surface terri?re de la placette au cours de la periode (somme des accroissements individuels, ne prend pas en compte l'?ventuel recru) \n")
    } else {
      warning("il n'y a pas de suivi par liste sur des periode suffisamment longue")
    }
  }
  # iv). resultat

  return(Output)
}