R/CvIFNSER.R

In pobsteta/gftools: Geographic Data Analysis and Modeling for Forests

#' Coefficients de variation du Gha et par essence sur une region SER donnee
#'
#' #' @description La fonction renvoie des coefficients de variation sur la surface terriere
#' en utilisant la base de donnees arbres de l'IFN.
#' La fonction necessite en entree un shape correspondant au perimetre retenu : forêt, massif,
#' sylvoecoregion, etc.
#'
#' @param enreg = FALSE par defaut, n'enregistre pas le tableau resultat
#' @param fichier = nom du fichier (chemin du repertoire compris) de la zone sur laquelle est calcule le tableau resultat
#' @param annee  = c(2005:2016) par defaut, vecteur indiquant les donnees IGN servant au calcul du tableau resultat
#' @param periode = NULL par defaut, couvre donc l'ensemble de la periode du vecteur annee, si 1 alors tableau resultat calcule annee par annee
#' @param tailleBuffer = 450 par defaut (450m), distance au-dela de la zone calculee sur laquelle les points des placettes IGN sont pris
#' @param tableau = 1 par defaut, renvoi un tableau des coefficients de variation sur la surface terriere totale, par essence et categorie de
#' diametre regroupee (PER, PB, BM, GB), si 2 renvoi un tableau des coefficients de variation sur la surface terriere par essence et par periode,
#' si 3 renvoi un tableau des coefficients de variation sur la surface terriere par essence, par periode et classe de diametre
#'
#' @return La fonction renvoie un tableau des coefficients de variation sur la surface terriere
#' \itemize{
#'  \item des essences contribuant a plus de 10\% de la surface terriere
#'  \item des PER, PB, BM et GB
#'  \item des gros bois des 2 essences contribuant le plus a la surface terriere
#'  \item des essences par periode annuelle regroupee des donnees IGN
#'  \item des essences par periode annuelle regroupee des donnees IGN
#' }
#'
#' @export CvIFNSER
#'
#' @author Pascal Obstetar
#'
#' @examples
#' \dontrun{
#' CvIFNSER(fichier = '~/frt_test.shp', enreg = F, tableau = 1)
#' CvIFNSER(fichier = '~/frt_test.shp', enreg = F, tableau = 2)
#' CvIFNSER(fichier = '~/frt_test.shp', enreg = F, tableau = 3)
#' CvIFNSER(fichier = '~/frt_test.shp', enreg = F, tableau = 2, periode=6)
#' CvIFNSER(fichier = '~/ec21.shp', enreg = F, tableau = 3, periode=6)
#' }
#'

