Merge pull request #472 from bcow/master

additional changes to met workflow functions

modules/data.atmosphere/NAMESPACE

@@ -25,6 +25,7 @@ export(met2CF.csv)
 export(metgapfill)
 export(par2ppfd)
 export(qair2rh)
+export(read.register)
 export(rh2qair)
 export(site.lst)
 export(solarMJ2ppfd)

modules/data.atmosphere/R/extract.nc.R

@@ -34,7 +34,6 @@ extract.nc <- function(in.path,in.prefix,outfolder,start_date,end_date,slat,slon
   close <- closest_xy(slat, slon,in.path,in.prefix)
   x <- close$x
   y <- close$y
-  print(c(x,y))
 
   start_year <- year(start_date)
   end_year <- year(end_date)

modules/data.atmosphere/R/met.process.R

@@ -17,6 +17,12 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
   require(RPostgreSQL)
   require(XML)
 
+  #setup connection and host information
+  con      <- db.open(dbparms)
+  username <- ""  
+  ifelse(host$name == "localhost", machine.host <- fqdn(), machine.host <- hostname)
+  machine = db.query(paste0("SELECT * from machines where hostname = '",machine.host,"'"),con)
+
   #get met source and potentially determine where to start in the process
   met <- ifelse(is.null(input_met$source), logger.error("Must specify met source"),input_met$source)
 
@@ -25,13 +31,8 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
   # Then unnecessary steps could be skipped?
 
   #read in registration xml for met specific information
-  register <- xmlToList(xmlParse(system.file(paste0("registration/register.", met, ".xml"), package = "PEcAn.data.atmosphere")))
-
-  #setup connection and host information
-  con      <- db.open(dbparms)
-  username <- ""  
-  ifelse(host$name == "localhost", machine.host <- fqdn(), machine.host <- hostname)
-  machine = db.query(paste0("SELECT * from machines where hostname = '",machine.host,"'"),con)
+  register.xml <- system.file(paste0("registration/register.", met, ".xml"), package = "PEcAn.data.atmosphere")
+  register <- read.register(register.xml, con)
 
   #setup additional browndog arguments
   if(!is.null(browndog)){browndog$inputtype <- register$format$inputtype}
@@ -53,7 +54,7 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
     check = db.query(
       paste0("SELECT i.start_date, i.end_date, d.file_path, d.container_id, d.id  from dbfiles as d join inputs as i on i.id = d.container_id where i.site_id =",register$siteid,
              " and d.container_type = 'Input' and i.format_id=",register$format$id, " and d.machine_id =",machine$id,
-             " and (i.start_date, i.end_date) OVERLAPS (DATE '", as.POSIXlt(start_date, tz = "GMT"),"',DATE '",as.POSIXlt(end_date, tz = "GMT"),"')"),con)
+             " and (i.start_date <= DATE '",as.POSIXlt(start_date, tz = "GMT"),"') and (DATE '", as.POSIXlt(end_date, tz = "GMT"),"' <= i.end_date)" ),con)
     print("end CHECK")
     options(digits=10)
     print(check)
@@ -83,7 +84,7 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
     check = db.query(
       paste0("SELECT i.start_date, i.end_date, d.file_path, d.container_id, d.id  from dbfiles as d join inputs as i on i.id = d.container_id where i.site_id =",site$id,
              " and d.container_type = 'Input' and i.format_id=",register$format$id, " and d.machine_id =",machine$id,
-             " and (i.start_date, i.end_date) OVERLAPS (DATE '", as.POSIXlt(start_date, tz = "GMT"),"',DATE '",as.POSIXlt(end_date, tz = "GMT"),"')"),con)
+             " and (i.start_date <= DATE '",as.POSIXlt(start_date, tz = "GMT"),"') and (DATE '", as.POSIXlt(end_date, tz = "GMT"),"' <= i.end_date)" ),con)
     print("end CHECK")
     options(digits=10)
     print(check)
