R/IFN.R

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

#' Liste les fichiers IFN par leur nom
#'
#' La fonction extrait la liste, par type d'objet des fichiers IFN
#' de donnees brutes, presents dans le dossier 'doss'
#'
#' @param doss le nom du dossier contenant les fichiers zip de l'IFN
#'
#' @return Liste les noms de fichiers contenus dans les fichiers zip
#' @family IFN
#'
#' @export getListFich_IFN
#'
#' @examples
#' getListFich_IFN(doss = system.file("extdata/IFN", package = "gftools"))
#'
getListFich_IFN <- function(doss) {
  doss <- normalizePath(doss, mustWork = FALSE)
  acc <- file.access(names = doss, 0)
  if (all(acc == -1)) {
    stop(paste("You do not have access to", doss, "!"))
  }
  ListZip <- dir(path = doss, pattern = "^([[:digit:]]){4}(-[[:digit:]]){0,1}(.zip)$", full.names = TRUE)
  if (length(ListZip) == 0) {
    stop("No .zip file in IFN in path!")
  }
  ListFich <- grep(pattern = ".csv", unlist(lapply(ListZip, FUN = function(x) unzip(x, list = TRUE)[, 1])), value = TRUE)
  ListFichObj <- list(Zip = ListZip, Pla = grep(pattern = "placettes_foret", ListFich, value = T), Arb = grep(pattern = "arbres_foret", ListFich, value = T), Eco = grep(
    pattern = "(ecologie_)([[:digit:]]){4}(.csv)",
    ListFich, value = T
  ), Flore = grep(pattern = "(flore_)([[:digit:]]){4}(.csv)", ListFich, value = T), Couv = grep(pattern = "couverts_foret", ListFich, value = T), PlaPeup = grep(
    pattern = "placettes_peupleraie",
    ListFich, value = T
  ), ArbPeup = grep(pattern = "arbres_peupleraie", ListFich, value = T), ArbMorts = grep(pattern = "arbres_morts_foret", ListFich, value = T), ArbPeupMorts = grep(
    pattern = "arbres_morts_peupleraie",
    ListFich, value = T
  ), Doc = grep(pattern = "(documentation_)([[:digit:]]){4}(.csv)", ListFich, value = T), DocFlore = grep(
    pattern = "documentation_flore", ListFich,
    value = T
  ))
  return(ListFichObj)
}

#' Liste les fichiers IFN par type d'objets
#'
#' La fonction extrait la liste, par type d'objet des fichiers IFN
#' de donnees brutes, presents dans le dossier 'doss'
#'
#' @details Attention, le temps d'execution de la fonction peut etre un peu long.
#' Il est lie au temps d'acces au dossier (typiquement sous T:) et au temps de lecture,
#'  ouverture et chargement des donnees IFN.
#' Par ailleurs les donnees d'un meme type d'objet restent separees dans le resultat produit.
#' C'est a l'utilisateur de veiller au fait qu'il peu, ou non, les rassembler dans un seul et unique data.frame.
#'
#' Attention, ce n'est pas parce qu'une variable existe plusieurs annees de suite qu'elle peut etre
#' regroupee : les modalites peuvent avoir change ou (pire) le sens de ces modalite !!
#'
#' Une seule regle : lire et relire la doc !!
#'
#' Voir aussi les exemples.
#'
#' @param obj vecteur des principaux 'objets' IFN dont on cherche a recuperer les donnees :
#'  \code{'Pla'} (placettes), \code{'Arb'} (arbres), \code{'Eco'} (ecologie), \code{'Flore'} (flore) et \code{'Couv'} (couverts)
#' @param Peup faut-il charger les donnees Peuplier ? Vaut \code{FALSE} par defaut
#' @param Morts faut-il charger les donnees des arbres morts ? Vaut \code{FALSE} par defaut
#' @param Doc faut-il charger les tables de documentation ? Vaut \code{TRUE} par defaut
#' @param ans vecteur (numerique) des annees charger. \code{2005:2013} par defaut
#' @param doss le nom du dossier contenant les fichiers zip de l'IFN (non modifies, avec leurs
#' noms en 20xx-v.zip, avec '20xx' l'annee et 'v' l'eventuelle version du fichier)
#'
#' @return une liste contenant les types d'objets, elle même subdivisee en data.frame par annee
#'
#' @author François Morneau, Pascal Obstetar
#'
#' @references Voir le portail internet IFN et toute la documentation associee au donnees.
#' Ainsi que, par exemple :
#' IGN Les donnees de l'inventaire forestier : etat des lieux et evolution, l'iF,
#'     La feuille de l'Inventaire forestier, 34, 17 p., nov. 2014
#' @export getFich_IFN
#' @family IFN
#'
#' @examples
#' \dontrun{
#' # Recuperation des seules donnees 'placette' des points foret et Peupleraie,
#' # sans la doc et pour qq annees
#' Plac_IFN <- getFich_IFN(obj = 'Pla', Peup = TRUE, Doc = FALSE, ans = c(2006, 2005, 2013, 2008))
#' # Sous selection des seuls identifiants de points et des coordonnees
#' PlaPeup <- lapply(Plac_IFN$PlaPeup, function(x) subset(x, select = c(idp, xl93, yl93)))
#' PlaFor <- lapply(Plac_IFN$Pla, function(x) subset(x, select = c(idp, xl93, yl93)))
#' rm(Plac_IFN)
#'
#' # Creation d'un data.frame unique
#' PlaPeup <- do.call('rbind', PlaPeup)
#' PlaFor <- do.call('rbind', PlaFor)
#' Pla <- rbind(data.frame(type_pla = 'Foret', PlaFor), data.frame(type_pla = 'Peup', PlaPeup))
#' Pla$an <- as.factor(floor(Pla$idp/ 100000) + 2005) # annee d'inventaire
#' xtabs(~ an , Pla)
#' rm(PlaPeup, PlaFor)
#'
#' # Changement de projection
#' require(sp)
#' require(rgdal)
#' coordinates(Pla) <- ~ xl93 + yl93
#'
#' # Definition de la projection utilisee
#' proj4string(Pla) <- lambert93
#'
#' # Transformation en lambert2 etendu
#' Pla <- spTransform(Pla, CRS(lambert2e))
#' Pla <- data.frame(Pla)
#' names(Pla)[names(Pla) %in% c('xl93', 'yl93')] <- c('x_l2e', 'y_l2e')
#'
#' ## Carte des points IFN
#' require(ggplot2)
#' # Creation du graphique par ajout des couches 'france.df' et 'Pla'
#' p <- ggplot(Pla) +
#' \t\taes(x = x_l2e, y = y_l2e, colour = type_pla) +
#'    facet_wrap(~ an) +
#'    geom_point() +
#'    scale_color_brewer('Type de placette', palette = 'Set1') +
#'    coord_equal() +
#' \t\ttheme_bw()
#' p
#'
#' ### Exemple 3
#' # Recuperation des donnees 'Eco'. Ces dernieres n'ont change qu'en 2013
#' # avec l'ajout de 4 variables : 'obsriv'   'obsriv2'  'distriv'  'denivriv'
#' Eco_IFN <- getFich_IFN(obj = 'Eco', Doc = FALSE, ans = 2010:2013)$Eco
#' str(Eco_IFN, 1)
#' # tp <- do.call('rbind', Eco_IFN) # Conduit a une erreur
#' tp2 <- do.call('rbind', Eco_IFN[1:3]) # Fonctionne !
#' str(tp2)
#' }
#'