CvIFNSER <- function(fichier = NULL, annee = c(2005:2016), periode = NULL, tailleBuffer = 450, enreg = F, tableau = 1) {
  if (is.null(fichier)) {
    stop("Your fichier is NULL!")
  }
  if (file.access(fichier) == -1) {
    stop(paste("You have no access to file:", fichier))
  }
  vecteur_annee <- annee
  periode <- dplyr::if_else(is.null(periode), max(annee) - min(annee) + 1, periode)
  donnees <- system.file("extdata/IFN", package = "gftools")
  CodesEssIFN <- gftools::getData("IFNCODE") %>% dplyr::filter(donnee %in% "ESPAR")
  # Extract placettes et arbres
  message("Extract data placettes...")
  plac <- data.frame()
  for (i in 1:length(vecteur_annee)) {
    yrs <- as.numeric(vecteur_annee[i])
    ifn <- gftools::getFich_IFN(obj = c("Pla"), Peup = FALSE, Morts = FALSE, Doc = TRUE, ans = yrs, doss = donnees)
    placet <- data.frame(yrs = yrs, ifn$Pla[[1]][, c("idp", "ser", "xl93", "yl93")])
    plac <- rbind(plac, placet)
  }
  message("Extract data arbres...")
  arb <- data.frame()
  for (i in 1:length(vecteur_annee)) {
    yrs <- as.numeric(vecteur_annee[i])
    ifn <- gftools::getFich_IFN(obj = c("Arb"), Peup = FALSE, Morts = FALSE, Doc = TRUE, ans = yrs, doss = donnees)
    arbre <- data.frame(yrs = yrs, ifn$Arb[[1]][, c("idp", "espar", "c13", "w")])
    arb <- rbind(arb, arbre)
  }
  ser <- sf::st_read(system.file("extdata/shapes/SER/ser_l93.shp", package = "gftools"), quiet = TRUE)
  perimetre <- sf::st_read(fichier, quiet = TRUE)
  perimetre <- sf::st_transform(perimetre, crs = 2154)
  ser <- sf::st_transform(ser, crs = 2154)
  perimetre <- sf::st_union(perimetre)
  zone <- sf::st_buffer(perimetre, dist = tailleBuffer)
  placettes <- sf::st_intersection(sf::st_as_sf(plac, coords = c("xl93", "yl93"), crs = 2154, agr = "constant"), zone)

  ## Au niveau arbre
  suppressWarnings(
    suppressMessages(
      Gha <- arb %>%
        dplyr::filter(idp %in% placettes$idp) %>%
        dplyr::filter(!is.na(w)) %>%
        dplyr::mutate(Diam = round(c13 / pi, 0)) %>%
        dplyr::mutate(Classe = floor(c13 / pi / 5 + 0.5) * 5) %>%
        dplyr::mutate(Gha = pi / 40000 * Diam ^ 2 * as.numeric(w)) %>%
        dplyr::mutate(Population = 1 + (yrs - min(yrs)) %/% periode) %>%
        dplyr::mutate(Periode = paste(min(arb$yrs) + (Population - 1) * periode, min(arb$yrs) + (Population * periode) - 1, sep = " - ")) %>%
        dplyr::left_join(CodesEssIFN[, 2:3], by = c(espar = "code"))
    )
  )
  ## Au niveau placette (idp)
  suppressWarnings(
    suppressMessages(
      GhaPla <- Gha %>%
        dplyr::group_by(idp) %>%
        dplyr::do(gftools::describe(.$Gha, fast = TRUE)) %>%
        dplyr::group_by(vars) %>%
        dplyr::do(gftools::describe(.$sum, fast = TRUE)) %>%
        dplyr::ungroup() %>%
        tibble::add_column(.before = 1, libelle = "Totale")
    )
  )
  tab <- GhaPla
  nidp <- tab$n
  ## Au niveau placette (idp) par periode
  suppressWarnings(
    suppressMessages(
      GhaPlaPer <- Gha %>%
        dplyr::group_by(idp, Periode) %>%
        dplyr::do(gftools::describe(.$Gha, fast = TRUE)) %>%
        dplyr::group_by(Periode) %>%
        dplyr::do(gftools::describe(.$sum, fast = TRUE))
    )
  )
  tabp <- GhaPlaPer
  np <- tabp$n
  ## Au niveau essence
  suppressWarnings(
    suppressMessages(
      GhaEss <- Gha %>%
        dplyr::group_by(idp, libelle) %>%
        dplyr::do(gftools::describe(.$Gha, fast = TRUE)) %>%
        dplyr::transmute(sum = sum / nidp) %>%
        dplyr::group_by(libelle) %>%
        dplyr::do(gftools::describe(.$sum, fast = TRUE)) %>%
        dplyr::arrange(desc(sum)) %>%
        dplyr::ungroup()
    )
  )
  ListeEssPrinc <- GhaEss$libelle
  tab <- rbind(tab, GhaEss)
  ## Au niveau essence par categorie de diametre regroupee
  suppressWarnings(
    suppressMessages(
      GhaEssCat <- Gha %>%
        dplyr::mutate(Cat = cut(Classe, breaks = c(0, 17.5, 27.5, 47.5, 200), labels = c("PER", "PB", "BM", "GB"))) %>%
        dplyr::group_by(idp, Cat) %>%
        dplyr::do(gftools::describe(.$Gha, fast = TRUE)) %>%
        dplyr::transmute(sum = sum / nidp) %>%
        dplyr::group_by(Cat) %>%
        dplyr::do(gftools::describe(.$sum, fast = TRUE)) %>%
        dplyr::rename(libelle = Cat) %>%
        dplyr::ungroup()
    )
  )
  tab <- rbind(tab, GhaEssCat)
  ## Au niveau des 2 essences principales par GB+BM
  suppressWarnings(
    suppressMessages(
      GhaEssCat2 <- Gha %>%
        dplyr::mutate(Cat = cut(Classe, breaks = c(0, 17.5, 27.5, 47.5, 200), labels = c("PER", "PB", "BM", "GB"))) %>%
        dplyr::filter(libelle %in% ListeEssPrinc[1:2] & (Cat == "GB" | Cat == "BM")) %>%
        dplyr::group_by(idp, libelle, Cat) %>%
        dplyr::do(gftools::describe(.$Gha, fast = TRUE)) %>%
        dplyr::transmute(sum = sum / nidp) %>%
        dplyr::group_by(libelle) %>%
        dplyr::do(gftools::describe(.$sum, fast = TRUE)) %>%
        dplyr::ungroup() %>%
        dplyr::mutate(libelle = paste(libelle, "GB + BM")) %>%
        dplyr::arrange(desc(sum))
    )
  )
  tab <- rbind(tab, GhaEssCat2)

  if (tableau == 1) {
    out <- list(tab)
    names(out) <- c("Tableau1")
    if (enreg) {
      readr::write_excel_csv(tab, paste0(dirname(fichier), "/tab1CvIGNSER.csv"))
      message(paste0("Result is saved in: ", paste0(dirname(fichier), "/tab1CvIGNSER.csv")))
    }
  }
  if (tableau == 2) {
    ## Au niveau placette (idp) par periode et par essence
    suppressWarnings(
      suppressMessages(
        GhaPlaPerEss <- Gha %>%
          dplyr::group_by(idp, libelle, Periode) %>%
          dplyr::do(gftools::describe(.$Gha, fast = TRUE)) %>%
          dplyr::transmute(sum = sum / nidp) %>%
          dplyr::group_by(Periode, libelle) %>%
          dplyr::do(gftools::describe(.$sum, fast = TRUE)) %>%
          dplyr::ungroup() %>%
          dplyr::arrange(libelle, Periode)
      )
    )
    out <- list(GhaPlaPerEss)
    names(out) <- c("Tableau2")
    if (enreg) {
      readr::write_excel_csv(GhaPlaPerEss, paste0(dirname(fichier), "/tab2CvIGNSER.csv"))
      message(paste0("Result is saved in: ", paste0(dirname(fichier), "/tab2CvIGNSER.csv")))
    }
  }
  if (tableau == 3) {
    ## Au niveau placette (idp) par periode, par essence et par Classe
    suppressWarnings(
      suppressMessages(
        GhaEssPerEssCla <- Gha %>%
          dplyr::group_by(idp, libelle, Periode, Classe) %>%
          dplyr::do(gftools::describe(.$Gha, fast = TRUE)) %>%
          dplyr::transmute(sum = sum / nidp) %>%
          dplyr::group_by(Periode, libelle, Classe) %>%
          dplyr::do(gftools::describe(.$sum, fast = TRUE)) %>%
          dplyr::ungroup() %>%
          dplyr::arrange(libelle, Periode)
      )
    )
    out <- list(GhaEssPerEssCla)
    names(out) <- c("Tableau3")
    if (enreg) {
      readr::write_excel_csv(GhaEssPerEssCla, paste0(dirname(fichier), "/tab3CvIGNSER.csv"))
      message(paste0("Result is saved in: ", paste0(dirname(fichier), "/tab3CvIGNSER.csv")))
    }
  }
  message("Calculation realized!")
  return(out)
}