Various minor updates (duplicate of broken #1149)

db/R/get.trait.data.R

@@ -52,8 +52,14 @@ check.lists <- function(x, y) {
 ##' @export
 ##'
 get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon,
-                               forceupdate = TRUE,
+                               forceupdate = FALSE,
                                trait.names = traitdictionary$id) {
+
+  # Create directory if necessary
+  if(!file.exists(pft$outdir) && !dir.create(pft$outdir, recursive=TRUE)) {
+    logger.error(paste0("Couldn't create PFT output directory: ", pft$outdir))
+  }
+
   ## Remove old files.  Clean up.
   old.files <- list.files(path=pft$outdir, full.names=TRUE, include.dirs=FALSE)
   file.remove(old.files)
@@ -250,8 +256,8 @@ get.trait.data <- function(pfts, modeltype, dbfiles, database, forceupdate,trait
 
   # process all pfts
   dbcon <- db.open(database)
+  on.exit(db.close(dbcon))
   result <- lapply(pfts, get.trait.data.pft, modeltype, dbfiles, dbcon, forceupdate, trait.names)
-  db.close(dbcon)
 
   invisible(result)
 }

db/R/priordupe.R

@@ -20,6 +20,8 @@ priordupe <- function(parent.pft.name = NULL,
 
   library(PEcAn.DB)
   con <- db.open(settings$database$bety)
+  on.exit(db.close(con))
+
   parent.pft.id <- db.query(paste("select id from pfts where name = ",
                                     parent.pft.name, ";"), con=con)
 
@@ -47,5 +49,4 @@ priordupe <- function(parent.pft.name = NULL,
                    new.pfts_priors$pft_id,
                    "specie_id = ",
                    new.pfts_priors$priors_id, ";"), con=con)
-  db.close(con)
 }

db/R/query.prior.R

@@ -26,6 +26,7 @@
 query.priors <- function(pft, trstr=NULL, out=NULL, con=NULL,...){
   if(is.null(con)){
     con <- db.open(settings$database$bety)
+    on.exit(db.close(con))
   }
   if(is.list(con)){
     print("query.priors")

db/R/query.trait.data.R

@@ -42,6 +42,7 @@ query.data <- function(trait, spstr, extra.columns='ST_X(ST_CENTROID(sites.geome
   if (is.null(con)) {
     logger.error("No open database connection passed in.")
     con <- db.open(settings$database$bety)
+    on.exit(db.close(con))
   }
   query <- paste("select
               traits.id, traits.citation_id, traits.site_id, traits.treatment_id,
@@ -64,7 +65,6 @@ query.data <- function(trait, spstr, extra.columns='ST_X(ST_CENTROID(sites.geome
   }
 
   return(result)
-  db.close(con)
 }
 ##==================================================================================================#
 

db/R/query.traits.R

@@ -29,6 +29,7 @@ query.traits <- function(spstr, priors, con = NULL, update.check.only=FALSE){
 
   if(is.null(con)){
     con <- db.open(settings$database$bety)
+    on.exit(db.close(con))
   }
   if(is.list(con)){
     print("query.traits")

db/R/utils.R

@@ -32,14 +32,13 @@
 ##' db.query('select count(id) from traits;', params=settings$database$bety)
 ##' }
 db.query <- function(query, con=NULL, params=NULL) {
-  iopened <- 0
   if(is.null(con)){
     if (is.null(params)) {
       logger.error("No parameters or connection specified")
       stop()
     }
     con <- db.open(params)
-    iopened <- 1
+    on.exit(db.close(con))
   }
   if (.db.utils$showquery) {
     logger.debug(query)
@@ -50,9 +49,6 @@ db.query <- function(query, con=NULL, params=NULL) {
     logger.severe(paste("Error executing db query '", query, "' errorcode=", res$errorNum, " message='", res$errorMsg, "'", sep=''))
   }
   .db.utils$queries <- .db.utils$queries+1
-  if(iopened==1) {
-    db.close(con)
-  }
   invisible(data)
 }
 
@@ -182,6 +178,8 @@ db.exists <- function(params, write=TRUE, table=NA) {
   })
   if (is.null(con)) {
     return(invisible(FALSE))
+  } else {
+    on.exit(db.close(con))
   }
 
   #check table's privilege about read and write permission
@@ -280,14 +278,6 @@ db.exists <- function(params, write=TRUE, table=NA) {
     result <- TRUE
   }
 
-
-  # close database, all done
-  tryCatch({
-    db.close(con)
-  }, error = function(e) {
-    logger.warn("Could not close database.\n\t", e)
-  })
-
   invisible(result)
 }
 

models/ed/data/pftmapping.csv

@@ -55,4 +55,7 @@ Optics.Temperate_Late_Conifer;8
 Optics.Temperate_Early_Hardwood;9
 Optics.Temperate_Mid_Hardwood;10
 Optics.Temperate_Late_Hardwood;11
-temperate.Early_Hardwood.RK;9
+temperate.Early_Hardwood.RK;9
+temperate.Western_Fir;8
+temperate.Western_Pine;6
+temperate.Western_Hardwood;10

models/linkages/R/write.config.LINKAGES.R

@@ -61,9 +61,9 @@ write.config.LINKAGES <- function(defaults = NULL, trait.values, settings, run.i
   texture <- read.csv(system.file("texture.csv", package = "PEcAn.LINKAGES"))
 
   dbcon <- db.open(settings$database$bety)
+  on.exit(db.close(dbcon))
   soils <- db.query(paste("SELECT soil,som,sand_pct,clay_pct,soilnotes FROM sites WHERE id =", settings$run$site$id), 
                     con = dbcon)
-  db.close(dbcon)
 
   sand <- as.numeric(soils[3]) / 100
   clay <- as.numeric(soils[4]) / 100

modules/assim.batch/R/pda.bayesian.tools.R

@@ -35,8 +35,10 @@ pda.bayesian.tools <- function(settings, params.id = NULL, param.names = NULL, p
   ## Open database connection
   if (settings$database$bety$write) {
     con <- try(db.open(settings$database$bety), silent = TRUE)
-    if (is.character(con)) {
+    if (is(con, "try-error")) {
       con <- NULL
+    } else {
+      on.exit(db.close(con))
     }
   } else {
     con <- NULL

modules/assim.batch/R/pda.emulator.R

@@ -46,8 +46,10 @@ pda.emulator <- function(settings, params.id = NULL, param.names = NULL, prior.i
   ## Open database connection
   if (settings$database$bety$write) {
     con <- try(db.open(settings$database$bety), silent = TRUE)
-    if (is.character(con)) {
+    if (is(con, "try-error")) {
       con <- NULL
+    } else {
+      on.exit(db.close(con))
     }
   } else {
     con <- NULL

modules/assim.batch/R/pda.mcmc.R

@@ -32,8 +32,10 @@ pda.mcmc <- function(settings, params.id = NULL, param.names = NULL, prior.id =
   ## Open database connection
   if (settings$database$bety$write) {
     con <- try(db.open(settings$database$bety), silent = TRUE)
-    if (is.character(con)) {
+    if (is(con, "try-error")) {
       con <- NULL
+    } else {
+      on.exit(db.close(con))
     }
   } else {
     con <- NULL

modules/assim.batch/R/pda.mcmc.bs.R

@@ -39,8 +39,10 @@ pda.mcmc.bs <- function(settings, params.id = NULL, param.names = NULL, prior.id
   ## Open database connection
   if (settings$database$bety$write) {
     con <- try(db.open(settings$database$bety), silent = TRUE)
-    if (is.character(con)) {
+    if (is(con, "try-error")) {
       con <- NULL
+    } else {
+      on.exit(db.close(con))
     }
   } else {
     con <- NULL

modules/assim.batch/R/pda.mcmc.recover.R

@@ -29,10 +29,12 @@ pda.mcmc.recover <- function(settings, params.id = NULL, param.names = NULL, pri
 
     ## Open database connection
     if (settings$database$bety$write) {
-        con <- try(db.open(settings$database$bety), silent = TRUE)
-        if (is.character(con)) {
-            con <- NULL
-        }
+      con <- try(db.open(settings$database$bety), silent = TRUE)
+      if (is(con, "try-error")) {
+          con <- NULL
+      } else {
+        on.exit(db.close(con))
+      }
     } else {
         con <- NULL
     }

modules/assim.sequential/R/sda.enkf.R

@@ -86,8 +86,10 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) {
   ###-------------------------------------------------------------------### 
   if (write) {
     con <- try(db.open(settings$database$bety), silent = TRUE)
-    if (is.character(con)) {
+    if (is(con, "try-error")) {
       con <- NULL
+    } else {
+      on.exit(db.close(con))
     }
   } else {
     con <- NULL

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

@@ -16,20 +16,21 @@
 ##'        `download`, `met2cf`, `standardize`, and `met2model`. If it is instead a simple boolean,
 ##'        the default behavior for `overwrite=FALSE` is to overwrite nothing, as you might expect.
 ##'        Note however that the default behavior for `overwrite=TRUE` is to overwrite everything
-##'        *except* raw met downloads (i.e., it corresponds to the same )
+##'        *except* raw met downloads. I.e., it corresponds to:
+##'
+##'        list(download = FALSE, met2cf = TRUE, standardize = TRUE,  met2model = TRUE)
 ##'
 ##' @author Elizabeth Cowdery, Michael Dietze, Ankur Desai, James Simkins, Ryan Kelly
 met.process <- function(site, input_met, start_date, end_date, model,
                         host = "localhost", dbparms, dir, browndog = NULL, 
-                        overwrite = list(download = FALSE, met2cf = FALSE, 
-                                         standardize = FALSE, met2model = FALSE)) {
+                        overwrite = FALSE) {
   library(RPostgreSQL)
 
   # If overwrite is a plain boolean, fill in defaults for each stage
   if (!is.list(overwrite)) {
     if (overwrite) {
       # Default for overwrite==TRUE is to overwrite everything but download
-      (overwrite <- overwrite) <- list(download = FALSE, met2cf = TRUE, standardize = TRUE,  met2model = TRUE)
+      overwrite <- list(download = FALSE, met2cf = TRUE, standardize = TRUE,  met2model = TRUE)
     } else {
       overwrite <- list(download = FALSE, met2cf = FALSE, standardize = FALSE, met2model = FALSE)
     }

modules/meta.analysis/R/run.meta.analysis.R

@@ -166,8 +166,9 @@ run.meta.analysis.pft <- function(pft, iterations, random = TRUE, threshold = 1.
 run.meta.analysis <- function(pfts, iterations, random = TRUE, threshold = 1.2, dbfiles, database) {
   # process all pfts
   dbcon <- db.open(database)
-  result <- lapply(pfts, PEcAn.MA:::run.meta.analysis.pft, iterations, random, threshold, dbfiles, dbcon)
-  db.close(dbcon)
+  on.exit(db.close(dbcon))
+
+  result <- lapply(pfts, run.meta.analysis.pft, iterations, random, threshold, dbfiles, dbcon)
 } # run.meta.analysis.R
 ## ==================================================================================================#
 

modules/priors/R/priors.R

@@ -187,7 +187,6 @@ pr.samp <- function(distn, parama, paramb, n) {
 ##' @seealso \link{pr.samp}
 ##' @export
 get.sample <- function(prior, n) {
-  print(paste("get.sample", prior$distn))
   if (as.character(prior$distn) %in% c("exp", "pois", "geom")) {
     ## one parameter distributions
     return(do.call(paste0("r", prior$distn), list(n, prior$parama)))

modules/uncertainty/NAMESPACE

@@ -5,7 +5,6 @@ export(flux.uncertainty)
 export(get.change)
 export(get.coef.var)
 export(get.elasticity)
-export(get.parameter.samples)
 export(get.sensitivity)
 export(plot_flux_uncertainty)
 export(plot_sensitivities)

settings/R/papply.R

@@ -75,8 +75,8 @@ papply <- function(settings, fn, stop.on.error = FALSE, ...) {
     }
 
     if (length(errors) > 0) {
-      PEcAn.utils::logger.warn(paste0("papply encountered the following errors, ", "but continued since stop.on.error=FALSE. ", 
-                                      paste(errors, collapse = "; ")))
+      PEcAn.utils::logger.warn(paste0("papply encountered errors for ", length(errors), " elements, ", 
+        "but continued since stop.on.error=FALSE. ", paste(errors, collapse = "; ")))
     }
 
     return(invisible(result))

settings/R/read.settings.R

@@ -6,6 +6,7 @@
 ## which accompanies this distribution, and is available at
 ## http://opensource.ncsa.illinois.edu/license.html
 ##-------------------------------------------------------------------------------
+
 ##' Loads PEcAn settings file
 ##' 
 ##' This will try and find the PEcAn settings file in the following order:

utils/.Rbuildignore

@@ -0,0 +1,2 @@
+^.*\.Rproj$
+^\.Rproj\.user$

utils/NAMESPACE

@@ -22,6 +22,7 @@ export(fqdn)
 export(full.path)
 export(get.ensemble.samples)
 export(get.model.output)
+export(get.parameter.samples)
 export(get.parameter.stat)
 export(get.quantiles)
 export(get.results)

utils/R/do.conversions.R

@@ -3,7 +3,8 @@
 ##' @title do.conversions
 ##' @description Input conversion workflow
 ##' @author Ryan Kelly, Rob Kooper, Betsy Cowdery
-do.conversions <- function(settings) {
+##' @export
+do.conversions <- function(settings, overwrite.met = FALSE, overwrite.fia = FALSE) {
   if (is.MultiSettings(settings)) {
     return(papply(settings, do.conversions))
   }
@@ -21,29 +22,29 @@ do.conversions <- function(settings) {
     input.tag <- names(settings$run$input)[i]
 
     # fia database
-    if ((input["input"] == "fia") && (status.check("FIA2ED") == 0)) {
-      status.start("FIA2ED")
-      fia.to.psscss(settings)
-      status.end()
+    if ((input.tag %in% c("css", "pss", "site")) &&
+        is.null(input$path) && !is.null(input$source) && (input$source == "FIA")) {
+      settings <- fia.to.psscss(settings, overwrite=overwrite.fia)
       needsave <- TRUE
     }
 
     # met conversion
     if (input.tag == "met") {
       name <- ifelse(is.null(settings$browndog), "MET Process", "BrownDog")
       if (is.null(input$path) && (status.check(name) == 0)) {
-        status.start(name)
-        result <- PEcAn.data.atmosphere::met.process(site = settings$run$site, 
-                                                     input_met = settings$run$inputs$met, 
-                                                     start_date = settings$run$start.date, 
-                                                     end_date = settings$run$end.date, 
-                                                     model = settings$model$type, 
-                                                     host = settings$host, 
-                                                     dbparms = settings$database$bety,
-                                                     dir = settings$database$dbfiles, 
-                                                     browndog = settings$browndog)
-        settings$run$inputs[[i]][["path"]] <- result
-        status.end()
+        settings$run$inputs[[i]][['path']] <- 
+          PEcAn.data.atmosphere::met.process(
+            site       = settings$run$site, 
+            input_met  = settings$run$inputs$met,
+            start_date = settings$run$start.date,
+            end_date   = settings$run$end.date,
+            model      = settings$model$type,
+            host       = settings$host,
+            dbparms    = settings$database$bety, 
+            dir        = settings$host$dbfiles,
+            browndog   = settings$browndog,
+            overwrite  = overwrite.met)
+
         needsave <- TRUE
       }
     }
@@ -54,4 +55,4 @@ do.conversions <- function(settings) {
     settings <- read.settings(file.path(settings$outdir, "pecan.METProcess.xml"))
   }
   return(settings)
-} # do.conversions
+}