diff --git a/modules/data.atmosphere/NAMESPACE b/modules/data.atmosphere/NAMESPACE index 67d89a05458..753c1376d52 100644 --- a/modules/data.atmosphere/NAMESPACE +++ b/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) diff --git a/modules/data.atmosphere/R/extract.nc.R b/modules/data.atmosphere/R/extract.nc.R index b060d38ccd9..d3a513aaacc 100644 --- a/modules/data.atmosphere/R/extract.nc.R +++ b/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) diff --git a/modules/data.atmosphere/R/met.process.R b/modules/data.atmosphere/R/met.process.R index 841d7ffb407..a0cc5e4f98b 100644 --- a/modules/data.atmosphere/R/met.process.R +++ b/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"]] diff --git a/modules/data.atmosphere/R/met2CF.Ameriflux.R b/modules/data.atmosphere/R/met2CF.Ameriflux.R index 7f27f01dd46..320a144ca86 100644 --- a/modules/data.atmosphere/R/met2CF.Ameriflux.R +++ b/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)) diff --git a/modules/data.atmosphere/R/metgapfill.R b/modules/data.atmosphere/R/metgapfill.R index 8c493eabdf3..acc1492c682 100644 --- a/modules/data.atmosphere/R/metgapfill.R +++ b/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=", ")) } diff --git a/modules/data.atmosphere/R/read.register.R b/modules/data.atmosphere/R/read.register.R new file mode 100644 index 00000000000..415d4ff4275 --- /dev/null +++ b/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) +} diff --git a/utils/R/convert.input.R b/utils/R/convert.input.R index 5a2a5167671..0b9b5f1033b 100644 --- a/utils/R/convert.input.R +++ b/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,7 +76,7 @@ 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" } } @@ -85,7 +84,7 @@ convert.input <- function(input.id,outfolder,formatname,mimetype,site.id,start_d 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") }