@@ -115,7 +116,7 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
   #--------------------------------------------------------------------------------------------------#
   # Change to  CF Standards
 
-  print("### Change to CF Standards")
+  logger.info("Begin change to CF Standards")
 
   input.id  <-  raw.id[1]
   pkg       <- "PEcAn.data.atmosphere"
@@ -133,7 +134,7 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
     check = db.query(
       paste0("SELECT i.start_date, i.end_date, d.file_path, d.container_id, d.id  from dbfiles as d join inputs as i on i.id = d.container_id where i.site_id =",register$siteid,
              " and d.container_type = 'Input' and i.format_id=",format.id, " and d.machine_id =",machine$id, " and i.name = '", input_name,
-             "' and (i.start_date, i.end_date) OVERLAPS (DATE '", as.POSIXlt(start_date, tz = "GMT"),"',DATE '",as.POSIXlt(end_date, tz = "GMT"),"')"),con)
+             "' and (i.start_date <= DATE '",as.POSIXlt(start_date, tz = "GMT"),"') and (DATE '", as.POSIXlt(end_date, tz = "GMT"),"' <= i.end_date)" ),con)
     print("end CHECK")
     options(digits=10)
     print(check)
@@ -161,7 +162,7 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
     check = db.query(
       paste0("SELECT i.start_date, i.end_date, d.file_path, d.container_id, d.id  from dbfiles as d join inputs as i on i.id = d.container_id where i.site_id =",register$siteid,
              " and d.container_type = 'Input' and i.format_id=",format.id, " and d.machine_id =",machine$id, " and i.name = '", input_name,
-             "' and (i.start_date, i.end_date) OVERLAPS (DATE '", as.POSIXlt(start_date, tz = "GMT"),"',DATE '",as.POSIXlt(end_date, tz = "GMT"),"')"),con)
+             "' and (i.start_date <= DATE '",as.POSIXlt(start_date, tz = "GMT"),"') and (DATE '", as.POSIXlt(end_date, tz = "GMT"),"' <= i.end_date)" ),con)
     print("end CHECK")
     options(digits=10)
     print(check)
@@ -180,9 +181,9 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
 
     print("start CHECK")   
     check = db.query(
-      paste0("SELECT i.start_date, i.end_date, d.file_path, d.container_id, d.id  from dbfiles as d join inputs as i on i.id = d.container_id where i.site_id =",register$siteid,
+      paste0("SELECT i.start_date, i.end_date, d.file_path, d.container_id, d.id  from dbfiles as d join inputs as i on i.id = d.container_id where i.site_id =",new.site$id,
              " and d.container_type = 'Input' and i.format_id=",33, " and d.machine_id =",machine$id, " and i.name = '", input_name,
-             "' and (i.start_date, i.end_date) OVERLAPS (DATE '", as.POSIXlt(start_date, tz = "GMT"),"',DATE '",as.POSIXlt(end_date, tz = "GMT"),"')"),con)
+             "' and (i.start_date <= DATE '",as.POSIXlt(start_date, tz = "GMT"),"') and (DATE '", as.POSIXlt(end_date, tz = "GMT"),"' <= i.end_date)" ),con)
     print("end CHECK")
     options(digits=10)
     print(check)
@@ -202,12 +203,16 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
                            username,con=con,hostname=host$name,browndog=NULL,write=TRUE) 
   }
 
+  logger.info("Finished change to CF Standards")
+
   #--------------------------------------------------------------------------------------------------#
   # Change to Site Level - Standardized Met (i.e. ready for conversion to model specific format)
 
