R/getGFS.R

##' Previsions d'ensemble GFS
##' 
##' \command{getGFS} aspire les prévisions de précipitations de 
##' témpératures de l'air et de rafales de vents du modèle GFS 
<<<<<<< HEAD
##' haute résolution (à 0,5 ou 0,25 degrés) fournies par NOAA-NCEP. 
##'   
##' @param date la date de simulation. Si la valeurs n'est pas fournie 
##' c'est aujourd'hui.
##' 
##' @param run l'heure de référence du calcul, choisie parmi les valeurs
##' \var{run=0, 6, 12 et 18}.
##' 
##' @param from valeur numérique donnant la première échéance à extraire.
##' 
##' @param to valeur numérique donnant le dernière écheance à extraire.
##' 
##' @param var la variable à extraire, choisie parmi les valeurs 
##' \var{var = 'precip', 'snow', 'temp' ou 'gust'}.  
##' 
##' @param lon la gamme des longitude à extraire en degrés décimaux.  
##' 
##' @param lat la gamme des latitudes à extraire en degrés décimaux.
##' 
##' @param hd valeur logique indiquant si l'on interroge le modèle à maille
##' fine de \var{0,25 deg} ou à maille large de \var{0,50 deg}. 
##' 
##' @param verbose valeur logique activant le fonctionnement bavard.
##' @param ... paramètres additionnels passés à la commande 
##' \command{download.file}.
##' 
##' @return 
##' \command{getGFS} retourne une liste contenant 4 éléments:
=======
##' haute résolution (à 0.5 ou 0.25 Deg) fournies par NOAA-NCEP. 
##'   
##' @param date la date de simulation. Si la valeurs n'est pas fournie 
##' c'est aujourd'hui.
##' @param run l'heure de référence du calcul, choisie parmi les valeurs
##' \var{run=0, 6, 12 et 18}.
##' @param from valeur numérique donnant la première échéance à extraire.
##' @param to valeur numérique donnant le dernière écheance à extraire.
##' @param var la variable à extraire, choisie parmi les valeurs 
##' \var{var = 'precip', 'snow', 'temp' ou 'gust'}.  
##' @param lon la gamme des longitude à extraire en degrés décimaux.  
##' @param lat la gamme des latitudes à extraire en degrés décimaux.
##' @param hd valeur logique indiquant si l'on interroge le modèle à 
##' maille fine de \var{0.25 deg} ou à maille large de \var{0.50 deg}. 
##' @param method la méthode à utiliser pour le téléchargement. 
##' En présence d'un proxy \sQuote{https} requérant une identification,
##' la méthode interne ne fonctionne pas. Il faut alors faire appel 
##' à l'outil \var{wget} via la méthode \samp{wget}.       
##' @param quiet valeur logique indiquant si la fonction reste 
##' silencieuse.
##' @param vebose valeur logique indiquant si la fonction est bavarde.
##' @param user chaîne de caractères donnant le nom d'utilisateur pour 
##' s'autentifier auprès du proxy. Ce paramètre n'est utile qu'avec 
##' la méthode \samp{wget}. 
##' @param pass chaîne de caratères indiquant le mot de passe 
##' d'autentification auorès du proxy.
##' @param verbose valeur logique activant le fonctionnement bavard.
##' 
##' @return \command{getGFS} retourne une liste contenant 4 éléments:
>>>>>>> 53ae716ce8775c9fd36538db2ce00c6b918e4778
##' \item{dir}{le chemin du répertoire temporaire contenant les GRIBs.}
##' \item{url}{les requêtes envoyés au serveur NOMADS.}
##' \item{files}{les noms des fichiers GRIBs téléchargés.}
##' \item{data}{la liste des jeux de données disponibles sous forme de 
##' \sQuote{RasterLayer} obtenus à l'aide des outils \command{raster} et 
##' \pkg{rgdal}.}
<<<<<<< HEAD
##' 
=======
>>>>>>> 53ae716ce8775c9fd36538db2ce00c6b918e4778
##' @examples
##' \dontrun{
##' x=getGFS(from=6, to=24)
##' visuGFS(x)
##' }
##' @author Thomas Esclaffer
##' @importFrom raster brick
##' @import raster
##' 
##' @export
getGFS <- 
<<<<<<< HEAD
   function(date, run=0, from=3, to=240, 
            var=c("precip", "snow", "temp","gust","alti"),
            lon=c(-8,12), lat=c(38,54), hd=TRUE, verbose = FALSE, ...) 
   {  
      ## Sélection du run GFS
      if (missing(date)) date <- Sys.Date()
      var <- match.arg(var)
      run <- (run %/% 6 )*6 
      drun <- format(date,"%Y%m%d")
      hrun <- formatC(run, width=2, flag="0")
      ## Vecteur d'écheances
      if (var == "alti") to <- from
      echeances <- formatC(seq(from, to, by=3), width=3, flag="0")
      DIR <- tempdir()
      
=======
   function(date, run, from=3, to=192, 
            var=c("precip", "snow", "temp","gust"),
            lon=c(-9,11), lat=c(35,55), hd=TRUE, 
            method=c("auto","internal","wget"), quiet=FALSE, verbose=FALSE, 
            user, pass) 
   {  
      ## Sélection du run GFS
      if (missing(date)) date <- Sys.Date()
      if (missing(run)) {
        run <- ((as.POSIXlt(Sys.time(),tz="UTC")$hour-5)%/%6) * 6
      } else {
        vrun <- ((as.numeric(run)%/%6) * 6)
        if (vrun != run) {
          warning("Le valeur", vrun, "est retenue pour 'run' !")
          run <- vrun
        }
      }
      ## 
      var <- match.arg(var)
      drun <- format(date,"%Y%m%d")
      hrun <- formatC(run, width=2, flag="0")
      ## Vecteur d'écheances
      echeances <- formatC(seq(from, to, by=3), width=3, flag="0")
      DIR <- tempdir()
      
      ## Arguments de configuration des outils CURL et WGET
      ## Partie requise pour la gestion des proxy 
      method <- match.arg(method)
      if (method=="wget") {
         extra="--no-check-certificate --tries=50"
         if (!missing(user) && !missing(pass))
            extra=c(extra, 
                    paste("--proxy-user=", user, sep=""),
                    paste("--proxy-passwd=", pass, sep=""))
      } else extra=NULL
      
>>>>>>> 53ae716ce8775c9fd36538db2ce00c6b918e4778
      ## Exemple de requete :
      ## -- Modele 025 -- 
      ## http://nomads.ncep.noaa.gov/cgi-bin/filter_gfs_0p25.pl?
      ## file=gfs.t00z.pgrb2.0p25.f000&lev_surface=on&
      ## var_APCP=on&leftlon=0&rightlon=360&toplat=90&bottomlat=-90&
      ## dir=%2Fgfs.2014121900
      ## 
      ## --Modele 050
      ## http://nomads.ncep.noaa.gov/cgi-bin/filter_gfs_0p50.pl?
      ## file=gfs.t12z.pgrb2full.0p50.f000&var_ACPCP=on&
      ## leftlon=0&rightlon=360&toplat=90&bottomlat=-90&
      ## dir=%2Fgfs.2015020212
<<<<<<< HEAD
     
=======

>>>>>>> 53ae716ce8775c9fd36538db2ce00c6b918e4778
      ## Schéma des Variables
      what <- switch(var,
                     precip="lev_surface=on&var_APCP=on",
                     snow="lev_surface=on&var_WEASD=on",
                     temp="lev_2_m_above_ground=on&var_TMP=on",
<<<<<<< HEAD
                     gust="lev_surface=on&var_GUST=on",
                     pmer="var_PRMSL=on",
                     alti="lev_surface=on&var_HGT=on")
=======
                     gust="lev_surface=on&var_GUST=on")
>>>>>>> 53ae716ce8775c9fd36538db2ce00c6b918e4778
      ## Schéma de base de l'URL de requete
      if (hd) {
        message("Extraction du modèle à maille 0.25 deg.")
        base="http://nomads.ncep.noaa.gov/cgi-bin/filter_gfs_0p25.pl?"
        ## Fonction de construction des requetes
        URL <- paste(base, "file=gfs.t",hrun,"z.pgrb2.0p25.f",
                     echeances,"&",what, "&subregion=",
                     "&leftlon=", min(lon),"&rightlon=", max(lon),
                     "&toplat=", max(lat), "&bottomlat=", min(lat),
                     "&dir=%2Fgfs.",drun,hrun, sep = "")
      } else {
        message("Extraction du modèle à maille 0.50 deg")
        base="http://nomads.ncep.noaa.gov/cgi-bin/filter_gfs_0p50.pl?"
        ## Fonction de construction des requetes
        URL <- paste(base, "file=gfs.t",hrun,"z.pgrb2full.0p50.f",
                     echeances,"&",what, "&subregion=",
                     "&leftlon=", min(lon),"&rightlon=", max(lon),
                     "&toplat=", max(lat), "&bottomlat=", min(lat),
                     "&dir=%2Fgfs.",drun,hrun, sep = "")
      }
      ## Fonction de construction du nom de fichier conteneur 
      FIC <- file.path(DIR, paste("grib_gfs",var, drun, hrun,
                                  echeances, sep="_"))
<<<<<<< HEAD
      ## Variables pour l'execution des requetes 
      nurl <- length(URL)
      message("Chargement de ", nurl, " fichiers pour '", var, "'")
      
      ## Execution des requetes
      start <- Sys.time()
      if (.Platform$OS == "windows") utils::setInternet2(use = TRUE)		
      for (i in 1:nurl) 
      {
        msg <- sprintf("(%2d/%d) Chargement de %s...", 
                       i, nurl, basename(FIC[i]))
        if (verbose) message(msg, appendLF = FALSE)
        suppressWarnings(
          redownload.file(URL[i], FIC[i], mode = "wb", quiet = TRUE, ...)
        )
        if (verbose) message("Ok")
        else if (i == nurl) message("..",nurl,"] Ok")
        else if (i == 1) message("[", i, appendLF = FALSE)
        else if ((i %% 10) == 0) message("..", i, appendLF = FALSE)
      }   
      ## Fin du téléchargement 
      time.up <- Sys.time() - start
      message("Durée du téléchargement: ", 
              signif(time.up,3)," ", units(time.up)) 
      ##
      ## Post-traitements   
      ## 
      ## Chargement des GRIB au format Raster
      message("Traitement des grilles...", appendLF = FALSE)
=======
      
      ## Variables pour l'execution des requetes 
      nurl <- length(URL)
      if (!quiet) message("Chargement de ", nurl, " fichiers ...")
      
      ## Execution des requetes
      start <- Sys.time()
      if (.Platform$OS=="windows") utils::setInternet2(use=TRUE)		
      
      chk <- logical()
      for (i in seq(nurl)) {
         retry <- 0
        
                   
         repeat {
           if (retry>0) Sys.sleep(3)
           if (!quiet) cat("\r[",i,"/", nurl,"] ", basename(FIC[i]),
                           " (",retry+1,"/10)", sep="") 
           chk[i] <- suppressWarnings(
             utils::download.file(
               URL[i], FIC[i], method=method, mode="wb", 
               cacheOK=TRUE, quiet=!verbose, extra=extra)
           )
           retry <- retry+1
           if (file.info(FIC[i])$size > 0)  break
           if (retry > 10) stop("\nTéléchargement impossible !")
         }
         #if (!quiet) cat("\r")
      }
      if (!quiet) cat("\nOk")
      time.up <- Sys.time() - start
      if(!quiet) message("Durée du téléchargement: ", 
                         signif(time.up,3)," ", units(time.up)) 
      ##
      ## Post-traitement   
      ## 
      ## Chargement des GRIB au format Raster
      if(!quiet) message("Traitement des grilles...")
>>>>>>> 53ae716ce8775c9fd36538db2ce00c6b918e4778
      #stk <- stack(as.list(FIC), quick=TRUE)
      tmp <- raster::brick(lapply(FIC, raster::raster))
      ## Mise à jour des coordonées du domaine.
      raster::extent(tmp) <- c(lon + c(-1,1)*raster::xres(tmp)/2,
                       lat + c(-1,1)*raster::yres(tmp)/2)
<<<<<<< HEAD
      message("Ok")
=======
>>>>>>> 53ae716ce8775c9fd36538db2ce00c6b918e4778
      ##
      ## Export des resultats
      drun <- as.POSIXct(date, tz="UTC") + 3600 * run
      invisible( 
         forecast(data=tmp, model="GFS", run=drun, variable=var,
                  echeances=as.numeric(echeances))
      )
   }
<<<<<<< HEAD

## 
redownload.file <- 
  function(url, destfile, mode="wb", quiet = TRUE, retry=5, ...) 
  {
    for(r in 1:retry) {
      res <- try(download.file(url, destfile, mode="wb", quiet = TRUE, ...))
      if (inherits(res, "try-error")) Sys.sleep(time = 5)
        else break
    }
    if (r == retry) stop("Echec du téléchargement de ", basename(destfile), "!" )  
  }

=======
>>>>>>> 53ae716ce8775c9fd36538db2ce00c6b918e4778
coolTot/DtgRecup documentation built on May 12, 2017, 9:45 a.m.