getFich_IFN <- function(obj = c("Pla", "Arb", "Eco", "Flore", "Couv"), Peup = FALSE, Morts = FALSE, Doc = TRUE, ans = 2005:2013, doss) {
  if (any(!obj %in% c("Pla", "Arb", "Eco", "Flore", "Couv"))) {
    stop("Bad argument 'obj' : see help function!")
  }
  if (!is.numeric(ans)) {
    stop("'ans' must be 'numeric'")
  }
  # tri des annees demandees par ordre croissant (sait-on jamais !)
  ans <- sort(unique(ans))
  # liste des fichiers IFN disponibles
  ListFich <- gftools::getListFich_IFN(doss)
  ListZip <- ListFich$Zip
  anszip <- as.numeric(substr(basename(tools::file_path_sans_ext(ListFich$Zip)), 1, 4))

  if (!all(ans %in% anszip)) {
    stop(paste("No inventory data for the year!", ans[!(ans %in% anszip)], "\n"))
  }
  # Sous-ensemble des fichiers .zip a regarder
  ListZip <- ListZip[anszip %in% ans]
  anszip <- anszip[anszip %in% ans]
  # Creation de la liste des objets a recuperer
  ListObj <- obj
  if (Morts) {
    ListObj <- c(ListObj, "ArbMorts")
  }
  if (Peup) {
    if (any(c("Pla", "Arb") %in% ListObj)) {
      ListObj <- c(ListObj, paste(ListObj[ListObj %in% c("Pla", "Arb")], "Peup", sep = ""))
    }
    if (Morts) {
      ListObj <- c(ListObj, "ArbPeupMorts")
    }
  }
  if (Doc) {
    ListObj <- c(ListObj, "Doc")
    if ("Flore" %in% ListObj) {
      ListObj <- c(ListObj, "DocFlore")
    }
  }
  # liste des annees disponibles par type d'objet
  ansdispObj <- lapply(ListFich[ListObj], function(obj) as.numeric(do.call(rbind, regmatches(obj, regexec("^([[:digit:]]){4}", obj)))[, 1]))
  # Creation d'une liste des fichiers zip a utiliser par objet
  ListZip <- lapply(ListFich[ListObj], function(x) x <- ListZip)
  # Comparaison avec les annees demandees
  ansindispObj <- lapply(ansdispObj, function(obj) ans[!ans %in% obj])
  for (obj in ListObj) {
    anindisp <- ansindispObj[[obj]]
    if (length(anindisp) > 0) {
      # Message signalant le probleme
      message(paste("Year", anindisp, "not available for the object", obj, "\n"))
      # Modification de la liste des fichiers .zip a consulter
      ListZip[[obj]] <- ListZip[[obj]][!anszip %in% anindisp]
    }
  }
  # Selections des seules annees requises pour l'export
  ansexpObj <- lapply(ansdispObj, function(obj) obj %in% ans)
  # Sous ensemble des fichiers a charger
  ListFich <- mapply(function(x, y) x[y], ListFich[ListObj], ansexpObj[ListObj], SIMPLIFY = FALSE)
  # Chargement des fichiers en question
  Fich <- mapply(
    function(fich, zipf) mapply(function(x, y) read.table(unz(x, y), header = TRUE, sep = ";", dec = ".", quote = ""), zipf, fich, SIMPLIFY = FALSE), ListFich[ListObj],
    ListZip, SIMPLIFY = FALSE
  )
  # Simplification des noms
  Fich <- lapply(Fich, function(x) {
    names(x) <- do.call(rbind, regmatches(names(x), regexec("([[:digit:]]){4}", names(x))))[, 1]
    x
  })
  return(Fich)
}