+  logger.info("Begin Standardize Met")
+
   if(register$scale=="regional"){ #### Site extraction 
 
-    print("# Site Extraction")
+    logger.info("Site Extraction")
 
     input.id   <- cf.id[1]
     outfolder  <- file.path(dir,paste0(met,"_CF_site_",str_ns))
@@ -222,7 +227,7 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
 
   }else if(register$scale=="site"){ ##### Site Level Processing
 
-    print("# Run Gapfilling") # Does NOT take place on browndog!
+    logger.info("Gapfilling") # Does NOT take place on browndog!
 
     input.id   <- cf.id[1]
     outfolder  <- file.path(dir,paste0(met,"_CF_gapfill_site_",str_ns))
@@ -236,11 +241,13 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
                                 username,con=con,hostname=host$name,browndog=NULL,write=TRUE,lst=lst)
 
   }
-  print("Standardized Met Produced")
+  logger.info("Finished Standardize Met")
 
   #--------------------------------------------------------------------------------------------------#
   # Prepare for Model
 
+  logger.info("Begin Model Specific Conversion")
+
   # Determine output format name and mimetype   
   model_info <- db.query(paste0("SELECT f.name, f.id, f.mime_type from modeltypes as m join modeltypes_formats as mf on m.id
                                 = mf.modeltype_id join formats as f on mf.format_id = f.id where m.name = '",model,"' AND mf.tag='met'"),con)
@@ -258,7 +265,7 @@ met.process <- function(site, input_met, start_date, end_date, model, host, dbpa
   model.id  <- convert.input(input.id,outfolder,formatname,mimetype,site.id=site$id,start_date,end_date,pkg,fcn,
                              username,con=con,hostname=host$name,browndog,write=TRUE,lst=lst,lat=new.site$lat,lon=new.site$lon)
 
-  print(c("Done model convert",model.id[1]))
+  logger.info(paste("Finished Model Specific Conversion",model.id[1]))
 
   model.file <- db.query(paste("SELECT * from dbfiles where id =",model.id[[2]]),con)[["file_name"]]
 

modules/data.atmosphere/R/met2CF.Ameriflux.R

@@ -138,8 +138,6 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date
     dim=list(lat,lon,time)
 
     # copy lat attribute to latitude
-    print(latlon)
-    print(lst)
     var <- ncvar_def(name="latitude",
                      units="degree_north",
                      dim=list(lat,lon), missval=as.numeric(-9999))

modules/data.atmosphere/R/metgapfill.R

@@ -335,7 +335,9 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst=
     nc_close(nc)
 
     if (length(error) > 0) {
-      logger.severe("Could not do gapfill, results are in", new.file, ".",
+      fail.file <- file.path(outfolder, paste(in.prefix, year,"failure","nc", sep="."))
+      file.rename(from = new.file, to = fail.file)
+      logger.severe("Could not do gapfill, results are in", fail.file, ".",
                     "The following variables have NA's:", paste(error, sep=", "))
     }
 

modules/data.atmosphere/R/read.register.R

@@ -0,0 +1,42 @@
+##' @name read.register
+##' @title read.register
+##' @export
+##' @param register.xml path of xml file
+##' @param con betydb connection
+##' 
+##' @author Betsy Cowdery
+
+read.register <- function(register.xml, con){
+
+  library(XML)
+  library(lubridate)
+  library(PEcAn.DB)
+  library(PEcAn.utils)
+
+  register <- xmlToList(xmlParse(register.xml))
+  print(as.data.frame(register))
+
+  #check scale 
+  if(is.null(register$scale)){
+    logger.error("Scale is not defined")
+  }else{
+    if(register$scale == "regional" & is.null(register$siteid)){logger.error("Region site id is not defined")}
+  }
+
+  #check format
+  if(is.null(register$format)){ # format is not defined
+    logger.error("Format is not defined")
+  }else if(is.null(register$format$inputtype)){
+    logger.error("Browndog input type is not defined") #Ultimatly can get this from the format table in betydb
+  }else{ #format is defined 
+    if((is.null(register$format$id) & is.null(register$format$name)  & is.null(register$format$mimetype))|(is.null(register$format$id) & is.null(register$format$name))|(is.null(register$format$id) & is.null(register$format$mimetype))){
+      logger.error("Not enough format info")
+    }else if((!is.null(register$format$id) & is.null(register$format$name))| (!is.null(register$format$id) & is.null(register$format$mimetype))){
+      register$format$name <- db.query(paste("SELECT name from formats where id = ",register$format$id),con)[[1]]
+      register$format$mimetype <- db.query(paste("SELECT mime_type from formats where id = ",register$format$id),con)[[1]]
+    }else if(is.null(register$format$id) & !is.null(register$format$name)  & !is.null(register$format$mimetype)){
+      register$format$id <- db.query(paste0("SELECT id from formats where name = '",register$format$name, "' and mime_type = '", register$format$mimetype, "'"),con)[[1]]
+    }
+  }
+  invisible(register)
+}

utils/R/convert.input.R

@@ -7,9 +7,8 @@
 ##' @author Betsy Cowdery, Michael Dietze
 convert.input <- function(input.id,outfolder,formatname,mimetype,site.id,start_date,end_date,
                           pkg,fcn,username,con=con,hostname='localhost',browndog, write=TRUE,...){
-  print(paste("Convert.Inputs",fcn,input.id,hostname))
-  print(paste(outfolder,formatname,mimetype,site.id,start_date,end_date))
-  l <- list(...); print(l)
+  logger.info(paste("Convert.Inputs",fcn,input.id,hostname,outfolder,formatname,mimetype,site.id,start_date,end_date))
+  l <- list(...); #print(l)
   n <- nchar(outfolder)
   if(substr(outfolder,n,n) != "/"){outfolder = paste0(outfolder,"/")}
 
@@ -77,15 +76,15 @@ convert.input <- function(input.id,outfolder,formatname,mimetype,site.id,start_d
     # check if we can do conversion 
     out.html <- getURL(paste0("http://dap-dev.ncsa.illinois.edu:8184/inputs/",browndog$inputtype), .opts = curloptions)
     if(outputtype %in% unlist(strsplit(out.html, '\n'))){
-      print(paste("Conversion from", browndog$inputtype,"to", outputtype, "through Brown Dog"))
+      logger.info(paste("Conversion from", browndog$inputtype,"to", outputtype, "through Brown Dog"))
       conversion <- "browndog"
     }
   }
 
   if(conversion == "browndog"){
 
     url <- file.path(browndog$url,outputtype) 
-    print(url)
+    #print(url)
 
     # loop over files in localhost and zip to send to Brown Dog 
     files <- list.files(dbfile$file_path, pattern=dbfile$file_name)
@@ -102,19 +101,18 @@ convert.input <- function(input.id,outfolder,formatname,mimetype,site.id,start_d
     # post zipped file to Brown Dog
     html <- postForm(url,"fileData" = fileUpload(zipfile), .opts = curloptions)
     link <- getHTMLLinks(html)
-    print(link)
+    #print(link)
     file.remove(zipfile)
 
     # download converted file
     outfile <- file.path(outfolder,unlist(strsplit(basename(link),"_"))[2])
     download.url(url = link, file = outfile, timeout = 600, .opts = curloptions, retry404 = TRUE)  
-    print(list.files(outfolder))
+    #print(list.files(outfolder))
 
     # unzip downloaded file if necessary
     if(file.exists(outfile)){
       if(tail(unlist(strsplit(outfile,"[.]")),1)=="zip"){
         fname <- unzip(outfile, list=TRUE)$Name
-        print(fname)
         unzip(outfile, files=fname, exdir=outfolder, overwrite=TRUE)
         file.remove(outfile)
       }else{fname <- list.files(outfolder)}
@@ -147,7 +145,7 @@ convert.input <- function(input.id,outfolder,formatname,mimetype,site.id,start_d
     }else{
       cmdFcn  = paste0(pkg,"::",fcn,"(",paste0("'",args,"'",collapse=","),")") 
     } 
-    print(cmdFcn)
+    print(cmdFcn) #do we want to print this?
     result <- remote.execute.R(script=cmdFcn,hostname,user=NA,verbose=TRUE,R="R")
   }