From fb934ed98e65ec70ab07bd2cae694ef6c14cbde9 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Thu, 6 Apr 2017 19:39:55 -0400 Subject: [PATCH 001/771] tree ring: X * time-varying interaction term (untested) --- modules/data.land/R/InventoryGrowthFusion.R | 25 ++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index b7e1032062a..c1a75358530 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -118,7 +118,7 @@ model{ if(FALSE){ ## DEV TESTING FOR X, polynomial X, and X interactions - fixed <- "X + X^3 + X*bob + bob + dia" + fixed <- "X + X^3 + X*bob + bob + dia + X*Tmin[t]" } ## Design matrix if (is.null(fixed)) { @@ -157,12 +157,27 @@ model{ covX <- strsplit(X.terms[i],"*",fixed=TRUE)[[1]] covX <- covX[-which(toupper(covX)=="X")] ## remove X from terms if(covX %in% colnames(cov.data)){ ## covariate present - if(!(covX %in% names(data))){ - ## add cov variables to data object - data[[covX]] <- cov.data[,covX] - } + + ##is covariate fixed or time varying? + tvar <- grep("[t]",covX,fixed=TRUE) + if(tvar){ + covX <- sub("[t]","",covX,fixed = TRUE) + if(!(covX %in% names(data))){ + ## add cov variables to data object + data[[covX]] <- time_varying[[covX]] + } + covX <- paste0(covX,"[i,t]") + } else { + ## variable is fixed + if(!(covX %in% names(data))){ + ## add cov variables to data object + data[[covX]] <- cov.data[,covX] + } + } ## end fixed or time varying + myBeta <- paste0("betaX_",covX) Xformula <- paste0(myBeta,"*x[i,t-1]*",covX,"[i]") + } else { ## covariate absent print("covariate absent from covariate data:", covX) From 23743cc2f0ed3df2b1a60a7be7fa21a8f7061d6d Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Thu, 6 Apr 2017 19:58:29 -0400 Subject: [PATCH 002/771] tree ring: bug fix in variable checking on X*fixed. Start of timevar * fixed --- modules/data.land/R/InventoryGrowthFusion.R | 50 ++++++++++++++++----- 1 file changed, 40 insertions(+), 10 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index c1a75358530..22ee5a8dc5b 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -156,7 +156,6 @@ model{ covX <- strsplit(X.terms[i],"*",fixed=TRUE)[[1]] covX <- covX[-which(toupper(covX)=="X")] ## remove X from terms - if(covX %in% colnames(cov.data)){ ## covariate present ##is covariate fixed or time varying? tvar <- grep("[t]",covX,fixed=TRUE) @@ -169,20 +168,21 @@ model{ covX <- paste0(covX,"[i,t]") } else { ## variable is fixed - if(!(covX %in% names(data))){ - ## add cov variables to data object - data[[covX]] <- cov.data[,covX] + if(covX %in% colnames(cov.data)){ ## covariate present + if(!(covX %in% names(data))){ + ## add cov variables to data object + data[[covX]] <- cov.data[,covX] + } + } else { + ## covariate absent + print("covariate absent from covariate data:", covX) } + } ## end fixed or time varying myBeta <- paste0("betaX_",covX) Xformula <- paste0(myBeta,"*x[i,t-1]*",covX,"[i]") - } else { - ## covariate absent - print("covariate absent from covariate data:", covX) - } - } else if(length(grep("^",X.terms[i],fixed=TRUE))==1){ ## POLYNOMIAL powX <- strsplit(X.terms[i],"^",fixed=TRUE)[[1]] powX <- powX[-which(toupper(powX)=="X")] ## remove X from terms @@ -254,11 +254,41 @@ model{ ## parse equation into variable names t_vars <- gsub(" ","",unlist(strsplit(time_varying,"+",fixed=TRUE))) ## split on +, remove whitespace ## check for interaction terms - it_vars <- grep(pattern = "*",x=t_vars,fixed = TRUE) + it_vars <- t_vars[grep(pattern = "*",x=t_vars,fixed = TRUE)] + t_vars <- t_vars[!(tvars == it_vars)] + ## need to deal with interactions with fixed variables ## will get really nasty if interactions are with catagorical variables ## need to create new data matrices on the fly + for(i in seq_along(it_vars)){ + + ##is covariate fixed or time varying? + covX <- strsplit(it_vars[i],"*",fixed=TRUE)[[1]] + tvar1 <- grep("[t]",covX[1],fixed=TRUE) + tvar2 <- grep("[t]",covX[2],fixed=TRUE) + + if(tvar){ + covX <- sub("[t]","",covX,fixed = TRUE) + if(!(covX %in% names(data))){ + ## add cov variables to data object + data[[covX]] <- time_varying[[covX]] + } + covX <- paste0(covX,"[i,t]") + } else { + ## variable is fixed + if(!(covX %in% names(data))){ + ## add cov variables to data object + data[[covX]] <- cov.data[,covX] + } + } ## end fixed or time varying + + myBeta <- paste0("betaX_",covX) + Xformula <- paste0(myBeta,"*x[i,t-1]*",covX,"[i]") + + } + + ## loop over variables for(j in seq_along(t_vars)){ tvar <- t_vars[j] From 4491fdb2e63ba8b796e7e07f7b3bb9fd906f3cd9 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Thu, 6 Apr 2017 20:00:23 -0400 Subject: [PATCH 003/771] tree ring: X*time-var -> change tvar to logical --- modules/data.land/R/InventoryGrowthFusion.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index 22ee5a8dc5b..7c01b7505c8 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -158,7 +158,7 @@ model{ covX <- covX[-which(toupper(covX)=="X")] ## remove X from terms ##is covariate fixed or time varying? - tvar <- grep("[t]",covX,fixed=TRUE) + tvar <- length(grep("[t]",covX,fixed=TRUE)) > 0 if(tvar){ covX <- sub("[t]","",covX,fixed = TRUE) if(!(covX %in% names(data))){ From d85747c471c88ef5ee8b671302484d557b2e5331 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Thu, 6 Apr 2017 20:15:35 -0400 Subject: [PATCH 004/771] tree-rings: refined time_var interaction terms --- modules/data.land/R/InventoryGrowthFusion.R | 44 ++++++++++++++------- 1 file changed, 29 insertions(+), 15 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index 7c01b7505c8..2bc304f18ff 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -250,6 +250,7 @@ model{ if (is.null(time_data)) { print("time_varying formula provided but time_data is absent:", time_varying) } + Xt.priors <- "" ## parse equation into variable names t_vars <- gsub(" ","",unlist(strsplit(time_varying,"+",fixed=TRUE))) ## split on +, remove whitespace @@ -265,28 +266,39 @@ model{ ##is covariate fixed or time varying? covX <- strsplit(it_vars[i],"*",fixed=TRUE)[[1]] - tvar1 <- grep("[t]",covX[1],fixed=TRUE) - tvar2 <- grep("[t]",covX[2],fixed=TRUE) - - if(tvar){ - covX <- sub("[t]","",covX,fixed = TRUE) - if(!(covX %in% names(data))){ + tvar <- length(grep("[t]",covX[1],fixed=TRUE)) > 0 + tvar[2] <- length(grep("[t]",covX[2],fixed=TRUE)) > 0 + myBeta <- "beta_" + for(j in 1:2){ + if(j == 2) myBeta <- paste0(myBeta,"_") + if(tvar[j]){ + covX[j] <- sub("[t]","",covX[j],fixed = TRUE) + if(!(covX[j] %in% names(data))){ ## add cov variables to data object - data[[covX]] <- time_varying[[covX]] + data[[covX[j]]] <- time_varying[[covX[j]]] } - covX <- paste0(covX,"[i,t]") + myBeta <- paste0(myBeta,covX[j]) + covX[j] <- paste0(covX[j],"[i,t]") } else { ## variable is fixed - if(!(covX %in% names(data))){ + if(!(covX[j] %in% names(data))){ ## add cov variables to data object - data[[covX]] <- cov.data[,covX] + data[[covX[j]]] <- cov.data[,covX[j]] } + myBeta <- paste0(myBeta,covX[j]) + covX[j] <- paste0(covX[j],"[i]") } ## end fixed or time varying - myBeta <- paste0("betaX_",covX) - Xformula <- paste0(myBeta,"*x[i,t-1]*",covX,"[i]") - - } + } ## end building beta + + ## append to process model formula + Pformula <- paste(Pformula, + paste0(myBeta,"*",covX[1],"*",covX[2])) + + ## priors + Xt.priors <- paste0(Xt.priors, + " ",myBeta,"~dnorm(0,0.001)\n") + } ## end time-varying interaction terms ## loop over variables @@ -308,7 +320,9 @@ model{ out.variables <- c(out.variables, paste0("beta", tvar)) } ## build prior - Xt.priors <- paste0(" beta", t_vars, "~dnorm(0,0.001)", collapse = "\n") + Xt.priors <- paste0(Xt.priors, + paste0(" beta", t_vars, "~dnorm(0,0.001)", collapse = "\n") + ) TreeDataFusionMV <- sub(pattern = "## TIME VARYING BETAS", Xt.priors, TreeDataFusionMV) } ## END time varying covariates From de66d879701973701f699535cb620154b92c1b17 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Fri, 14 Apr 2017 10:42:22 -0400 Subject: [PATCH 005/771] Debugging tree-ring time-varying interaction terms --- modules/data.land/R/InventoryGrowthFusion.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index 2bc304f18ff..1926d745780 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -114,7 +114,7 @@ model{ ## Substitute into code TreeDataFusionMV <- sub(pattern = "## RANDOM EFFECT TAUS", Rpriors, TreeDataFusionMV) TreeDataFusionMV <- gsub(pattern = "## RANDOM_EFFECTS", Reffects, TreeDataFusionMV) - } + } ### END RANDOM EFFECTS if(FALSE){ ## DEV TESTING FOR X, polynomial X, and X interactions @@ -163,7 +163,7 @@ model{ covX <- sub("[t]","",covX,fixed = TRUE) if(!(covX %in% names(data))){ ## add cov variables to data object - data[[covX]] <- time_varying[[covX]] + data[[covX]] <- time_data[[covX]] } covX <- paste0(covX,"[i,t]") } else { @@ -203,7 +203,7 @@ model{ ## add to out.variables out.variables <- c(out.variables, myBeta) - } + } ## END LOOP OVER X TERMS ## create priors TreeDataFusionMV <- sub(pattern = "## ENDOGENOUS BETAS", Xpriors, TreeDataFusionMV) @@ -219,7 +219,7 @@ model{ ##Center the covariate data Xf.center <- apply(Xf, 2, mean, na.rm = TRUE) Xf <- t(t(Xf) - Xf.center) - } + } ## end fixed effects parsing ## build formula in JAGS syntax if (!is.null(Xf)) { @@ -256,7 +256,7 @@ model{ t_vars <- gsub(" ","",unlist(strsplit(time_varying,"+",fixed=TRUE))) ## split on +, remove whitespace ## check for interaction terms it_vars <- t_vars[grep(pattern = "*",x=t_vars,fixed = TRUE)] - t_vars <- t_vars[!(tvars == it_vars)] + t_vars <- t_vars[!(t_vars == it_vars)] ## need to deal with interactions with fixed variables ## will get really nasty if interactions are with catagorical variables @@ -293,7 +293,7 @@ model{ ## append to process model formula Pformula <- paste(Pformula, - paste0(myBeta,"*",covX[1],"*",covX[2])) + paste0(" + ",myBeta,"*",covX[1],"*",covX[2])) ## priors Xt.priors <- paste0(Xt.priors, From 48b62e14478d0af92dee19d7ca2afcd25f8662c6 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Fri, 14 Apr 2017 12:32:39 -0400 Subject: [PATCH 006/771] tree rings: addition debugging of time varying interactions --- modules/data.land/R/InventoryGrowthFusion.R | 24 ++++++++++++++------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index 1926d745780..3b45d88f41f 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -92,6 +92,8 @@ model{ data[[length(data)+1]] <- as.numeric(as.factor(as.character(cov.data[,r_var[j]]))) ## multiple conversions to eliminate gaps names(data)[length(data)] <- r_var[j] } + if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at r_var",names(data))} + nr[j] <- max(as.numeric(data[[r_var[j]]])) } index <- paste0("[",index,"]") @@ -154,6 +156,7 @@ model{ Xformula <- NULL if(length(grep("*",X.terms[i],fixed = TRUE)) == 1){ ## INTERACTION + myIndex <- "[i]" covX <- strsplit(X.terms[i],"*",fixed=TRUE)[[1]] covX <- covX[-which(toupper(covX)=="X")] ## remove X from terms @@ -165,7 +168,10 @@ model{ ## add cov variables to data object data[[covX]] <- time_data[[covX]] } - covX <- paste0(covX,"[i,t]") + if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at covX",names(data))} + +# covX <- paste0(covX,"[i,t-1]") + myIndex <- "[i,t-1]" } else { ## variable is fixed if(covX %in% colnames(cov.data)){ ## covariate present @@ -173,6 +179,7 @@ model{ ## add cov variables to data object data[[covX]] <- cov.data[,covX] } + if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at covX2",names(data))} } else { ## covariate absent print("covariate absent from covariate data:", covX) @@ -181,7 +188,7 @@ model{ } ## end fixed or time varying myBeta <- paste0("betaX_",covX) - Xformula <- paste0(myBeta,"*x[i,t-1]*",covX,"[i]") + Xformula <- paste0(myBeta,"*x[i,t-1]*",covX,myIndex) } else if(length(grep("^",X.terms[i],fixed=TRUE))==1){ ## POLYNOMIAL powX <- strsplit(X.terms[i],"^",fixed=TRUE)[[1]] @@ -239,6 +246,8 @@ model{ out.variables <- c(out.variables, paste0("beta", Xf.names)) } + if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at Xf",names(data))} + if(FALSE){ ## DEVEL TESTING FOR TIME VARYING time_varying <- "TminJuly + PrecipDec + TminJuly*PrecipDec" @@ -305,13 +314,12 @@ model{ for(j in seq_along(t_vars)){ tvar <- t_vars[j] - ## grab from the list of data matrices - dtmp <- time_data[[tvar]] + if(!(tvar %in% names(data))){ + ## add cov variables to data object + data[[tvar]] <- time_data[[tvar]] + } + if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at tvar",names(data))} - ## insert data into JAGS inputs - data[[length(data)+1]] <- dtmp - names(data)[length(data)] <- tvar - ## append to process model formula Pformula <- paste(Pformula, paste0("+ beta", tvar, "*",tvar,"[i,t]")) From 90179755cd5cd581828820f08f744d4105a9a1f1 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Fri, 14 Apr 2017 19:57:38 -0400 Subject: [PATCH 007/771] tree-ring: add time-var interaction to output tracking variables --- modules/data.land/R/InventoryGrowthFusion.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index 3b45d88f41f..37f7d6ed5b3 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -307,6 +307,10 @@ model{ ## priors Xt.priors <- paste0(Xt.priors, " ",myBeta,"~dnorm(0,0.001)\n") + + ## add to list of varibles JAGS is tracking + out.variables <- c(out.variables, myBeta) + } ## end time-varying interaction terms From e0e763f6d65d84665d96eaee3aeb2be959f8d9ec Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Thu, 20 Apr 2017 17:42:40 -0400 Subject: [PATCH 008/771] Sitegroup to MultiSettings: bugfix to query of id vs site_id --- settings/R/createMultisiteMultiSettings.r | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/settings/R/createMultisiteMultiSettings.r b/settings/R/createMultisiteMultiSettings.r index 28f13baf81e..ea4dea2ed91 100644 --- a/settings/R/createMultisiteMultiSettings.r +++ b/settings/R/createMultisiteMultiSettings.r @@ -25,13 +25,13 @@ #' #' @example examples/examples.MultiSite.MultiSettings.r createSitegroupMultiSettings = function(templateSettings, sitegroupId, nSite, con=NULL, params=templateSettings$database$bety) { - query <- paste("SELECT id FROM sitegroups_sites WHERE sitegroup_id =", sitegroupId) + query <- paste("SELECT site_id FROM sitegroups_sites WHERE sitegroup_id =", sitegroupId) allSites <- PEcAn.DB::db.query(query, con=con, params=params) if(missing(nSite)) - siteIds <- allSites$id + siteIds <- allSites$site_id else - siteIds <- sample(allSites$id, nSite, replace=FALSE) + siteIds <- sample(allSites$site_id, nSite, replace=FALSE) settings <- createMultiSiteSettings(templateSettings, siteIds) } From 69cbb61a1901f0ea4cc43160539e07e78a63b4b3 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sun, 21 May 2017 13:02:52 -0500 Subject: [PATCH 009/771] Experimenting with ggplotly for interactiveness --- shiny/workflowPlot/helper.R | 14 +++++++++++++ shiny/workflowPlot/server.R | 40 +++++++++++++++++++++++++++---------- shiny/workflowPlot/ui.R | 13 ++++++++---- 3 files changed, 52 insertions(+), 15 deletions(-) create mode 100644 shiny/workflowPlot/helper.R diff --git a/shiny/workflowPlot/helper.R b/shiny/workflowPlot/helper.R new file mode 100644 index 00000000000..a014b844a8a --- /dev/null +++ b/shiny/workflowPlot/helper.R @@ -0,0 +1,14 @@ +checkAndDownload<-function(packageNames) { + for(packageName in packageNames) { + if(!isInstalled(packageName)) { + install.packages(packageName,repos="http://lib.stat.cmu.edu/R/CRAN") + } + library(packageName,character.only=TRUE,quietly=TRUE,verbose=FALSE) + } +} +isInstalled <- function(mypkg){ + is.element(mypkg, installed.packages()[,1]) +} + +checkAndDownload(c('plotly','scales')) +# testVal = 5 \ No newline at end of file diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 1f4d31e2117..11ee7c1f271 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -3,8 +3,9 @@ library(PEcAn.DB) library(shiny) library(ncdf4) library(ggplot2) - - +source('helper.R') +require(plotly) +library(scales) # Define server logic server <- shinyServer(function(input, output, session) { bety <- betyConnect() @@ -30,6 +31,9 @@ server <- shinyServer(function(input, output, session) { var_names <- reactive({ run_ids <- get_run_ids(bety, workflow_id()) var_names <- get_var_names(bety, workflow_id(), run_ids[1]) + # Removing the variables "Year" and "FracJulianDay" from the Variable Name input in the app + removeVarNames = c('Year','FracJulianDay') + var_names <-var_names[!var_names %in% removeVarNames] return(var_names) }) observe({ @@ -52,8 +56,14 @@ server <- shinyServer(function(input, output, session) { ranges$y <- NULL } }) - - output$outputPlot <- renderPlot({ + # If want to render text + output$info <- renderText({ + paste0(input$variable_name) + # paste0(testVal) + # paste0("x=", input$plot_dblclick$x, "\ny=", input$plot_dblclick$y) + }) + + output$outputPlot <- renderPlotly({ workflow_id <- isolate(input$workflow_id) run_id <- isolate(input$run_id) var_name <- input$variable_name @@ -83,16 +93,24 @@ server <- shinyServer(function(input, output, session) { xlab <- if (is.null(ranges$x)) "Time" else paste(ranges$x, collapse=" - ") # plot result print(ranges$x) - plt <- ggplot(data.frame(dates, vals), aes(x=dates, y=vals)) + - geom_point(aes(color="Model output")) + + dates = as.Date(dates) + df = data.frame(dates, vals) + # df$dates = as.factor(df$dates) + + plt <- ggplot(df, aes(x=dates, y=vals)) + + # geom_point(aes(color="Model output")) + + geom_point() + # geom_smooth(aes(fill = "Spline fit")) + - coord_cartesian(xlim = ranges$x, ylim = ranges$y) + - scale_y_continuous(labels=fancy_scientific) + + # coord_cartesian(xlim = ranges$x, ylim = ranges$y) + + # scale_y_continuous(labels=fancy_scientific) + labs(title=title, x=xlab, y=ylab) + scale_color_manual(name = "", values = "black") + - scale_fill_manual(name = "", values = "grey50") - plot(plt) - add_icon() + scale_fill_manual(name = "", values = "grey50") + # theme(axis.text.x = element_text(angle = -90)) + + plt<-ggplotly(plt) + # plot(plt) + # add_icon() } } }) diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 5f7c5962ec7..8b54949a691 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -1,4 +1,5 @@ library(shiny) +source('helper.R') # Define UI ui <- shinyUI(fluidPage( @@ -12,10 +13,14 @@ ui <- shinyUI(fluidPage( selectInput("variable_name", "Variable Name", "") ), mainPanel( - plotOutput("outputPlot", - brush = brushOpts(id = "plot_brush", - resetOnNew = TRUE), - dblclick = "plot_dblclick") + plotlyOutput("outputPlot" + ## brushOpts and dblclick not supported by plotly + # brush = brushOpts(id = "plot_brush", + # resetOnNew = TRUE), + # dblclick = "plot_dblclick" + ) + # Checking variable names + ,verbatimTextOutput("info") ) ) )) From 716735b4bb8705fa0b59f03233d7ca954875568d Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Thu, 25 May 2017 19:30:03 +0530 Subject: [PATCH 010/771] Added the Dockerfile to generate the Containers new file: Dockerfile --- Dockerfile | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 Dockerfile diff --git a/Dockerfile b/Dockerfile new file mode 100644 index 00000000000..a61c62a9bd4 --- /dev/null +++ b/Dockerfile @@ -0,0 +1,40 @@ +FROM ubuntu:16.04 +MAINTAINER amanskywalker (ak47su30ac@gmail.com) + +# expose port 80 for the web interface +EXPOSE 80 + +# expose port 22 for ssh maintance +EXPOSE 22 + +# updated ppa's +RUN echo "deb http://cran.rstudio.com/bin/linux/ubuntu xenial/" > /etc/apt/sources.list.d/R.list &&\ + apt-key adv --keyserver keyserver.ubuntu.com --recv-keys E084DAB9 + +# copy the installation script inside the container +ADD docker/ /build + +# Run the OS System setup script +RUN chmod 750 /build/system_services.sh +RUN /build/system_services.sh + +# Set script mod +x for preprocessors +RUN chmod 750 /build/* + +# run update machine to update machine +RUN /build/update_machine.sh + +# run inatall packages to install required packages +RUN /build/install_packages.sh + +# run install R to install R packages +RUN /build/install_R.sh + +# run install pecan to install pecan cores +RUN /build/install_pecan.sh + +# Clean up APT when done. +RUN apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* + +# startup +CMD ["/sbin/my_init"] From 4c4fbf777968fb49d1ddc2dbf418fb92f21e480d Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Thu, 25 May 2017 19:30:50 +0530 Subject: [PATCH 011/771] Added the Dockerfile supporting Scripts to install PEcAn and needed packages --- docker/bin/my_init | 189 +++++++++++++++++++++++++++ docker/config/cron_log_config | 5 + docker/install_R.sh | 32 +++++ docker/install_packages.sh | 86 ++++++++++++ docker/install_pecan.sh | 38 ++++++ docker/install_pecan_preprocessor.sh | 36 +++++ docker/runit/cron | 3 + docker/runit/cron_log | 3 + docker/system_services.sh | 90 +++++++++++++ docker/update_machine.sh | 30 +++++ 10 files changed, 512 insertions(+) create mode 100644 docker/bin/my_init create mode 100644 docker/config/cron_log_config create mode 100644 docker/install_R.sh create mode 100644 docker/install_packages.sh create mode 100644 docker/install_pecan.sh create mode 100644 docker/install_pecan_preprocessor.sh create mode 100644 docker/runit/cron create mode 100644 docker/runit/cron_log create mode 100644 docker/system_services.sh create mode 100644 docker/update_machine.sh diff --git a/docker/bin/my_init b/docker/bin/my_init new file mode 100644 index 00000000000..af87c28c78b --- /dev/null +++ b/docker/bin/my_init @@ -0,0 +1,189 @@ +#! /bin/bash +export LC_ALL=C TERM="xterm" + +trap 'shutdown_runit_services' INT TERM + +# variables +env > /etc/envvars +temp_var=$@ +FILES=/etc/container_environment/* +runsvdir_PID= + +# functions + +# importing the environment variables from image +import_envvars () { + + clear_existing_environment=${1:-true} + override_existing_environment=${2:-true} + + for file in $FILES + do + FILE=`basename $file` + if [ $override_existing_environment = true ] || !( env | grep -q $FILE) + then + export eval $FILE=`cat $file` + fi + done +} + +# exporting the environment variables to the image +export_envvars () { + to_dir=${1:-true} + no_record="HOME USER GROUP UID GID SHELL SHLVL PWD" + # to begin .json and.sh files + echo -n "{" > /etc/container_environment.json + echo -n "" > /etc/container_environment.sh + # saving variables into file. individual file by variable. + env | while read -r line + do + a=`expr index "$line" \=` + b=$((a-1)) + file_name=${line:0:$b} + file_val=${line:$a} + if echo "$no_record" | grep -q "$file_name" + then + continue + else + # write to files + if [ $to_dir = true ] ; then echo $file_val > /etc/container_environment/$file_name ; fi + # write to .sh file + echo "export" $file_name"='"$file_val"'" >> /etc/container_environment.sh + # write to .json file + echo -n "\""$file_name"\":\""$file_val"\"," >> /etc/container_environment.json + fi + done + # adding } to closed the .json file + echo -e "\b}" >> /etc/container_environment.json +} + +# function to run the command +run_command () { + if [ -x $1 ]; then + echo >&2 "*** Running: $1" + $1 + retval=$? + if [ $retval != 0 ]; + then + echo >&2 "*** Failed with return value: $retval" + exit $retval + else + import_envvars + export_envvars false + fi + fi +} + +# function to run the startup scripts +run_startup_files() { + # running /etc/my_init.d/ + echo "Starting pre-service scritps in /etc/my_init.d" + for script in /etc/my_init.d/* + do + run_command $script + done + + echo "starting rc.local scritps" + run_command /etc/rc.local +} + + +# function to start corn jobs +start_runit () { + echo "Booting runit daemon..." + /usr/bin/runsvdir -P /etc/service 'log:.........................................................................................................' & + runsvdir_PID=$! + echo "Process runsvdir running with PID $runsvdir_PID" +} + +# function to shutdown corn jobs +shutdown_runit_services() { + # need to check if runit service is runnung before shutdown .. + echo "Begin shutting down runit services..." + /usr/bin/sv down /etc/service/* + # need to give some time and check if service is down if time greater than allow them force exit + count=1 + while [ $(/usr/bin/sv status /etc/service/* | grep -c "^run:") != 0 ] + do + sleep 1 + count=`expr $count + 1` + if [ $count -gt 10 ]; then break ; fi + done + exit 0 +} + +# message to echo things to user +message () { + echo "usage: my_init [-h|--help] [--skip-startup-files] [--skip-runit] [-- MAIN_COMMAND ]" + echo "optional arguments:" + echo " -h, --help show this help message and exit" + echo " --skip-startup-files Skip running /etc/my_init.d/* and /etc/rc.local" + echo " --skip-runit Do not run runit services" + echo " --quiet Only print warnings and errors" +} + +# import & export env +import_envvars false false +export_envvars + + +# condition for --help +if [ `echo $temp_var | grep -c "\-\-help" ` -gt 0 ] || [ `echo $temp_var | grep -c "\-h" ` -gt 0 ] ; then + message + exit 0 +fi + +# condition for --quiet +if ! [ `echo $temp_var | grep -c "\-\-quiet" ` -gt 0 ] ; then + : + else + temp_var=$(echo $temp_var|sed "s/--quiet//") + echo "--quiet still need to be implememted" +fi + +# condition for --skip-startup-files +if ! [ `echo $temp_var | grep -c "\-\-skip-startup-files" ` -gt 0 ] ; then + run_startup_files + else + temp_var=$(echo $temp_var|sed "s/--skip-startup-files//") +fi + +# condition for --skip-runit +if ! [ `echo $temp_var | grep -c "\-\-skip-runit" ` -gt 0 ] ; then + start_runit + else + temp_var=$(echo $temp_var|sed "s/--skip-runit//") + if [ `echo $temp_var | grep -c "\-\- " ` -gt 0 ] ; then + temp_var=$(echo $temp_var|sed "s/--//") + exec $temp_var + exit 0 + else + echo "Need to add command to do something: -- command" + echo + message + exit 0 + fi +fi + +if [ `echo $temp_var | grep -c "\-\- " ` -gt 0 ] ; then +temp_var=$(echo $temp_var|sed "s/--//") + if ! [ "$temp_var" = "" ] ; then + # need to check if all service are online before executing command + count=1 + while [ $(/sbin/sv status /etc/service/* | grep -c "^down:") != 0 ] + do + sleep 1 + count=`expr $count + 1` + if [ $count -gt 10 ]; then break ; fi + done + exec $temp_var + shutdown_runit_services + else + echo "Need to add command to do something: -- command " + echo + message + shutdown_runit_services + fi +fi + +wait diff --git a/docker/config/cron_log_config b/docker/config/cron_log_config new file mode 100644 index 00000000000..786ed9b34ce --- /dev/null +++ b/docker/config/cron_log_config @@ -0,0 +1,5 @@ +s100000 +n5 +N3 +t86400 +!logwatcher diff --git a/docker/install_R.sh b/docker/install_R.sh new file mode 100644 index 00000000000..1abf6c760c3 --- /dev/null +++ b/docker/install_R.sh @@ -0,0 +1,32 @@ +#!/bin/bash + +. /build/install_pecan_preprocessor.sh + +echo "######################################################################" +echo "R" +echo "######################################################################" +if [ -z "${R_LIBS_USER}" ]; then + echo 'export R_LIBS_USER=${HOME}/R/library' >> ${HOME}/.bashrc + echo 'R_LIBS_USER=${HOME}/R/library' >> ${HOME}/.Renviron + export export R_LIBS_USER=${HOME}/R/library + mkdir -p ${R_LIBS_USER} + + case "$OS_VERSION" in + RH_*) + echo 'export PATH=${PATH}:/usr/pgsql-9.5/bin' >> ${HOME}/.bashrc + export PATH=${PATH}:/usr/pgsql-9.5/bin + ;; + esac +fi +echo 'if(!"devtools" %in% installed.packages()) install.packages("devtools", repos="http://cran.rstudio.com/")' | R --vanilla +echo 'if(!"udunits2" %in% installed.packages()) install.packages("udunits2", configure.args=c(udunits2="--with-udunits2-include=/usr/include/udunits2"), repo="http://cran.rstudio.com")' | R --vanilla + +# packages for BrownDog shiny app +echo 'if(!"leaflet" %in% installed.packages()) install.packages("leaflet", repos="http://cran.rstudio.com/")' | R --vanilla +echo 'if(!"RJSONIO" %in% installed.packages()) install.packages("RJSONIO", repos="http://cran.rstudio.com/")' | R --vanilla + +#echo 'update.packages(repos="http://cran.rstudio.com/", ask=FALSE)' | R --vanilla +echo 'x <- rownames(old.packages(repos="http://cran.rstudio.com/")); update.packages(repos="http://cran.rstudio.com/", ask=FALSE, oldPkgs=x[!x %in% "rgl"])' | R --vanilla + +#echo 'update.packages(repos="http://cran.rstudio.com/", ask=FALSE)' | R --vanilla +echo 'x <- rownames(old.packages(repos="http://cran.rstudio.com/")); update.packages(repos="http://cran.rstudio.com/", ask=FALSE, oldPkgs=x[!x %in% "rgl"])' | R --vanilla diff --git a/docker/install_packages.sh b/docker/install_packages.sh new file mode 100644 index 00000000000..a89e4110e02 --- /dev/null +++ b/docker/install_packages.sh @@ -0,0 +1,86 @@ +#!/bin/bash + +. /build/install_pecan_preprocessor.sh + +echo "######################################################################" +echo "SETTING UP REPOS" +echo "######################################################################" +case "$OS_VERSION" in + RH_5) + yum install -y wget + wget -O /etc/yum.repos.d/cornell.repo http://download.opensuse.org/repositories/home:cornell_vrdc/CentOS_CentOS-6/home:cornell_vrdc.repo + rpm -Uvh http://download.fedoraproject.org/pub/epel/5/x86_64/epel-release-5-4.noarch.rpm + ;; + RH_6) + yum install -y wget + wget -O /etc/yum.repos.d/cornell.repo http://download.opensuse.org/repositories/home:cornell_vrdc/CentOS_CentOS-6/home:cornell_vrdc.repo + yum -y localinstall https://download.postgresql.org/pub/repos/yum/9.5/redhat/rhel-6-x86_64/pgdg-centos95-9.5-2.noarch.rpm + rpm -Uvh http://download.fedoraproject.org/pub/epel/6/x86_64/epel-release-6-8.noarch.rpm + ;; + RH_7) + yum install -y wget + wget -O /etc/yum.repos.d/cornell.repo wget http://download.opensuse.org/repositories/home:cornell_vrdc/CentOS_7/home:cornell_vrdc.repo + yum -y localinstall https://download.postgresql.org/pub/repos/yum/9.5/redhat/rhel-7-x86_64/pgdg-centos95-9.5-2.noarch.rpm + rpm -Uvh http://download.fedoraproject.org/pub/epel/7/x86_64/e/epel-release-7-6.noarch.rpm + setsebool -P httpd_can_network_connect 1 + ;; + Ubuntu) + # if [ ! -e /etc/apt/sources.list.d/R.list ]; then + # sh -c 'echo "deb http://cran.rstudio.com/bin/linux/ubuntu `lsb_release -s -c`/" > /etc/apt/sources.list.d/R.list' + # apt-key adv --keyserver keyserver.ubuntu.com --recv E084DAB9 + # fi + if [ ! -e /etc/apt/sources.list.d/ruby.list ]; then + sh -c 'echo "deb http://ppa.launchpad.net/brightbox/ruby-ng/ubuntu xenial main" > /etc/apt/sources.list.d/ruby.list' + apt-key adv --keyserver keyserver.ubuntu.com --recv C3173AA6 + fi + # if [ ! -e /etc/apt/sources.list.d/pgdg.list ]; then + # sh -c 'echo "deb http://apt.postgresql.org/pub/repos/apt `lsb_release -s -c`-pgdg main" > /etc/apt/sources.list.d/pgdg.list' + # wget --quiet -O - https://www.postgresql.org/media/keys/ACCC4CF8.asc | apt-key add - + # fi + apt-get -qq -y update + ;; +esac + +echo "######################################################################" +echo "INSTALLING PACKAGES" +echo "######################################################################" +case "$OS_VERSION" in + RH_*) + yum install -y git R gfortran openssl-devel + yum install -y openmpi openmpi-devel netcdf netcdf-openmpi netcdf-devel netcdf-openmpi-devel netcdf-fortran-devel netcdf-fortran-openmpi + ln -s /usr/lib64/openmpi/bin/mpicc /usr/bin/mpicc + ln -s /usr/lib64/openmpi/bin/mpif90 /usr/bin/mpif90 + # for ED + yum install -y hdf5-openmpi-devel + # for LPJ-GUESS + yum install -y cmake + # for DALEC + yum install -y gsl-devel liblas-devel lapack-devel + # for PEcAn + yum install -y ed libpng-devel libpng12-devel libjpeg-turbo-devel jags4 jags4-devel python-devel udunits2-devel gdal-devel proj-devel proj-devel proj-nad proj-epsg libxml2-devel udunits2-devel gmp-devel + # for PostgreSQL + yum install -y postgresql95-server postgresql95-devel postgis2_95 + # web gui + yum install -y httpd php php-pgsql php-xml + ;; + Ubuntu) + apt-get -y install build-essential gfortran git r-base-core r-base r-base-dev jags liblapack-dev libnetcdf-dev netcdf-bin bc libcurl4-gnutls-dev curl udunits-bin libudunits2-dev libgmp-dev python-dev libgdal1-dev libproj-dev expect + apt-get -y install openmpi-bin libopenmpi-dev + apt-get -y install libgsl0-dev libssl-dev + # + apt-get -y install r-cran-ggplot2 + # for maeswrap + apt-get -y install r-cran-rgl + # for R doc + apt-get -y install texinfo texlive-latex-base texlive-latex-extra texlive-fonts-recommended + # ruby + apt-get -y install ruby2.1 ruby2.1-dev + # for LPJ-GUESS + apt-get -y install cmake + # for PostgreSQL + # apt-get -y install libdbd-pgsql postgresql-9.5 postgresql-client-9.5 libpq-dev postgresql-9.5-postgis-2.2 postgresql-9.5-postgis-scripts + # for web gui + apt-get -y install apache2 libapache2-mod-php7.0 php7.0 libapache2-mod-passenger php7.0-xml php-ssh2 php7.0-pgsql + # Ubuntu 14.04 php5-pgsql libapache2-mod-php5 php5 and no php-xml + ;; +esac diff --git a/docker/install_pecan.sh b/docker/install_pecan.sh new file mode 100644 index 00000000000..ffd6a30c128 --- /dev/null +++ b/docker/install_pecan.sh @@ -0,0 +1,38 @@ +#!/bin/bash + +. /build/install_pecan_preprocessor.sh + +echo "######################################################################" +echo "PECAN" +echo "######################################################################" +if [ ! -e ${HOME}/pecan ]; then + cd + git clone https://github.com/PecanProject/pecan.git +fi +cd ${HOME}/pecan +git pull +make + + curl -o /var/www/html/pecan.pdf https://www.gitbook.com/download/pdf/book/pecan/pecan-documentation + rm /var/www/html/index.html + ln -s ${HOME}/pecan/documentation/index_vm.html /var/www/html/index.html +if [ ! -e ${HOME}/pecan/web/config.php ]; then + sed -e "s#browndog_url=.*#browndog_url=\"${BROWNDOG_URL}\";#" \ + -e "s#browndog_username=.*#browndog_username=\"${BROWNDOG_USERNAME}\";#" \ + -e "s#browndog_password=.*#browndog_password=\"${BROWNDOG_PASSWORD}\";#" \ + -e "s#googleMapKey=.*#googleMapKey=\"${GOOGLE_MAP_KEY}\";#" \ + -e "s/carya/$USER/g" ${HOME}/pecan/web/config.example.php > ${HOME}/pecan/web/config.php +fi + +if [ ! -e ${HTTP_CONF}/pecan.conf ]; then + cat > /tmp/pecan.conf << EOF +Alias /pecan ${HOME}/pecan/web + + DirectoryIndex index.php + Options +ExecCGI + Require all granted + +EOF + cp /tmp/pecan.conf ${HTTP_CONF}/pecan.conf + rm /tmp/pecan.conf +fi diff --git a/docker/install_pecan_preprocessor.sh b/docker/install_pecan_preprocessor.sh new file mode 100644 index 00000000000..c92a67378a1 --- /dev/null +++ b/docker/install_pecan_preprocessor.sh @@ -0,0 +1,36 @@ +#!/bin/bash + +set -e + +#if [ "`whoami`" == "root" ]; then +# echo "Don't run this script as root" +# exit -1 +#fi + +# configuration +BROWNDOG_URL="http://dap.ncsa.illinois.edu:8184/convert/"; +BROWNDOG_USERNAME=""; +BROWNDOG_PASSWORD=""; + +GOOGLE_MAP_KEY="" + +#SETUP_VM="" +#SETUP_PALEON="" +#REBUILD="" + +# commented out might need it later for communication purpose +#RSTUDIO_SERVER="1.0.136" +#SHINY_SERVER="1.5.3.838" + +if [ -e $(dirname $0)/install_pecan.config ]; then + . $(dirname $0)/install_pecan.config +fi + +if [ -e /etc/redhat-release ]; then + OS_VERSION="RH_$( sed -r 's/.* ([0-9]+)\..*/\1/' /etc/redhat-release )" + HTTP_CONF="/etc/httpd/conf.d/" + chmod o+x ${HOME} +else + OS_VERSION="Ubuntu" + HTTP_CONF="/etc/apache2/conf-available/" +fi diff --git a/docker/runit/cron b/docker/runit/cron new file mode 100644 index 00000000000..e36fbfd51ec --- /dev/null +++ b/docker/runit/cron @@ -0,0 +1,3 @@ +#!/bin/sh + +exec /usr/sbin/cron -f diff --git a/docker/runit/cron_log b/docker/runit/cron_log new file mode 100644 index 00000000000..c0c15e1ca78 --- /dev/null +++ b/docker/runit/cron_log @@ -0,0 +1,3 @@ +#!/bin/sh + +exec chpst -u nobody svlogd -tt /var/log/cron/ diff --git a/docker/system_services.sh b/docker/system_services.sh new file mode 100644 index 00000000000..81088dcad13 --- /dev/null +++ b/docker/system_services.sh @@ -0,0 +1,90 @@ +#!/bin/bash +export LC_ALL=C +export DEBIAN_FRONTEND=noninteractive +minimal_apt_get_install='apt-get install -y --no-install-recommends' + +## temporarily disable dpkg fsync to make building faster. +if [[ ! -e /etc/dpkg/dpkg.cfg.d/docker-apt-speedup ]]; then + echo force-unsafe-io > /etc/dpkg/dpkg.cfg.d/docker-apt-speedup +fi + +## prevent initramfs updates from trying to run grub and lilo. +export INITRD=no +mkdir -p /etc/container_environment +echo -n no > /etc/container_environment/INITRD + +## enable Ubuntu Universe and Multiverse. +sed -i 's/^#\s*\(deb.*universe\)$/\1/g' /etc/apt/sources.list +sed -i 's/^#\s*\(deb.*multiverse\)$/\1/g' /etc/apt/sources.list +apt-get update + +## fix some issues with APT packages. +dpkg-divert --local --rename --add /sbin/initctl +ln -sf /bin/true /sbin/initctl + +## replace the 'ischroot' tool to make it always return true. +dpkg-divert --local --rename --add /usr/bin/ischroot +ln -sf /bin/true /usr/bin/ischroot + +## upgrade all packages. +apt-get dist-upgrade -y --no-install-recommends + +## install HTTPS support for APT. +$minimal_apt_get_install apt-utils apt-transport-https ca-certificates language-pack-en + +## fix locale. +locale-gen en_US.UTF-8 +update-locale LANG=en_US.UTF-8 LC_CTYPE=en_US.UTF-8 LANGUAGE=en_US:en LC_ALL=en_US.UTF-8 +echo -n en_US.UTF-8 > /etc/container_environment/LANG +echo -n en_US.UTF-8 > /etc/container_environment/LC_CTYPE +echo -n en_US:en > /etc/container_environment/LANGUAGE +echo -n en_US.UTF-8 > /etc/container_environment/LC_ALL + +## install init process. +cp /build/bin/my_init /sbin/ +chmod 750 /sbin/my_init +mkdir -p /etc/my_init.d +mkdir -p /etc/container_environment +touch /etc/container_environment.sh +touch /etc/container_environment.json +chmod 700 /etc/container_environment + +groupadd -g 8377 docker_env +chown :docker_env /etc/container_environment.sh /etc/container_environment.json +chmod 640 /etc/container_environment.sh /etc/container_environment.json +ln -s /etc/container_environment.sh /etc/profile.d/ +echo ". /etc/container_environment.sh" >> /root/.bashrc + +## install runit. +$minimal_apt_get_install runit cron + +## install cron daemon. +mkdir -p /etc/service/cron +mkdir -p /var/log/cron +chmod 600 /etc/crontabs +cp /build/runit/cron /etc/service/cron/run +cp /build/config/cron_log_config /var/log/cron/config +chown -R nobody /var/log/cron +chmod +x /etc/service/cron/run + +## remove useless cron entries. +rm -f /etc/cron.daily/standard +rm -f /etc/cron.daily/upstart +rm -f /etc/cron.daily/dpkg +rm -f /etc/cron.daily/password +rm -f /etc/cron.weekly/fstrim + +## often used tools. +$minimal_apt_get_install curl less nano psmisc wget + +## fix other small problem. +rm /bin/sh +ln -s /bin/bash /bin/sh +echo `. /etc/lsb-release; echo ${DISTRIB_CODENAME/*, /}` >> /etc/container_environment/DISTRIB_CODENAME + +## cleanup +apt-get clean +rm -rf /build +rm -rf /tmp/* /var/tmp/* +rm -rf /var/lib/apt/lists/* +rm -f /etc/dpkg/dpkg.cfg.d/02apt-speedup diff --git a/docker/update_machine.sh b/docker/update_machine.sh new file mode 100644 index 00000000000..4f7709df5ef --- /dev/null +++ b/docker/update_machine.sh @@ -0,0 +1,30 @@ +#!/bin/bash + +. /build/install_pecan_preprocessor.sh + +# actual install/update +echo "######################################################################" +echo "UPDATING MACHINE" +echo "######################################################################" +mkdir /home/carya/ +chmod 755 /home/carya/ +case "$OS_VERSION" in + RH_*) + yum update -y + if [ "$SETUP_VM" != "" ]; then + sed -i -e "s/^127.0.0.1 .*\$/127.0.0.1 ${HOSTNAME}.pecan ${HOSTNAME} localhost localhost.localdomain localhost4 localhost4.localdomain4/" /etc/hosts + fi + ;; + Ubuntu) + apt-get -qq -y update + apt-get -y dist-upgrade + apt-get -y purge --auto-remove + if [ "$SETUP_VM" != "" ]; then + sed -i -e "s/^127.0.0.1 .*\$/127.0.0.1 ${HOSTNAME}.pecan ${HOSTNAME} localhost/" /etc/hosts + fi + ;; + *) + echo "Unknown OS" + exit 1 + ;; +esac From a37e01e209a8664676f4d69956da125f324e0027 Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Sat, 27 May 2017 10:25:40 -0400 Subject: [PATCH 012/771] Some cleanup --- models/fates/inst/template.job | 2 -- 1 file changed, 2 deletions(-) diff --git a/models/fates/inst/template.job b/models/fates/inst/template.job index 855212c2e66..cd5c5af83c6 100644 --- a/models/fates/inst/template.job +++ b/models/fates/inst/template.job @@ -25,8 +25,6 @@ export GFORTRAN_UNBUFFERED_PRECONNECTED=yes ## Seem to be stuck having to build a new case. Will try and avoid this in the future cd ${SCRIPTROOT} echo "*** Run create_newcase ***" - #./create_newcase -case @CASEDIR@ -res CLM_USRDAT -compset ICLM45ED -mach eddi -compiler gnu - #./create_newcase -case @CASEDIR@ -res 1x1_brazil -compset ICLM45ED -mach eddi -compiler gnu -project pecan echo @MACHINE@ ./create_newcase -case @CASEDIR@ -res 1x1_brazil -compset ICLM45ED -mach @MACHINE@ -compiler @COMPILER@ -project @PROJECT@ From 214d6b8b0beb3c34e1c9a03bb60b64d01bd72853 Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Mon, 29 May 2017 10:24:56 -0400 Subject: [PATCH 013/771] Updated template.job. Works on modex --- models/fates/inst/template.job | 26 +++++++++++++++++++------- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/models/fates/inst/template.job b/models/fates/inst/template.job index cd5c5af83c6..6174570327e 100644 --- a/models/fates/inst/template.job +++ b/models/fates/inst/template.job @@ -25,9 +25,17 @@ export GFORTRAN_UNBUFFERED_PRECONNECTED=yes ## Seem to be stuck having to build a new case. Will try and avoid this in the future cd ${SCRIPTROOT} echo "*** Run create_newcase ***" + echo " ----- Case details:" + echo @CASEDIR@ + #echo @RES@ + #echo @COMPSET@ echo @MACHINE@ + echo @COMPILER@ + echo @PROJECT@ + echo "--------------------------" ./create_newcase -case @CASEDIR@ -res 1x1_brazil -compset ICLM45ED -mach @MACHINE@ -compiler @COMPILER@ -project @PROJECT@ - + #./create_newcase -case @CASEDIR@ -res @RES@ -compset @COMPSET -mach @MACHINE@ -compiler @COMPILER@ -project @PROJECT@ + cd "@RUNDIR@" ## RECURSIVELY COPY/SYMLINK REFERENCE INPUTS DIRECTORY (DIN_LOC_ROOT) @@ -72,8 +80,9 @@ export GFORTRAN_UNBUFFERED_PRECONNECTED=yes ## ENV_BUILD update configurations ./xmlchange -file env_build.xml -id CIME_OUTPUT_ROOT -val @CASEDIR@ - ./xmlchange -file env_build.xml -id EXEROOT -val @BLD@ - ./xmlchange -file env_build.xml -id BUILD_COMPLETE -val TRUE + #./xmlchange -file env_build.xml -id EXEROOT -val @BLD@ + ./xmlchange -file env_build.xml -id EXEROOT -val @CASEDIR@/bld + #./xmlchange -file env_build.xml -id BUILD_COMPLETE -val TRUE ## DATES -> ENV_RUN ./xmlchange -file env_run.xml -id RUNDIR -val @CASEDIR@/run @@ -81,7 +90,7 @@ export GFORTRAN_UNBUFFERED_PRECONNECTED=yes ./xmlchange -file env_run.xml -id STOP_OPTION -val ndays ./xmlchange -file env_run.xml -id STOP_N -val @STOP_N@ - ## SITE INFO --> DOMAIN FILE + rm @INDIR@/share/domains/domain.clm/* ln -s @RUNDIR@/domain.lnd.@SITE_NAME@.nc @INDIR@/share/domains/domain.clm/ @@ -111,10 +120,10 @@ EOF echo "*** Run case.setup ***" ./case.setup - ## ADDITIONAL MODS THAT ARE JUST ASSOCIATED WITH REFCASE + ## ADDITIONAL MODS THAT ARE JUST ASSOCIATED WITH REFCASE - removed 'NEP' 'NPP_column' cat >> user_nl_clm << EOF hist_empty_htapes = .true. -hist_fincl1='EFLX_LH_TOT','TSOI_10CM','QVEGT','NEP','GPP','AR','ED_bleaf','ED_biomass','NPP_column','NPP','MAINT_RESP','GROWTH_RESP' +hist_fincl1='EFLX_LH_TOT','TSOI_10CM','QVEGT','GPP','AR','ED_bleaf','ED_biomass','NPP','MAINT_RESP','GROWTH_RESP' hist_mfilt = 8760 hist_nhtfrq = -1 EOF @@ -124,7 +133,9 @@ EOF #EOF echo "*** Run case.build ***" + sleep 10 ./case.build + #./case.build --sharedlib-only ## RUN echo "*** Run ***" @@ -145,7 +156,8 @@ EOF ln -s @RUNDIR@/datm.streams.txt.PEcAn_met . fi - "@BINARY@" + #"@BINARY@" # EDITED BY SPS + "@CASEDIR@/bld/cesm.exe" # edited for testing STATUS=$? From bfa8bffa907e6bcd27c3be39fed2a809ed40eb0a Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Mon, 29 May 2017 10:52:00 -0400 Subject: [PATCH 014/771] Update to models/fates/R/model2netcdf.FATES.R to isolate var outputting NANs --- models/fates/R/model2netcdf.FATES.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/models/fates/R/model2netcdf.FATES.R b/models/fates/R/model2netcdf.FATES.R index 1c9dcf8924a..ed3768e4b38 100644 --- a/models/fates/R/model2netcdf.FATES.R +++ b/models/fates/R/model2netcdf.FATES.R @@ -98,10 +98,12 @@ model2netcdf.FATES <- function(outdir) { xyt <- list(lon, lat, t) ### build netCDF data + ## !! TODO: ADD MORE OUTPUTS HERE out <- NULL out <- var_update(out,"AR","AutoResp","kgC m-2 s-1") out <- var_update(out,"GPP","GPP","kgC m-2 s-1") - out <- var_update(out,"NPP_column","NPP","kgC m-2 s-1") + out <- var_update(out,"NPP","NPP","kgC m-2 s-1") + #out <- var_update(out,"NPP_column","NPP","kgC m-2 s-1") #!! RKnox suggested using NPP not NPP_column #out <- var_update(out,"NEP","NEE","kgC m-2 s-1") # !!temporarily disabling NEE. See https://github.com/NGEET/ed-clm/issues/154 out <- var_update(out,"EFLX_LH_TOT","Qle","W m-2") out <- var_update(out,"QVEGT","TVeg","mm s-1") ## equiv to std of kg m-2 s but don't trust udunits to get right From 330bff647bda1e5534342f5517bb8ed57f06de8e Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Mon, 29 May 2017 11:13:10 -0400 Subject: [PATCH 015/771] Quick add back of comment --- models/fates/inst/template.job | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/fates/inst/template.job b/models/fates/inst/template.job index 6174570327e..27943f3487d 100644 --- a/models/fates/inst/template.job +++ b/models/fates/inst/template.job @@ -90,7 +90,7 @@ export GFORTRAN_UNBUFFERED_PRECONNECTED=yes ./xmlchange -file env_run.xml -id STOP_OPTION -val ndays ./xmlchange -file env_run.xml -id STOP_N -val @STOP_N@ - + ## SITE INFO --> DOMAIN FILE rm @INDIR@/share/domains/domain.clm/* ln -s @RUNDIR@/domain.lnd.@SITE_NAME@.nc @INDIR@/share/domains/domain.clm/ From 1232952efb4c472c9c855d0a1e291b86361b1f1d Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Tue, 30 May 2017 09:01:56 -0400 Subject: [PATCH 016/771] A few more tweaks to template.job. Still need to get this to work without re-building model each time --- models/fates/inst/template.job | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/models/fates/inst/template.job b/models/fates/inst/template.job index 27943f3487d..7ed2e9b05fd 100644 --- a/models/fates/inst/template.job +++ b/models/fates/inst/template.job @@ -27,11 +27,11 @@ export GFORTRAN_UNBUFFERED_PRECONNECTED=yes echo "*** Run create_newcase ***" echo " ----- Case details:" echo @CASEDIR@ - #echo @RES@ - #echo @COMPSET@ - echo @MACHINE@ - echo @COMPILER@ - echo @PROJECT@ + #echo "Res: @RES@ " + #echo "Compset: @COMPSET@ " + echo "Machine: @MACHINE@ " + echo "Compiler: @COMPILER@ " + echo "Project_name: @PROJECT@ " echo "--------------------------" ./create_newcase -case @CASEDIR@ -res 1x1_brazil -compset ICLM45ED -mach @MACHINE@ -compiler @COMPILER@ -project @PROJECT@ #./create_newcase -case @CASEDIR@ -res @RES@ -compset @COMPSET -mach @MACHINE@ -compiler @COMPILER@ -project @PROJECT@ @@ -139,6 +139,8 @@ EOF ## RUN echo "*** Run ***" + now=`date` + echo "Simulation start: $now" cd run mkdir timing echo `pwd` From 5fa6e79eac0dc966feeb3f2aa5fab2255263cd3a Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sat, 3 Jun 2017 21:48:29 -0500 Subject: [PATCH 017/771] Refactoring shiny code to load all variables at once. Also allow models from different run and workflow ids --- shiny/workflowPlot/helper.R | 4 +- shiny/workflowPlot/server.R | 211 +++++++++++++++++++++++++++--------- shiny/workflowPlot/ui.R | 10 +- 3 files changed, 172 insertions(+), 53 deletions(-) diff --git a/shiny/workflowPlot/helper.R b/shiny/workflowPlot/helper.R index a014b844a8a..9390b6d30b7 100644 --- a/shiny/workflowPlot/helper.R +++ b/shiny/workflowPlot/helper.R @@ -9,6 +9,6 @@ checkAndDownload<-function(packageNames) { isInstalled <- function(mypkg){ is.element(mypkg, installed.packages()[,1]) } - -checkAndDownload(c('plotly','scales')) +checkAndDownload(c('plotly','scales','dplyr')) +# devtools::install_github('hadley/ggplot2') # testVal = 5 \ No newline at end of file diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 11ee7c1f271..06307552dcd 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -4,48 +4,48 @@ library(shiny) library(ncdf4) library(ggplot2) source('helper.R') -require(plotly) +library(plotly) library(scales) +library(dplyr) # Define server logic server <- shinyServer(function(input, output, session) { + # options(shiny.trace=TRUE) bety <- betyConnect() - + # bety <- betyConnect('/home/carya/pecan/web/config.php') ranges <- reactiveValues(x = NULL, y = NULL) - print("RESTART") # set the workflow id(s) ids <- get_workflow_ids(bety, session) - updateSelectizeInput(session, "workflow_id", choices=ids) + # updateSelectizeInput(session, "workflow_id", choices=ids) + observe({ + updateSelectizeInput(session, "workflow_id", choices=ids) + }) workflow_id <- reactive({ req(input$workflow_id) workflow_id <- input$workflow_id }) - # update the run_ids if user changes workflow run_ids <- reactive(get_run_ids(bety, workflow_id())) observe({ updateSelectizeInput(session, "run_id", choices=run_ids()) }) - # update variables if user changes run var_names <- reactive({ run_ids <- get_run_ids(bety, workflow_id()) var_names <- get_var_names(bety, workflow_id(), run_ids[1]) # Removing the variables "Year" and "FracJulianDay" from the Variable Name input in the app - removeVarNames = c('Year','FracJulianDay') + removeVarNames <- c('Year','FracJulianDay') var_names <-var_names[!var_names %in% removeVarNames] return(var_names) }) observe({ updateSelectizeInput(session, "variable_name", choices=var_names()) }) - observe({ ignore <- input$variable_name ranges$x <- NULL ranges$y <- NULL }) - observeEvent(input$plot_dblclick, { brush <- input$plot_brush if (!is.null(brush)) { @@ -59,61 +59,174 @@ server <- shinyServer(function(input, output, session) { # If want to render text output$info <- renderText({ paste0(input$variable_name) - # paste0(testVal) + # paste0(run_ids(),length(run_ids()),ids) + # ,session$clientData$url_search) # paste0("x=", input$plot_dblclick$x, "\ny=", input$plot_dblclick$y) }) - - output$outputPlot <- renderPlotly({ - workflow_id <- isolate(input$workflow_id) - run_id <- isolate(input$run_id) - var_name <- input$variable_name - if (workflow_id != "" && run_id != "" && var_name != "") { - workflow <- collect(workflow(bety, workflow_id)) - if(nrow(workflow) > 0) { - outputfolder <- file.path(workflow$folder, 'out', run_id) - files <- list.files(outputfolder, "*.nc$", full.names=TRUE) - dates <- NA - vals <- NA - title <- var_name - ylab <- "" - for(file in files) { - nc <- nc_open(file) - var <- ncdf4::ncatt_get(nc, var_name) - #sw <- if ('Swdown' %in% names(nc$var)) ncdf4::ncvar_get(nc, 'Swdown') else TRUE - sw <- TRUE - title <- var$long_name - ylab <- var$units - x <- ncdays2date(ncdf4::ncvar_get(nc, 'time'), ncdf4::ncatt_get(nc, 'time')) - y <- ncdf4::ncvar_get(nc, var_name) - b <- !is.na(x) & !is.na(y) & sw != 0 - dates <- if(is.na(dates)) x[b] else c(dates, x[b]) - vals <- if(is.na(vals)) y[b] else c(vals, y[b]) - ncdf4::nc_close(nc) + workFlowData <-reactive({ + # workflow_id = 99000000077 + # run_id = 99000000002 + # var_name = var_names + globalDF <- data.frame() + for(workflow_id in ids){ + run_ids <- get_run_ids(bety,workflow_id) + for(run_id in run_ids){ + var_names <- get_var_names(bety, workflow_id, run_id) + removeVarNames <- c('Year','FracJulianDay') + var_names <-var_names[!var_names %in% removeVarNames] + # if (workflow_id != "" && run_id != "" && var_name != "") { + workflow <- collect(workflow(bety, workflow_id)) + if(nrow(workflow) > 0) { + outputfolder <- file.path(workflow$folder, 'out', run_id) + files <- list.files(outputfolder, "*.nc$", full.names=TRUE) + for(file in files) { + nc <- nc_open(file) + for(var_name in var_names){ + dates <- NA + vals <- NA + title <- var_name + ylab <- "" + var <- ncdf4::ncatt_get(nc, var_name) + #sw <- if ('Swdown' %in% names(nc$var)) ncdf4::ncvar_get(nc, 'Swdown') else TRUE + sw <- TRUE + if(!is.null(var$long_name)){ + title <- var$long_name + } + if(!is.null(var$units)){ + ylab <- var$units + } + x <- ncdays2date(ncdf4::ncvar_get(nc, 'time'), ncdf4::ncatt_get(nc, 'time')) + y <- ncdf4::ncvar_get(nc, var_name) + b <- !is.na(x) & !is.na(y) & sw != 0 + dates <- if(is.na(dates)) x[b] else c(dates, x[b]) + dates <- as.Date(dates) + vals <- if(is.na(vals)) y[b] else c(vals, y[b]) + xlab <- "Time" + # xlab <- if (is.null(ranges$x)) "Time" else paste(ranges$x, collapse=" - ") + valuesDF <- data.frame(dates,vals) + metaDF <- data.frame(workflow_id,run_id,title,xlab,ylab,var_name) + # metaDF1<-metaDF[rep(seq_len(nrow(valuesDF))),] + currentDF = cbind(valuesDF,metaDF) + globalDF<-rbind(globalDF,currentDF) + } + ncdf4::nc_close(nc) + } } - xlab <- if (is.null(ranges$x)) "Time" else paste(ranges$x, collapse=" - ") - # plot result - print(ranges$x) - dates = as.Date(dates) - df = data.frame(dates, vals) - # df$dates = as.factor(df$dates) - - plt <- ggplot(df, aes(x=dates, y=vals)) + + } + } + globalDF$title = as.character(globalDF$title) + globalDF$xlab = as.character(globalDF$xlab) + globalDF$ylab = as.character(globalDF$ylab) + globalDF$var_name = as.character(globalDF$var_name) + return(globalDF) + }) + output$outputPlot <- renderPlotly({ + # workflow_id <- isolate(input$workflow_id) + # run_id <- isolate(input$run_id) + # var_name <- input$variable_name + # if (workflow_id != "" && run_id != "" && var_name != "") { + # workflow <- collect(workflow(bety, workflow_id)) + # if(nrow(workflow) > 0) { + # outputfolder <- file.path(workflow$folder, 'out', run_id) + # files <- list.files(outputfolder, "*.nc$", full.names=TRUE) + # dates <- NA + # vals <- NA + # title <- var_name + # ylab <- "" + # for(file in files) { + # nc <- nc_open(file) + # var <- ncdf4::ncatt_get(nc, var_name) + # #sw <- if ('Swdown' %in% names(nc$var)) ncdf4::ncvar_get(nc, 'Swdown') else TRUE + # sw <- TRUE + # title <- var$long_name + # ylab <- var$units + # x <- ncdays2date(ncdf4::ncvar_get(nc, 'time'), ncdf4::ncatt_get(nc, 'time')) + # y <- ncdf4::ncvar_get(nc, var_name) + # b <- !is.na(x) & !is.na(y) & sw != 0 + # dates <- if(is.na(dates)) x[b] else c(dates, x[b]) + # vals <- if(is.na(vals)) y[b] else c(vals, y[b]) + # ncdf4::nc_close(nc) + # } + # xlab <- if (is.null(ranges$x)) "Time" else paste(ranges$x, collapse=" - ") + # # plot result + # print(ranges$x) + # dates <- as.Date(dates) + # df <- data.frame(dates, vals) + # df <- workFlowData(input$workflow_id,input$run_id,input$variable_names) + masterDF<-workFlowData() + output$info1 <- renderText({ + paste0(nrow(masterDF)) + }) + validate( + need(input$workflow_id, 'Found workflow id'), + need(input$run_id, 'Run id detected'), + need(input$variable_name, 'Please wait! Loading data') + ) + masterDF$var_name = as.character(masterDF$var_name) + # masterDF$var_name = as.factor(masterDF$var_name) + # df1<-subset(masterDF,var_name==var_name) + df<-masterDF %>% + dplyr::filter(workflow_id == input$workflow_id & + run_id == input$run_id & + var_name == input$variable_name) %>% + dplyr::select(dates,vals) + title<-unique(df$title)[1] + xlab<-unique(df$xlab)[1] + ylab<-unique(df$ylab)[1] + output$info2 <- renderText({ + paste0(nrow(df)) + # paste0(typeof(title)) + }) + output$info3 <- renderText({ + paste0('xlab') + # paste0(typeof(title)) + }) + + # df1<-masterDF %>% filter(masterDF$var_name %in% var_name) + # workflow_id %in% workflow_id) + # & run_id == run_id & var_name == var_name) + # df<-masterDF %>% dplyr::filter(workflow_id == input$workflow_id) + plt <- ggplot(df, aes(x=dates, y=vals)) + # geom_point(aes(color="Model output")) + geom_point() + # geom_smooth(aes(fill = "Spline fit")) + # coord_cartesian(xlim = ranges$x, ylim = ranges$y) + # scale_y_continuous(labels=fancy_scientific) + - labs(title=title, x=xlab, y=ylab) + + labs(title=title, x=xlab, y=ylab) + + # labs(title=unique(df$title)[1], x=unique(df$xlab)[1], y=unique(df$ylab)[1]) + scale_color_manual(name = "", values = "black") + scale_fill_manual(name = "", values = "grey50") # theme(axis.text.x = element_text(angle = -90)) - plt<-ggplotly(plt) # plot(plt) # add_icon() - } - } + # } + # } }) + +# Shiny server closes here }) +# global_df<-data.frame() +# for(variable in var_names){ +# local_df<-data.frame() +# for(file in files){ +# nc <-nc_open(file) +# var <- ncdf4::ncatt_get(nc, var_name) +# #sw <- if ('Swdown' %in% names(nc$var)) ncdf4::ncvar_get(nc, 'Swdown') else TRUE +# sw <- TRUE +# title <- var$long_name +# ylab <- var$units +# x <- ncdays2date(ncdf4::ncvar_get(nc, 'time'), ncdf4::ncatt_get(nc, 'time')) +# y <- ncdf4::ncvar_get(nc, var_name) +# b <- !is.na(x) & !is.na(y) & sw != 0 +# dates <- if(is.na(dates)) x[b] else c(dates, x[b]) +# vals <- if(is.na(vals)) y[b] else c(vals, y[b]) +# local_df<-rbind(local_df,data.frame(dates,vals,title,ylab,variable)) +# } +# global_df<-rbind(global_df,local_df) +# } + +# runApp(port=6480, launch.browser=FALSE) + # runApp(port=5658, launch.browser=FALSE) diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 8b54949a691..7cc7ba427ac 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -11,6 +11,9 @@ ui <- shinyUI(fluidPage( selectInput("workflow_id", "Workflow ID", c()), selectInput("run_id", "Run ID", c()), selectInput("variable_name", "Variable Name", "") + # selectInput("workflow_id", "Workflow ID", c(99000000077)), + # selectInput("run_id", "Run ID", c(99000000002)), + # selectInput("variable_name", "Variable Name", c("AutoResp","GPP")) ), mainPanel( plotlyOutput("outputPlot" @@ -18,9 +21,12 @@ ui <- shinyUI(fluidPage( # brush = brushOpts(id = "plot_brush", # resetOnNew = TRUE), # dblclick = "plot_dblclick" - ) + ), # Checking variable names - ,verbatimTextOutput("info") + verbatimTextOutput("info"), + verbatimTextOutput("info1"), + verbatimTextOutput("info2"), + verbatimTextOutput("info3") ) ) )) From fa390dc84293e121c81622f1ec3329148f095cb3 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 7 Jun 2017 22:54:50 +0530 Subject: [PATCH 018/771] Commented out the cleanings as it removing the useful files which needed in further stages modified: docker/system_services.sh --- docker/system_services.sh | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/docker/system_services.sh b/docker/system_services.sh index 81088dcad13..9e991c011b0 100644 --- a/docker/system_services.sh +++ b/docker/system_services.sh @@ -83,8 +83,8 @@ ln -s /bin/bash /bin/sh echo `. /etc/lsb-release; echo ${DISTRIB_CODENAME/*, /}` >> /etc/container_environment/DISTRIB_CODENAME ## cleanup -apt-get clean -rm -rf /build -rm -rf /tmp/* /var/tmp/* -rm -rf /var/lib/apt/lists/* -rm -f /etc/dpkg/dpkg.cfg.d/02apt-speedup +# apt-get clean +# rm -rf /build +# rm -rf /tmp/* /var/tmp/* +# rm -rf /var/lib/apt/lists/* +# rm -f /etc/dpkg/dpkg.cfg.d/02apt-speedup From be83943a0be124b7aace4be88e9dba1195f78ce6 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 7 Jun 2017 22:56:20 +0530 Subject: [PATCH 019/771] Added the Volume Mounting point modified: Dockerfile --- Dockerfile | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/Dockerfile b/Dockerfile index a61c62a9bd4..f5ad9d89695 100644 --- a/Dockerfile +++ b/Dockerfile @@ -14,13 +14,12 @@ RUN echo "deb http://cran.rstudio.com/bin/linux/ubuntu xenial/" > /etc/apt/sourc # copy the installation script inside the container ADD docker/ /build +# Set script mod +x for preprocessors +RUN chmod 750 /build/*.sh + # Run the OS System setup script -RUN chmod 750 /build/system_services.sh RUN /build/system_services.sh -# Set script mod +x for preprocessors -RUN chmod 750 /build/* - # run update machine to update machine RUN /build/update_machine.sh @@ -36,5 +35,8 @@ RUN /build/install_pecan.sh # Clean up APT when done. RUN apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* +# Mounting pecan data volume +VOLUME /home/skywalker/pecandata:/pecandata + # startup CMD ["/sbin/my_init"] From c8bade7e13e8240036274f4d165fc5d4d5009633 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Thu, 8 Jun 2017 21:10:22 +0530 Subject: [PATCH 020/771] Added docker composer file Only support postgresql and pecancore till now new file: docker-compose.yml --- docker-compose.yml | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 docker-compose.yml diff --git a/docker-compose.yml b/docker-compose.yml new file mode 100644 index 00000000000..9d99d4ca851 --- /dev/null +++ b/docker-compose.yml @@ -0,0 +1,24 @@ +version: '3' + +networks: + net1: + driver: bridge + +services: + postgresql: + image: 'postgres:latest' + networks: + - net1 + ports: + - '5432:5432' + + pecan-image: + build: + context: . + dockerfile: Dockerfile + networks: + - net1 + ports: + - '8787:8787' + volumes: + - /home/skywalker/pecandata:/pecandata From a57cf0a6c4a1987465dcb3a8abcfa761c819a587 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 10 Jun 2017 18:20:41 +0530 Subject: [PATCH 021/771] Added Bety in Compose file Added bety in docker-compose.yml Added SIPNET (with installation script) as default testing Model in Dockerfile Added postgress setup script --- Dockerfile | 10 ++++----- docker-compose.yml | 12 +++++++++++ docker/install_sipnet.sh | 27 ++++++++++++++++++++++++ docker/setup_postgresql.sh | 43 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 87 insertions(+), 5 deletions(-) create mode 100644 docker/install_sipnet.sh create mode 100644 docker/setup_postgresql.sh diff --git a/Dockerfile b/Dockerfile index f5ad9d89695..c4698cff828 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,5 +1,5 @@ FROM ubuntu:16.04 -MAINTAINER amanskywalker (ak47su30ac@gmail.com) +MAINTAINER Aman Kumar (ak47su30ac@gmail.com) # expose port 80 for the web interface EXPOSE 80 @@ -32,11 +32,11 @@ RUN /build/install_R.sh # run install pecan to install pecan cores RUN /build/install_pecan.sh -# Clean up APT when done. -RUN apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* +# run install sipnet to install SIPNET (default testing Model) +RUN /build/install_sipnet.sh -# Mounting pecan data volume -VOLUME /home/skywalker/pecandata:/pecandata +# Clean up APT when done. +RUN apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* /build/* # startup CMD ["/sbin/my_init"] diff --git a/docker-compose.yml b/docker-compose.yml index 9d99d4ca851..5f4c6bcd798 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -12,7 +12,17 @@ services: ports: - '5432:5432' + bety: + image: 'pecan/bety:latest' + networks: + - net1 + ports: + - '3000:3000' + pecan-image: + depends_on: + - postgresql + - bety build: context: . dockerfile: Dockerfile @@ -20,5 +30,7 @@ services: - net1 ports: - '8787:8787' + - '22:22' + - '80:80' volumes: - /home/skywalker/pecandata:/pecandata diff --git a/docker/install_sipnet.sh b/docker/install_sipnet.sh new file mode 100644 index 00000000000..2034f81a9f5 --- /dev/null +++ b/docker/install_sipnet.sh @@ -0,0 +1,27 @@ +echo "######################################################################" +echo "SIPNET" +echo "######################################################################" +if [ ! -e ${HOME}/sipnet_unk ]; then + cd + curl -o sipnet_unk.tar.gz http://isda.ncsa.illinois.edu/~kooper/PEcAn/models/sipnet_unk.tar.gz + tar zxf sipnet_unk.tar.gz + rm sipnet_unk.tar.gz +fi +cd ${HOME}/sipnet_unk/ +make clean +make +sudo cp sipnet /usr/local/bin/sipnet.runk +make clean + +if [ ! -e ${HOME}/sipnet_r136 ]; then + cd + curl -o sipnet_r136.tar.gz http://isda.ncsa.illinois.edu/~kooper/EBI/sipnet_r136.tar.gz + tar zxf sipnet_r136.tar.gz + rm sipnet_r136.tar.gz + sed -i 's#$(LD) $(LIBLINKS) \(.*\)#$(LD) \1 $(LIBLINKS)#' ${HOME}/sipnet_r136/Makefile +fi +cd ${HOME}/sipnet_r136/ +make clean +make +sudo cp sipnet /usr/local/bin/sipnet.r136 +make clean diff --git a/docker/setup_postgresql.sh b/docker/setup_postgresql.sh new file mode 100644 index 00000000000..3e0250a3263 --- /dev/null +++ b/docker/setup_postgresql.sh @@ -0,0 +1,43 @@ +echo "######################################################################" +echo "POSTGRES" +echo "######################################################################" +# ADD export PATH=${PATH}:/usr/pgsql-9.5/bin +# ADD exclude=postgresql* to /etc/yum.repos.d/CentOS-Base.repo or /etc/yum/pluginconf.d/rhnplugin.conf +# SEE https://wiki.postgresql.org/wiki/YUM_Installation#Configure_your_YUM_repository +case "$OS_VERSION" in + RH_5) + echo "No PostgreSQL configuration (yet) for RedHat 5" + exit 1 + ;; + RH_6) + sudo service postgresql-9.5 initdb + sudo sh -c 'if ! grep -Fq "bety" /var/lib/pgsql/9.5/data/pg_hba.conf ; then + sed -i "/# TYPE/ a\ +local all bety trust\n\ +host all bety 127.0.0.1/32 trust\n\ +host all bety ::1/128 trust" /var/lib/pgsql/9.5/data/pg_hba.conf + fi' + chkconfig postgresql-9.5 on + sudo service postgresql-9.5 start + ;; + RH_7) + sudo /usr/pgsql-9.5/bin/postgresql95-setup initdb + sudo sh -c 'if ! grep -Fq "bety" /var/lib/pgsql/9.5/data/pg_hba.conf ; then + sed -i "/# TYPE/ a\ +local all bety trust\n\ +host all bety 127.0.0.1/32 trust\n\ +host all bety ::1/128 trust" /var/lib/pgsql/9.5/data/pg_hba.conf + fi' + sudo systemctl enable postgresql-9.5.service + sudo systemctl start postgresql-9.5.service + ;; + Ubuntu) + sudo sh -c 'if ! grep -Fq "bety" /etc/postgresql/9.5/main/pg_hba.conf ; then + sed -i "/# TYPE/ a\ +local all bety trust\n\ +host all bety 127.0.0.1/32 trust\n\ +host all bety ::1/128 trust" /etc/postgresql/9.5/main/pg_hba.conf +fi' + sudo service postgresql restart + ;; +esac From ae0da51e6655af64baa3df6515a524fee9ceb1ea Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sun, 11 Jun 2017 11:06:25 -0500 Subject: [PATCH 022/771] Code formatting related comments. Adding action button to ui --- shiny/workflowPlot/server.R | 47 +++++++++++-------------------------- shiny/workflowPlot/ui.R | 2 ++ 2 files changed, 16 insertions(+), 33 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 06307552dcd..75d2864988e 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -102,22 +102,24 @@ server <- shinyServer(function(input, output, session) { dates <- as.Date(dates) vals <- if(is.na(vals)) y[b] else c(vals, y[b]) xlab <- "Time" + # Not required to change xlab by ranges. Using ggplotly. # xlab <- if (is.null(ranges$x)) "Time" else paste(ranges$x, collapse=" - ") valuesDF <- data.frame(dates,vals) metaDF <- data.frame(workflow_id,run_id,title,xlab,ylab,var_name) + # Populating metaDF as same length of values DF # metaDF1<-metaDF[rep(seq_len(nrow(valuesDF))),] - currentDF = cbind(valuesDF,metaDF) - globalDF<-rbind(globalDF,currentDF) + currentDF <- cbind(valuesDF,metaDF) + globalDF <- rbind(globalDF,currentDF) } ncdf4::nc_close(nc) } } } } - globalDF$title = as.character(globalDF$title) - globalDF$xlab = as.character(globalDF$xlab) - globalDF$ylab = as.character(globalDF$ylab) - globalDF$var_name = as.character(globalDF$var_name) + globalDF$title <- as.character(globalDF$title) + globalDF$xlab <- as.character(globalDF$xlab) + globalDF$ylab <- as.character(globalDF$ylab) + globalDF$var_name <- as.character(globalDF$var_name) return(globalDF) }) output$outputPlot <- renderPlotly({ @@ -153,7 +155,7 @@ server <- shinyServer(function(input, output, session) { # dates <- as.Date(dates) # df <- data.frame(dates, vals) # df <- workFlowData(input$workflow_id,input$run_id,input$variable_names) - masterDF<-workFlowData() + masterDF <- workFlowData() output$info1 <- renderText({ paste0(nrow(masterDF)) }) @@ -162,17 +164,17 @@ server <- shinyServer(function(input, output, session) { need(input$run_id, 'Run id detected'), need(input$variable_name, 'Please wait! Loading data') ) - masterDF$var_name = as.character(masterDF$var_name) + masterDF$var_name <- as.character(masterDF$var_name) # masterDF$var_name = as.factor(masterDF$var_name) # df1<-subset(masterDF,var_name==var_name) - df<-masterDF %>% + df <- masterDF %>% dplyr::filter(workflow_id == input$workflow_id & run_id == input$run_id & var_name == input$variable_name) %>% dplyr::select(dates,vals) - title<-unique(df$title)[1] - xlab<-unique(df$xlab)[1] - ylab<-unique(df$ylab)[1] + title <- unique(df$title)[1] + xlab <- unique(df$xlab)[1] + ylab <- unique(df$ylab)[1] output$info2 <- renderText({ paste0(nrow(df)) # paste0(typeof(title)) @@ -207,26 +209,5 @@ server <- shinyServer(function(input, output, session) { # Shiny server closes here }) -# global_df<-data.frame() -# for(variable in var_names){ -# local_df<-data.frame() -# for(file in files){ -# nc <-nc_open(file) -# var <- ncdf4::ncatt_get(nc, var_name) -# #sw <- if ('Swdown' %in% names(nc$var)) ncdf4::ncvar_get(nc, 'Swdown') else TRUE -# sw <- TRUE -# title <- var$long_name -# ylab <- var$units -# x <- ncdays2date(ncdf4::ncvar_get(nc, 'time'), ncdf4::ncatt_get(nc, 'time')) -# y <- ncdf4::ncvar_get(nc, var_name) -# b <- !is.na(x) & !is.na(y) & sw != 0 -# dates <- if(is.na(dates)) x[b] else c(dates, x[b]) -# vals <- if(is.na(vals)) y[b] else c(vals, y[b]) -# local_df<-rbind(local_df,data.frame(dates,vals,title,ylab,variable)) -# } -# global_df<-rbind(global_df,local_df) -# } - # runApp(port=6480, launch.browser=FALSE) - # runApp(port=5658, launch.browser=FALSE) diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 7cc7ba427ac..644a820fb35 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -10,7 +10,9 @@ ui <- shinyUI(fluidPage( sidebarPanel( selectInput("workflow_id", "Workflow ID", c()), selectInput("run_id", "Run ID", c()), + actionButton("go", "Load Data"), selectInput("variable_name", "Variable Name", "") + # selectInput("workflow_id", "Workflow ID", c(99000000077)), # selectInput("run_id", "Run ID", c(99000000002)), # selectInput("variable_name", "Variable Name", c("AutoResp","GPP")) From 8151d89b81d03b7184a9fd0436a26f71ad7b2513 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Mon, 12 Jun 2017 10:41:24 -0500 Subject: [PATCH 023/771] Multiple workflow and run ids --- shiny/workflowPlot/server.R | 69 ++++++++++++++++++++++++++++++------- shiny/workflowPlot/ui.R | 9 +++-- 2 files changed, 64 insertions(+), 14 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 75d2864988e..b3d1ccf901f 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -15,28 +15,73 @@ server <- shinyServer(function(input, output, session) { ranges <- reactiveValues(x = NULL, y = NULL) print("RESTART") # set the workflow id(s) - ids <- get_workflow_ids(bety, session) - # updateSelectizeInput(session, "workflow_id", choices=ids) - observe({ - updateSelectizeInput(session, "workflow_id", choices=ids) - }) + # Retrieving all workflow ids. + # Creating a new function here so that we wont have to modify the original one. + # Ideally the get_workflow_ids function in db/R/query.dplyr.R should take a flag to check + # if we want to load all workflow ids. + get_all_workflow_ids <- function(bety) { + ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% + .[["workflow_id"]] %>% sort(decreasing = TRUE) + return(ids) + } + # get_workflow_ids + ids <- get_all_workflow_ids(bety) + # ids <- get_all_workflow_ids(bety, session) + updateSelectizeInput(session, "workflow_id", choices=ids) + # Removing observe here as we want to load workflow ids first + # observe({ + # updateSelectizeInput(session, "workflow_id", choices=ids) + # }) workflow_id <- reactive({ req(input$workflow_id) workflow_id <- input$workflow_id }) # update the run_ids if user changes workflow - run_ids <- reactive(get_run_ids(bety, workflow_id())) + # run_ids <- reactive(get_run_ids(bety, workflow_id())) + run_ids <- reactive({ + w_ids <- input$workflow_id + run_id_list <- c() + for(w_id in w_ids){ + r_ids <- get_run_ids(bety, w_id) + for(r_id in r_ids){ + list_item <- paste0('workflow ',w_id,', run ',r_id) + run_id_list <- c(run_id_list,list_item) + } + } + return(run_id_list) + }) + parse_workflowID_runID_from_input <- function(run_id_string){ + id_list <- c() + split_string <- strsplit(run_id_string,',')[[1]] + # run_id_string: 'workflow' workflow_ID, 'run' run_id + wID <- as.numeric(strsplit(split_string[1],' ')[[1]][2]) + runID <- as.numeric(strsplit(split_string[2],' ')[[1]][2]) + id_list <- c(id_list,wID) + id_list <- c(id_list,runID) + # c(workflow_id,run_id) + return(id_list) + } observe({ updateSelectizeInput(session, "run_id", choices=run_ids()) }) # update variables if user changes run + get_var_names_for_ID <- function(bety,wID,runID){ + var_names <- get_var_names(bety, wID, runID) + return(var_names) + } var_names <- reactive({ - run_ids <- get_run_ids(bety, workflow_id()) - var_names <- get_var_names(bety, workflow_id(), run_ids[1]) + # run_ids <- get_run_ids(bety, workflow_id()) + # var_names <- get_var_names(bety, workflow_id(), run_ids[1]) # Removing the variables "Year" and "FracJulianDay" from the Variable Name input in the app - removeVarNames <- c('Year','FracJulianDay') - var_names <-var_names[!var_names %in% removeVarNames] - return(var_names) + + # run_ids <- input$run_id[1] + # # for(rID in run_ids){ + # id_list <- parse_workflowID_runID_from_input(run_ids) + # # var_names <- get_var_names_for_ID(bety,id_list[1],id_list[2]) + # # # } + # removeVarNames <- c('Year','FracJulianDay') + # var_names <-var_names[!var_names %in% removeVarNames] + # return(id_list) }) observe({ updateSelectizeInput(session, "variable_name", choices=var_names()) @@ -63,7 +108,7 @@ server <- shinyServer(function(input, output, session) { # ,session$clientData$url_search) # paste0("x=", input$plot_dblclick$x, "\ny=", input$plot_dblclick$y) }) - workFlowData <-reactive({ + workFlowData <-eventReactive(input$go,{ # workflow_id = 99000000077 # run_id = 99000000002 # var_name = var_names diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 644a820fb35..739b17be01b 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -8,9 +8,14 @@ ui <- shinyUI(fluidPage( sidebarLayout( sidebarPanel( - selectInput("workflow_id", "Workflow ID", c()), - selectInput("run_id", "Run ID", c()), + # helpText(), + p("Please select the workflow ID to continue. You can select multiple IDs"), + selectizeInput("workflow_id", "Mutliple Workflow IDs", c(),multiple=TRUE), + p("Please select the run ID. You can select multiple IDs"), + selectizeInput("run_id", "Mutliple Run IDs", c(),multiple=TRUE), actionButton("go", "Load Data"), + selectInput("workflow_id_selected", "Workflow ID", c()), + selectInput("run_id_selected", "Run ID", c()), selectInput("variable_name", "Variable Name", "") # selectInput("workflow_id", "Workflow ID", c(99000000077)), From b171ff5756f4ed874028c64d07dccb678b3b7314 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Tue, 13 Jun 2017 19:21:42 +0530 Subject: [PATCH 024/771] Removed the exposed port from the Dockerfile Removed the exposed port 80 and 22 as they were not needed as of now --- Dockerfile | 6 ------ 1 file changed, 6 deletions(-) diff --git a/Dockerfile b/Dockerfile index c4698cff828..7106d144857 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,12 +1,6 @@ FROM ubuntu:16.04 MAINTAINER Aman Kumar (ak47su30ac@gmail.com) -# expose port 80 for the web interface -EXPOSE 80 - -# expose port 22 for ssh maintance -EXPOSE 22 - # updated ppa's RUN echo "deb http://cran.rstudio.com/bin/linux/ubuntu xenial/" > /etc/apt/sources.list.d/R.list &&\ apt-key adv --keyserver keyserver.ubuntu.com --recv-keys E084DAB9 From 5e79026eedc8f4bb2d087e392fcdb49892f7b3d0 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Tue, 13 Jun 2017 20:51:59 +0530 Subject: [PATCH 025/771] Minor fixes modified: docker-compose.yml --- docker-compose.yml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/docker-compose.yml b/docker-compose.yml index 5f4c6bcd798..e38529fe6fd 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -5,8 +5,8 @@ networks: driver: bridge services: - postgresql: - image: 'postgres:latest' + postgres: + image: 'mdillon/postgis:9.6' networks: - net1 ports: @@ -18,10 +18,12 @@ services: - net1 ports: - '3000:3000' + link: + - postgres:pg pecan-image: depends_on: - - postgresql + - postgres - bety build: context: . From 9e3815d1e8455192b8c046c321491d19b50e0d4b Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 14 Jun 2017 22:38:36 +0530 Subject: [PATCH 026/771] Removed pecan web codes from the core Removed the pecan web codes from the core in docker/install_pecan.sh Renamed the pecan-image to pecan-core in docker-compose.yml --- docker-compose.yml | 4 +--- docker/install_pecan.sh | 24 ------------------------ 2 files changed, 1 insertion(+), 27 deletions(-) diff --git a/docker-compose.yml b/docker-compose.yml index e38529fe6fd..c9e8a0198d9 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -21,7 +21,7 @@ services: link: - postgres:pg - pecan-image: + pecan-core: depends_on: - postgres - bety @@ -32,7 +32,5 @@ services: - net1 ports: - '8787:8787' - - '22:22' - - '80:80' volumes: - /home/skywalker/pecandata:/pecandata diff --git a/docker/install_pecan.sh b/docker/install_pecan.sh index ffd6a30c128..a56ef18f1cd 100644 --- a/docker/install_pecan.sh +++ b/docker/install_pecan.sh @@ -12,27 +12,3 @@ fi cd ${HOME}/pecan git pull make - - curl -o /var/www/html/pecan.pdf https://www.gitbook.com/download/pdf/book/pecan/pecan-documentation - rm /var/www/html/index.html - ln -s ${HOME}/pecan/documentation/index_vm.html /var/www/html/index.html -if [ ! -e ${HOME}/pecan/web/config.php ]; then - sed -e "s#browndog_url=.*#browndog_url=\"${BROWNDOG_URL}\";#" \ - -e "s#browndog_username=.*#browndog_username=\"${BROWNDOG_USERNAME}\";#" \ - -e "s#browndog_password=.*#browndog_password=\"${BROWNDOG_PASSWORD}\";#" \ - -e "s#googleMapKey=.*#googleMapKey=\"${GOOGLE_MAP_KEY}\";#" \ - -e "s/carya/$USER/g" ${HOME}/pecan/web/config.example.php > ${HOME}/pecan/web/config.php -fi - -if [ ! -e ${HTTP_CONF}/pecan.conf ]; then - cat > /tmp/pecan.conf << EOF -Alias /pecan ${HOME}/pecan/web - - DirectoryIndex index.php - Options +ExecCGI - Require all granted - -EOF - cp /tmp/pecan.conf ${HTTP_CONF}/pecan.conf - rm /tmp/pecan.conf -fi From 3b6b0caab6831e5dee7d6baccefd69e4b0b771cd Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 14 Jun 2017 23:08:10 +0530 Subject: [PATCH 027/771] Removed the pecan-web installation packages Removed the pecan-web installation packages to reduce the size of the image Typo fix in docker-compose.yml --- docker-compose.yml | 2 +- docker/install_packages.sh | 2 +- docker/install_pecan_preprocessor.sh | 26 +++++++++++++------------- 3 files changed, 15 insertions(+), 15 deletions(-) diff --git a/docker-compose.yml b/docker-compose.yml index c9e8a0198d9..0be09c4d9af 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -18,7 +18,7 @@ services: - net1 ports: - '3000:3000' - link: + links: - postgres:pg pecan-core: diff --git a/docker/install_packages.sh b/docker/install_packages.sh index a89e4110e02..c665a887caf 100644 --- a/docker/install_packages.sh +++ b/docker/install_packages.sh @@ -80,7 +80,7 @@ case "$OS_VERSION" in # for PostgreSQL # apt-get -y install libdbd-pgsql postgresql-9.5 postgresql-client-9.5 libpq-dev postgresql-9.5-postgis-2.2 postgresql-9.5-postgis-scripts # for web gui - apt-get -y install apache2 libapache2-mod-php7.0 php7.0 libapache2-mod-passenger php7.0-xml php-ssh2 php7.0-pgsql + # apt-get -y install apache2 libapache2-mod-php7.0 php7.0 libapache2-mod-passenger php7.0-xml php-ssh2 php7.0-pgsql # Ubuntu 14.04 php5-pgsql libapache2-mod-php5 php5 and no php-xml ;; esac diff --git a/docker/install_pecan_preprocessor.sh b/docker/install_pecan_preprocessor.sh index c92a67378a1..e53311b38ad 100644 --- a/docker/install_pecan_preprocessor.sh +++ b/docker/install_pecan_preprocessor.sh @@ -8,11 +8,11 @@ set -e #fi # configuration -BROWNDOG_URL="http://dap.ncsa.illinois.edu:8184/convert/"; -BROWNDOG_USERNAME=""; -BROWNDOG_PASSWORD=""; - -GOOGLE_MAP_KEY="" +# BROWNDOG_URL="http://dap.ncsa.illinois.edu:8184/convert/"; +# BROWNDOG_USERNAME=""; +# BROWNDOG_PASSWORD=""; +# +# GOOGLE_MAP_KEY="" #SETUP_VM="" #SETUP_PALEON="" @@ -26,11 +26,11 @@ if [ -e $(dirname $0)/install_pecan.config ]; then . $(dirname $0)/install_pecan.config fi -if [ -e /etc/redhat-release ]; then - OS_VERSION="RH_$( sed -r 's/.* ([0-9]+)\..*/\1/' /etc/redhat-release )" - HTTP_CONF="/etc/httpd/conf.d/" - chmod o+x ${HOME} -else - OS_VERSION="Ubuntu" - HTTP_CONF="/etc/apache2/conf-available/" -fi +# if [ -e /etc/redhat-release ]; then +# OS_VERSION="RH_$( sed -r 's/.* ([0-9]+)\..*/\1/' /etc/redhat-release )" +# HTTP_CONF="/etc/httpd/conf.d/" +# chmod o+x ${HOME} +# else +# OS_VERSION="Ubuntu" +# HTTP_CONF="/etc/apache2/conf-available/" +# fi From 04198245c9cd0a43414cdedd84d07dfe1a074a82 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 14 Jun 2017 23:17:14 +0530 Subject: [PATCH 028/771] hard coded to git clone the repo not to pull even if present --- docker/install_pecan.sh | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/docker/install_pecan.sh b/docker/install_pecan.sh index a56ef18f1cd..43528dc6399 100644 --- a/docker/install_pecan.sh +++ b/docker/install_pecan.sh @@ -5,10 +5,6 @@ echo "######################################################################" echo "PECAN" echo "######################################################################" -if [ ! -e ${HOME}/pecan ]; then - cd - git clone https://github.com/PecanProject/pecan.git -fi -cd ${HOME}/pecan -git pull +git clone https://github.com/PecanProject/pecan.git +cd pecan/ make From 85e902de4ba5f943deb8f83985aee21d8af9ecd4 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 14 Jun 2017 23:22:22 +0530 Subject: [PATCH 029/771] Added OS version --- docker/install_pecan_preprocessor.sh | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/docker/install_pecan_preprocessor.sh b/docker/install_pecan_preprocessor.sh index e53311b38ad..60b62c1810d 100644 --- a/docker/install_pecan_preprocessor.sh +++ b/docker/install_pecan_preprocessor.sh @@ -26,11 +26,11 @@ if [ -e $(dirname $0)/install_pecan.config ]; then . $(dirname $0)/install_pecan.config fi -# if [ -e /etc/redhat-release ]; then -# OS_VERSION="RH_$( sed -r 's/.* ([0-9]+)\..*/\1/' /etc/redhat-release )" -# HTTP_CONF="/etc/httpd/conf.d/" -# chmod o+x ${HOME} -# else -# OS_VERSION="Ubuntu" -# HTTP_CONF="/etc/apache2/conf-available/" -# fi +if [ -e /etc/redhat-release ]; then + OS_VERSION="RH_$( sed -r 's/.* ([0-9]+)\..*/\1/' /etc/redhat-release )" + HTTP_CONF="/etc/httpd/conf.d/" + chmod o+x ${HOME} +else + OS_VERSION="Ubuntu" + HTTP_CONF="/etc/apache2/conf-available/" +fi From 1fb2695281a71f1d1cd6b918b7a036eb79b2cb99 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Fri, 16 Jun 2017 10:50:34 +0530 Subject: [PATCH 030/771] Minor fix in install_pecan.sh Added depends_on bety service in docker-compose.yml --- docker-compose.yml | 2 ++ docker/install_pecan.sh | 9 +++++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/docker-compose.yml b/docker-compose.yml index 0be09c4d9af..c4d4c2eb6c9 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -13,6 +13,8 @@ services: - '5432:5432' bety: + depends_on: + - postgres image: 'pecan/bety:latest' networks: - net1 diff --git a/docker/install_pecan.sh b/docker/install_pecan.sh index 43528dc6399..e848c17ff93 100644 --- a/docker/install_pecan.sh +++ b/docker/install_pecan.sh @@ -5,6 +5,11 @@ echo "######################################################################" echo "PECAN" echo "######################################################################" -git clone https://github.com/PecanProject/pecan.git -cd pecan/ +if [ ! -e ${HOME}/pecan ]; then + cd + git clone https://github.com/PecanProject/pecan.git +fi +cd ${HOME}/pecan +git pull +mkdir .install make From 241a36381798e30eadae5c74967e136681805adf Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Fri, 16 Jun 2017 19:57:51 +0530 Subject: [PATCH 031/771] Added web gui Added Dockerfile_pecan_web to generate the web gui also added docker/install_pecan_web.sh as script to install the web gui --- Dockerfile_pecan_web | 23 +++++++++++++++++++ docker/install_pecan_web.sh | 46 +++++++++++++++++++++++++++++++++++++ 2 files changed, 69 insertions(+) create mode 100644 Dockerfile_pecan_web create mode 100644 docker/install_pecan_web.sh diff --git a/Dockerfile_pecan_web b/Dockerfile_pecan_web new file mode 100644 index 00000000000..a098331f034 --- /dev/null +++ b/Dockerfile_pecan_web @@ -0,0 +1,23 @@ +FROM amanskywalker/pecan-dev:latest +MAINTAINER Aman Kumar (ak47su30ac@gmail.com) + +# copy the installation script inside the container +ADD docker/ /build + +# Set script mod +x for preprocessors +RUN chmod 750 /build/*.sh + +# Run the OS System setup script +RUN /build/system_services.sh + +# run update machine to update machine +RUN /build/update_machine.sh + +# install pecan web +RUN /build/install_pecan_web.sh + +# Clean up APT when done. +RUN apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* /build/* + +# startup +CMD ["/sbin/my_init"] diff --git a/docker/install_pecan_web.sh b/docker/install_pecan_web.sh new file mode 100644 index 00000000000..666d2917d7c --- /dev/null +++ b/docker/install_pecan_web.sh @@ -0,0 +1,46 @@ +#!/bin/bash + +. /build/install_pecan_preprocessor.sh + +echo "######################################################################" +echo "PECAN-WEB" +echo "######################################################################" + +#configuration + +BROWNDOG_URL="http://dap.ncsa.illinois.edu:8184/convert/"; +BROWNDOG_USERNAME=""; +BROWNDOG_PASSWORD=""; + +GOOGLE_MAP_KEY="" + +echo "Intalling php and apache2" + +# for web gui +apt-get -y install apache2 libapache2-mod-php7.0 php7.0 libapache2-mod-passenger php7.0-xml php-ssh2 php7.0-pgsql + +echo "Setting up web gui" +sudo curl -o /var/www/html/pecan.pdf https://www.gitbook.com/download/pdf/book/pecan/pecan-documentation +sudo rm /var/www/html/index.html +sudo ln -s ${HOME}/pecan/documentation/index_vm.html /var/www/html/index.html + +if [ ! -e ${HOME}/pecan/web/config.php ]; then + sed -e "s#browndog_url=.*#browndog_url=\"${BROWNDOG_URL}\";#" \ + -e "s#browndog_username=.*#browndog_username=\"${BROWNDOG_USERNAME}\";#" \ + -e "s#browndog_password=.*#browndog_password=\"${BROWNDOG_PASSWORD}\";#" \ + -e "s#googleMapKey=.*#googleMapKey=\"${GOOGLE_MAP_KEY}\";#" \ + -e "s/carya/$USER/g" ${HOME}/pecan/web/config.example.php > ${HOME}/pecan/web/config.php +fi + +if [ ! -e ${HTTP_CONF}/pecan.conf ]; then + cat > /tmp/pecan.conf << EOF +Alias /pecan ${HOME}/pecan/web + + DirectoryIndex index.php + Options +ExecCGI + Require all granted + +EOF + sudo cp /tmp/pecan.conf ${HTTP_CONF}/pecan.conf + rm /tmp/pecan.conf +fi From 2a6f3c522b15abf9a05ba13ec90595cd3ea2ee20 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sat, 17 Jun 2017 08:09:26 -0500 Subject: [PATCH 032/771] UI related changes. Working on server.R --- shiny/workflowPlot/server.R | 124 ++++++++++++++++++------------------ shiny/workflowPlot/ui.R | 12 ++-- 2 files changed, 68 insertions(+), 68 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index b3d1ccf901f..52d6df8f8ef 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -20,8 +20,8 @@ server <- shinyServer(function(input, output, session) { # Ideally the get_workflow_ids function in db/R/query.dplyr.R should take a flag to check # if we want to load all workflow ids. get_all_workflow_ids <- function(bety) { - ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% - .[["workflow_id"]] %>% sort(decreasing = TRUE) + ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% + .[["workflow_id"]] %>% sort(decreasing = TRUE) return(ids) } # get_workflow_ids @@ -70,18 +70,18 @@ server <- shinyServer(function(input, output, session) { return(var_names) } var_names <- reactive({ - # run_ids <- get_run_ids(bety, workflow_id()) - # var_names <- get_var_names(bety, workflow_id(), run_ids[1]) - # Removing the variables "Year" and "FracJulianDay" from the Variable Name input in the app - - # run_ids <- input$run_id[1] - # # for(rID in run_ids){ - # id_list <- parse_workflowID_runID_from_input(run_ids) - # # var_names <- get_var_names_for_ID(bety,id_list[1],id_list[2]) - # # # } - # removeVarNames <- c('Year','FracJulianDay') - # var_names <-var_names[!var_names %in% removeVarNames] - # return(id_list) + # run_ids <- get_run_ids(bety, workflow_id()) + # var_names <- get_var_names(bety, workflow_id(), run_ids[1]) + # Removing the variables "Year" and "FracJulianDay" from the Variable Name input in the app + + # run_ids <- input$run_id[1] + # # for(rID in run_ids){ + # id_list <- parse_workflowID_runID_from_input(run_ids) + # # var_names <- get_var_names_for_ID(bety,id_list[1],id_list[2]) + # # # } + # removeVarNames <- c('Year','FracJulianDay') + # var_names <-var_names[!var_names %in% removeVarNames] + # return(id_list) }) observe({ updateSelectizeInput(session, "variable_name", choices=var_names()) @@ -199,59 +199,59 @@ server <- shinyServer(function(input, output, session) { # print(ranges$x) # dates <- as.Date(dates) # df <- data.frame(dates, vals) - # df <- workFlowData(input$workflow_id,input$run_id,input$variable_names) - masterDF <- workFlowData() - output$info1 <- renderText({ - paste0(nrow(masterDF)) - }) - validate( - need(input$workflow_id, 'Found workflow id'), - need(input$run_id, 'Run id detected'), - need(input$variable_name, 'Please wait! Loading data') - ) - masterDF$var_name <- as.character(masterDF$var_name) - # masterDF$var_name = as.factor(masterDF$var_name) - # df1<-subset(masterDF,var_name==var_name) - df <- masterDF %>% - dplyr::filter(workflow_id == input$workflow_id & + # df <- workFlowData(input$workflow_id,input$run_id,input$variable_names) + masterDF <- workFlowData() + output$info1 <- renderText({ + paste0(nrow(masterDF)) + }) + validate( + need(input$workflow_id, 'Found workflow id'), + need(input$run_id, 'Run id detected'), + need(input$variable_name, 'Please wait! Loading data') + ) + masterDF$var_name <- as.character(masterDF$var_name) + # masterDF$var_name = as.factor(masterDF$var_name) + # df1<-subset(masterDF,var_name==var_name) + df <- masterDF %>% + dplyr::filter(workflow_id == input$workflow_id & run_id == input$run_id & var_name == input$variable_name) %>% - dplyr::select(dates,vals) - title <- unique(df$title)[1] - xlab <- unique(df$xlab)[1] - ylab <- unique(df$ylab)[1] - output$info2 <- renderText({ - paste0(nrow(df)) - # paste0(typeof(title)) - }) - output$info3 <- renderText({ - paste0('xlab') - # paste0(typeof(title)) - }) - - # df1<-masterDF %>% filter(masterDF$var_name %in% var_name) - # workflow_id %in% workflow_id) - # & run_id == run_id & var_name == var_name) - # df<-masterDF %>% dplyr::filter(workflow_id == input$workflow_id) - plt <- ggplot(df, aes(x=dates, y=vals)) + - # geom_point(aes(color="Model output")) + - geom_point() + -# geom_smooth(aes(fill = "Spline fit")) + - # coord_cartesian(xlim = ranges$x, ylim = ranges$y) + - # scale_y_continuous(labels=fancy_scientific) + - labs(title=title, x=xlab, y=ylab) + - # labs(title=unique(df$title)[1], x=unique(df$xlab)[1], y=unique(df$ylab)[1]) + - scale_color_manual(name = "", values = "black") + - scale_fill_manual(name = "", values = "grey50") - # theme(axis.text.x = element_text(angle = -90)) - plt<-ggplotly(plt) - # plot(plt) - # add_icon() + dplyr::select(dates,vals) + title <- unique(df$title)[1] + xlab <- unique(df$xlab)[1] + ylab <- unique(df$ylab)[1] + output$info2 <- renderText({ + paste0(nrow(df)) + # paste0(typeof(title)) + }) + output$info3 <- renderText({ + paste0('xlab') + # paste0(typeof(title)) + }) + + # df1<-masterDF %>% filter(masterDF$var_name %in% var_name) + # workflow_id %in% workflow_id) + # & run_id == run_id & var_name == var_name) + # df<-masterDF %>% dplyr::filter(workflow_id == input$workflow_id) + plt <- ggplot(df, aes(x=dates, y=vals)) + + # geom_point(aes(color="Model output")) + + geom_point() + + # geom_smooth(aes(fill = "Spline fit")) + + # coord_cartesian(xlim = ranges$x, ylim = ranges$y) + + # scale_y_continuous(labels=fancy_scientific) + + labs(title=title, x=xlab, y=ylab) + + # labs(title=unique(df$title)[1], x=unique(df$xlab)[1], y=unique(df$ylab)[1]) + + scale_color_manual(name = "", values = "black") + + scale_fill_manual(name = "", values = "grey50") + # theme(axis.text.x = element_text(angle = -90)) + plt<-ggplotly(plt) + # plot(plt) + # add_icon() # } # } }) - -# Shiny server closes here + + # Shiny server closes here }) # runApp(port=6480, launch.browser=FALSE) diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 739b17be01b..cc2880bb7b2 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -5,7 +5,7 @@ source('helper.R') ui <- shinyUI(fluidPage( # Application title titlePanel("Workflow Plots"), - + sidebarLayout( sidebarPanel( # helpText(), @@ -24,11 +24,11 @@ ui <- shinyUI(fluidPage( ), mainPanel( plotlyOutput("outputPlot" - ## brushOpts and dblclick not supported by plotly - # brush = brushOpts(id = "plot_brush", - # resetOnNew = TRUE), - # dblclick = "plot_dblclick" - ), + ## brushOpts and dblclick not supported by plotly + # brush = brushOpts(id = "plot_brush", + # resetOnNew = TRUE), + # dblclick = "plot_dblclick" + ), # Checking variable names verbatimTextOutput("info"), verbatimTextOutput("info1"), From 50cb285b73402d06d5e892cc317e1cbeb7bdaf52 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 17 Jun 2017 20:16:10 +0530 Subject: [PATCH 033/771] Added override for HOME variable and Few web codes --- docker/install_packages.sh | 1 + docker/install_pecan_preprocessor.sh | 4 ++++ docker/install_pecan_web.sh | 12 ++++++++---- docker/install_sipnet.sh | 4 ++++ 4 files changed, 17 insertions(+), 4 deletions(-) diff --git a/docker/install_packages.sh b/docker/install_packages.sh index c665a887caf..6379e8a9ecd 100644 --- a/docker/install_packages.sh +++ b/docker/install_packages.sh @@ -79,6 +79,7 @@ case "$OS_VERSION" in apt-get -y install cmake # for PostgreSQL # apt-get -y install libdbd-pgsql postgresql-9.5 postgresql-client-9.5 libpq-dev postgresql-9.5-postgis-2.2 postgresql-9.5-postgis-scripts + apt-get -y install postgresql-client-9.4 # for web gui # apt-get -y install apache2 libapache2-mod-php7.0 php7.0 libapache2-mod-passenger php7.0-xml php-ssh2 php7.0-pgsql # Ubuntu 14.04 php5-pgsql libapache2-mod-php5 php5 and no php-xml diff --git a/docker/install_pecan_preprocessor.sh b/docker/install_pecan_preprocessor.sh index 60b62c1810d..d629d880fb3 100644 --- a/docker/install_pecan_preprocessor.sh +++ b/docker/install_pecan_preprocessor.sh @@ -7,6 +7,10 @@ set -e # exit -1 #fi +# overiding environment variables + +export HOME='/home/carya/' + # configuration # BROWNDOG_URL="http://dap.ncsa.illinois.edu:8184/convert/"; # BROWNDOG_USERNAME=""; diff --git a/docker/install_pecan_web.sh b/docker/install_pecan_web.sh index 666d2917d7c..fb45bb3be5d 100644 --- a/docker/install_pecan_web.sh +++ b/docker/install_pecan_web.sh @@ -20,9 +20,9 @@ echo "Intalling php and apache2" apt-get -y install apache2 libapache2-mod-php7.0 php7.0 libapache2-mod-passenger php7.0-xml php-ssh2 php7.0-pgsql echo "Setting up web gui" -sudo curl -o /var/www/html/pecan.pdf https://www.gitbook.com/download/pdf/book/pecan/pecan-documentation -sudo rm /var/www/html/index.html -sudo ln -s ${HOME}/pecan/documentation/index_vm.html /var/www/html/index.html +curl -o /var/www/html/pecan.pdf https://www.gitbook.com/download/pdf/book/pecan/pecan-documentation +rm /var/www/html/index.html +ln -s ${HOME}/pecan/documentation/index_vm.html /var/www/html/index.html if [ ! -e ${HOME}/pecan/web/config.php ]; then sed -e "s#browndog_url=.*#browndog_url=\"${BROWNDOG_URL}\";#" \ @@ -41,6 +41,10 @@ Alias /pecan ${HOME}/pecan/web Require all granted EOF - sudo cp /tmp/pecan.conf ${HTTP_CONF}/pecan.conf + cp /tmp/pecan.conf ${HTTP_CONF}/pecan.conf rm /tmp/pecan.conf fi + +a2enconf pecan.conf + +services apache2 restart diff --git a/docker/install_sipnet.sh b/docker/install_sipnet.sh index 2034f81a9f5..2417c41aad0 100644 --- a/docker/install_sipnet.sh +++ b/docker/install_sipnet.sh @@ -1,3 +1,7 @@ + + +. /build/install_pecan_preprocessor.sh + echo "######################################################################" echo "SIPNET" echo "######################################################################" From c1009c2abb927cef91224ab901926eac7477cb24 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 17 Jun 2017 20:38:15 +0530 Subject: [PATCH 034/771] Moved Pecan Web Dockerfile into docker dir --- Dockerfile_pecan_web => docker/Dockerfile | 0 docker/install_packages.sh | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) rename Dockerfile_pecan_web => docker/Dockerfile (100%) diff --git a/Dockerfile_pecan_web b/docker/Dockerfile similarity index 100% rename from Dockerfile_pecan_web rename to docker/Dockerfile diff --git a/docker/install_packages.sh b/docker/install_packages.sh index 6379e8a9ecd..6ece1b32631 100644 --- a/docker/install_packages.sh +++ b/docker/install_packages.sh @@ -79,7 +79,7 @@ case "$OS_VERSION" in apt-get -y install cmake # for PostgreSQL # apt-get -y install libdbd-pgsql postgresql-9.5 postgresql-client-9.5 libpq-dev postgresql-9.5-postgis-2.2 postgresql-9.5-postgis-scripts - apt-get -y install postgresql-client-9.4 + apt-get -y install postgresql-client-9.5 # for web gui # apt-get -y install apache2 libapache2-mod-php7.0 php7.0 libapache2-mod-passenger php7.0-xml php-ssh2 php7.0-pgsql # Ubuntu 14.04 php5-pgsql libapache2-mod-php5 php5 and no php-xml From cf5297cea0de2bc003ee8b6c2594172b542b4e85 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 17 Jun 2017 21:23:46 +0530 Subject: [PATCH 035/771] minor fixes in various files in docker/ --- docker/Dockerfile | 2 +- docker/install_pecan_preprocessor.sh | 2 +- docker/update_machine.sh | 7 +++++-- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/docker/Dockerfile b/docker/Dockerfile index a098331f034..d386dd9a5b9 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -2,7 +2,7 @@ FROM amanskywalker/pecan-dev:latest MAINTAINER Aman Kumar (ak47su30ac@gmail.com) # copy the installation script inside the container -ADD docker/ /build +ADD . /build # Set script mod +x for preprocessors RUN chmod 750 /build/*.sh diff --git a/docker/install_pecan_preprocessor.sh b/docker/install_pecan_preprocessor.sh index d629d880fb3..0f715370898 100644 --- a/docker/install_pecan_preprocessor.sh +++ b/docker/install_pecan_preprocessor.sh @@ -9,7 +9,7 @@ set -e # overiding environment variables -export HOME='/home/carya/' +export HOME='/home/carya' # configuration # BROWNDOG_URL="http://dap.ncsa.illinois.edu:8184/convert/"; diff --git a/docker/update_machine.sh b/docker/update_machine.sh index 4f7709df5ef..ebbde9bba6b 100644 --- a/docker/update_machine.sh +++ b/docker/update_machine.sh @@ -6,8 +6,11 @@ echo "######################################################################" echo "UPDATING MACHINE" echo "######################################################################" -mkdir /home/carya/ -chmod 755 /home/carya/ +if [ ! -e /home/carya/ ]; then + mkdir /home/carya/ + chmod 755 /home/carya/ +fi + case "$OS_VERSION" in RH_*) yum update -y From 5820a8993fe7d66761db734acf2895932cc1e9df Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 17 Jun 2017 22:42:55 +0530 Subject: [PATCH 036/771] Added scripts for the apache to keep running in background --- docker/Dockerfile | 11 +++++++++++ docker/apache2/runserver.sh | 3 +++ docker/apache2/startup.sh | 11 +++++++++++ docker/install_pecan_web.sh | 2 +- 4 files changed, 26 insertions(+), 1 deletion(-) create mode 100644 docker/apache2/runserver.sh create mode 100644 docker/apache2/startup.sh diff --git a/docker/Dockerfile b/docker/Dockerfile index d386dd9a5b9..043b6bf1c27 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -1,3 +1,4 @@ +# Dockerfile for the pecan web FROM amanskywalker/pecan-dev:latest MAINTAINER Aman Kumar (ak47su30ac@gmail.com) @@ -16,6 +17,16 @@ RUN /build/update_machine.sh # install pecan web RUN /build/install_pecan_web.sh +# simple scripts to do the startup task +RUN mkdir -p /etc/my_init.d +COPY /build/apache2/startup.sh /etc/my_init.d/startup.sh +RUN chmod +x /etc/my_init.d/startup.sh + +# adding demons of apache2 +RUN mkdir -p /etc/service/rserver ; sync +COPY /build/apache2/runserver.sh /etc/service/rserver/run +RUN chmod +x /etc/service/rserver/run \ + # Clean up APT when done. RUN apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* /build/* diff --git a/docker/apache2/runserver.sh b/docker/apache2/runserver.sh new file mode 100644 index 00000000000..3c111a74640 --- /dev/null +++ b/docker/apache2/runserver.sh @@ -0,0 +1,3 @@ +#!/bin/sh + +exec chpst -u root /usr/sbin/apache2 -DFOREGROUND off 2>&1 diff --git a/docker/apache2/startup.sh b/docker/apache2/startup.sh new file mode 100644 index 00000000000..ca232920ba2 --- /dev/null +++ b/docker/apache2/startup.sh @@ -0,0 +1,11 @@ +#!/bin/bash + +set -e + +if [ -f /etc/configured ]; then + echo 'already configured' +else + #code that need to run only one time .... + update-locale + date > /etc/configured +fi diff --git a/docker/install_pecan_web.sh b/docker/install_pecan_web.sh index fb45bb3be5d..6f749e8bb53 100644 --- a/docker/install_pecan_web.sh +++ b/docker/install_pecan_web.sh @@ -47,4 +47,4 @@ fi a2enconf pecan.conf -services apache2 restart +/etc/init.d/apache2 restart From fc3472f92be156a8c9a1ed1ac6f4dc0a42948481 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 17 Jun 2017 23:00:30 +0530 Subject: [PATCH 037/771] Minor fixes --- docker/Dockerfile | 6 +++--- docker/apache2/runserver.sh | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/docker/Dockerfile b/docker/Dockerfile index 043b6bf1c27..63f3cbc130f 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -19,13 +19,13 @@ RUN /build/install_pecan_web.sh # simple scripts to do the startup task RUN mkdir -p /etc/my_init.d -COPY /build/apache2/startup.sh /etc/my_init.d/startup.sh +COPY apache2/startup.sh /etc/my_init.d/startup.sh RUN chmod +x /etc/my_init.d/startup.sh # adding demons of apache2 RUN mkdir -p /etc/service/rserver ; sync -COPY /build/apache2/runserver.sh /etc/service/rserver/run -RUN chmod +x /etc/service/rserver/run \ +COPY apache2/runserver.sh /etc/service/rserver/run +RUN chmod +x /etc/service/rserver/run # Clean up APT when done. RUN apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* /build/* diff --git a/docker/apache2/runserver.sh b/docker/apache2/runserver.sh index 3c111a74640..008a2465425 100644 --- a/docker/apache2/runserver.sh +++ b/docker/apache2/runserver.sh @@ -1,3 +1,3 @@ #!/bin/sh -exec chpst -u root /usr/sbin/apache2 -DFOREGROUND off 2>&1 +exec /etc/init.d/apache2 start From 25dbb08070627332439e4171ce608cb4245276a6 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sat, 17 Jun 2017 19:13:56 -0500 Subject: [PATCH 038/771] Updating query.dplyr.R. Multiple selection server.R and ui.R --- db/R/query.dplyr.R | 5 +- shiny/workflowPlot/server.R | 194 ++++++++++++++++++++---------------- shiny/workflowPlot/ui.R | 10 +- 3 files changed, 115 insertions(+), 94 deletions(-) diff --git a/db/R/query.dplyr.R b/db/R/query.dplyr.R index 18c52d7cd16..5c36256a99b 100644 --- a/db/R/query.dplyr.R +++ b/db/R/query.dplyr.R @@ -134,9 +134,10 @@ runs <- function(bety, workflow_id) { #' @inheritParams dbHostInfo #' @param session Session object passed through Shiny #' @export -get_workflow_ids <- function(bety, session) { +get_workflow_ids <- function(bety, session,all.ids=FALSE) { query <- isolate(parseQueryString(session$clientData$url_search)) - if ("workflow_id" %in% names(query)) { + # If we dont want all workflow ids but only workflow id from the user url query + if (!all.ids & "workflow_id" %in% names(query)) { ids <- unlist(query[names(query) == "workflow_id"], use.names = FALSE) } else { # Get all workflow IDs diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 52d6df8f8ef..1dc303523c5 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -12,107 +12,159 @@ server <- shinyServer(function(input, output, session) { # options(shiny.trace=TRUE) bety <- betyConnect() # bety <- betyConnect('/home/carya/pecan/web/config.php') - ranges <- reactiveValues(x = NULL, y = NULL) + # Ranges not required. + # ranges <- reactiveValues(x = NULL, y = NULL) print("RESTART") # set the workflow id(s) # Retrieving all workflow ids. # Creating a new function here so that we wont have to modify the original one. # Ideally the get_workflow_ids function in db/R/query.dplyr.R should take a flag to check # if we want to load all workflow ids. - get_all_workflow_ids <- function(bety) { - ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% - .[["workflow_id"]] %>% sort(decreasing = TRUE) - return(ids) - } + # get_all_workflow_ids <- function(bety) { + # ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% + # .[["workflow_id"]] %>% sort(decreasing = TRUE) + # return(ids) + # } # get_workflow_ids - ids <- get_all_workflow_ids(bety) + # ids <- get_all_workflow_ids(bety) # ids <- get_all_workflow_ids(bety, session) - updateSelectizeInput(session, "workflow_id", choices=ids) - # Removing observe here as we want to load workflow ids first - # observe({ - # updateSelectizeInput(session, "workflow_id", choices=ids) - # }) - workflow_id <- reactive({ - req(input$workflow_id) - workflow_id <- input$workflow_id + # Get all workflow ids + # Using this function here for now. + get_workflow_ids_all <- function(bety, session,all.ids=FALSE) { + query <- isolate(parseQueryString(session$clientData$url_search)) + # If we dont want all workflow ids but only workflow id from the user url query + if (!all.ids & "workflow_id" %in% names(query)) { + ids <- unlist(query[names(query) == "workflow_id"], use.names = FALSE) + } else { + # Get all workflow IDs + ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% + .[["workflow_id"]] %>% sort(decreasing = TRUE) + } + return(ids) + } # get_workflow_ids + + # Update all workflow ids + observe({ + # get_workflow_id function from query.dplyr.R + all_ids <- get_workflow_ids_all(bety, session,all.ids=TRUE) + updateSelectizeInput(session, "all_workflow_id", choices=all_ids) }) - # update the run_ids if user changes workflow - # run_ids <- reactive(get_run_ids(bety, workflow_id())) - run_ids <- reactive({ - w_ids <- input$workflow_id + # Retrieves all run ids for seleted workflow ids + # Returns ('workflow ',w_id,', run ',r_id) + all_run_ids <- reactive({ + req(input$all_workflow_id) + w_ids <- input$all_workflow_id run_id_list <- c() for(w_id in w_ids){ r_ids <- get_run_ids(bety, w_id) for(r_id in r_ids){ - list_item <- paste0('workflow ',w_id,', run ',r_id) + # . as a separator between multiple run ids + list_item <- paste0('workflow ',w_id,', run ',r_id, ';') run_id_list <- c(run_id_list,list_item) } } return(run_id_list) }) - parse_workflowID_runID_from_input <- function(run_id_string){ - id_list <- c() - split_string <- strsplit(run_id_string,',')[[1]] - # run_id_string: 'workflow' workflow_ID, 'run' run_id - wID <- as.numeric(strsplit(split_string[1],' ')[[1]][2]) - runID <- as.numeric(strsplit(split_string[2],' ')[[1]][2]) - id_list <- c(id_list,wID) - id_list <- c(id_list,runID) - # c(workflow_id,run_id) - return(id_list) - } + # Update all run_ids ('workflow ',w_id,', run ',r_id) + observe({ + updateSelectizeInput(session, "all_run_id", choices=all_run_ids()) + }) + # Update on load: workflow id for selected run ids (models) + observe({ + if(input$load){ + req(input$all_workflow_id) + # Selected `multiple' ids + selected_id <- strsplit(input$all_workflow_id,' ') + # To allow caching + display_id <- selected_id + updateSelectizeInput(session, "workflow_id", choices=display_id) + } else{ + session_workflow_id <- get_workflow_ids_all(bety, session) + updateSelectizeInput(session, "workflow_id", choices=session_workflow_id) + } + }) + # Update run id for selected workflow id (model) + run_ids <- reactive({ + req(input$workflow_id) + get_run_ids(bety, input$workflow_id) + }) observe({ updateSelectizeInput(session, "run_id", choices=run_ids()) }) - # update variables if user changes run - get_var_names_for_ID <- function(bety,wID,runID){ - var_names <- get_var_names(bety, wID, runID) - return(var_names) + parse_ids_from_input_runID <- function(run_id_string){ + id_list <- c() + split_diff_ids <- strsplit(run_id_string,';')[[1]] + # run_id_string: 'workflow' workflow_ID, 'run' run_id + for(diff_ids in split_diff_ids){ + split_string <- strsplit(diff_ids,',')[[1]] + wID <- as.numeric(strsplit(trimws(split_string[1],which = c("both")),' ')[[1]][2]) + runID <- as.numeric(strsplit(trimws(split_string[2],which = c("both")),' ')[[1]][2]) + ids <- list(wID,runID) + } + id_list <- c(id_list,ids) + return(id_list) } + # Update variables if user changes run + # get_var_names_for_ID <- function(bety,wID,runID){ + # var_names <- get_var_names(bety, wID, runID) + # return(var_names) + # } var_names <- reactive({ # run_ids <- get_run_ids(bety, workflow_id()) # var_names <- get_var_names(bety, workflow_id(), run_ids[1]) # Removing the variables "Year" and "FracJulianDay" from the Variable Name input in the app + req(input$workflow_id,input$run_id) + workflow_id <- input$workflow_id + run_id <- input$run_id + var_names <- get_var_names(bety, workflow_id, run_id) - # run_ids <- input$run_id[1] # # for(rID in run_ids){ # id_list <- parse_workflowID_runID_from_input(run_ids) # # var_names <- get_var_names_for_ID(bety,id_list[1],id_list[2]) # # # } - # removeVarNames <- c('Year','FracJulianDay') - # var_names <-var_names[!var_names %in% removeVarNames] + removeVarNames <- c('Year','FracJulianDay') + var_names <-var_names[!var_names %in% removeVarNames] + return(var_names) # return(id_list) }) observe({ updateSelectizeInput(session, "variable_name", choices=var_names()) }) - observe({ - ignore <- input$variable_name - ranges$x <- NULL - ranges$y <- NULL - }) - observeEvent(input$plot_dblclick, { - brush <- input$plot_brush - if (!is.null(brush)) { - ranges$x <- as.POSIXct(c(brush$xmin, brush$xmax), origin = "1970-01-01", tz = "UTC") - ranges$y <- c(brush$ymin, brush$ymax) - } else { - ranges$x <- NULL - ranges$y <- NULL - } - }) + # observe({ + # ignore <- input$variable_name + # ranges$x <- NULL + # ranges$y <- NULL + # }) + # observeEvent(input$plot_dblclick, { + # brush <- input$plot_brush + # if (!is.null(brush)) { + # ranges$x <- as.POSIXct(c(brush$xmin, brush$xmax), origin = "1970-01-01", tz = "UTC") + # ranges$y <- c(brush$ymin, brush$ymax) + # } else { + # ranges$x <- NULL + # ranges$y <- NULL + # } + # }) # If want to render text output$info <- renderText({ - paste0(input$variable_name) + # indicators <- strsplit(input$indicators, ",")[[1]] + + # if(input$load){ + # all_workflow_id <- strsplit(input$all_workflow_id,',') + # } + # d <- typeof(all_workflow_id) + paste0(input$all_run_id) + # paste0(input$variable_name) # paste0(run_ids(),length(run_ids()),ids) # ,session$clientData$url_search) # paste0("x=", input$plot_dblclick$x, "\ny=", input$plot_dblclick$y) }) - workFlowData <-eventReactive(input$go,{ + workFlowData <-eventReactive(input$load,{ # workflow_id = 99000000077 # run_id = 99000000002 # var_name = var_names globalDF <- data.frame() + ids for(workflow_id in ids){ run_ids <- get_run_ids(bety,workflow_id) for(run_id in run_ids){ @@ -168,38 +220,6 @@ server <- shinyServer(function(input, output, session) { return(globalDF) }) output$outputPlot <- renderPlotly({ - # workflow_id <- isolate(input$workflow_id) - # run_id <- isolate(input$run_id) - # var_name <- input$variable_name - # if (workflow_id != "" && run_id != "" && var_name != "") { - # workflow <- collect(workflow(bety, workflow_id)) - # if(nrow(workflow) > 0) { - # outputfolder <- file.path(workflow$folder, 'out', run_id) - # files <- list.files(outputfolder, "*.nc$", full.names=TRUE) - # dates <- NA - # vals <- NA - # title <- var_name - # ylab <- "" - # for(file in files) { - # nc <- nc_open(file) - # var <- ncdf4::ncatt_get(nc, var_name) - # #sw <- if ('Swdown' %in% names(nc$var)) ncdf4::ncvar_get(nc, 'Swdown') else TRUE - # sw <- TRUE - # title <- var$long_name - # ylab <- var$units - # x <- ncdays2date(ncdf4::ncvar_get(nc, 'time'), ncdf4::ncatt_get(nc, 'time')) - # y <- ncdf4::ncvar_get(nc, var_name) - # b <- !is.na(x) & !is.na(y) & sw != 0 - # dates <- if(is.na(dates)) x[b] else c(dates, x[b]) - # vals <- if(is.na(vals)) y[b] else c(vals, y[b]) - # ncdf4::nc_close(nc) - # } - # xlab <- if (is.null(ranges$x)) "Time" else paste(ranges$x, collapse=" - ") - # # plot result - # print(ranges$x) - # dates <- as.Date(dates) - # df <- data.frame(dates, vals) - # df <- workFlowData(input$workflow_id,input$run_id,input$variable_names) masterDF <- workFlowData() output$info1 <- renderText({ paste0(nrow(masterDF)) diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index cc2880bb7b2..b7b938b43bb 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -10,12 +10,12 @@ ui <- shinyUI(fluidPage( sidebarPanel( # helpText(), p("Please select the workflow ID to continue. You can select multiple IDs"), - selectizeInput("workflow_id", "Mutliple Workflow IDs", c(),multiple=TRUE), + selectizeInput("all_workflow_id", "Mutliple Workflow IDs", c(),multiple=TRUE), p("Please select the run ID. You can select multiple IDs"), - selectizeInput("run_id", "Mutliple Run IDs", c(),multiple=TRUE), - actionButton("go", "Load Data"), - selectInput("workflow_id_selected", "Workflow ID", c()), - selectInput("run_id_selected", "Run ID", c()), + selectizeInput("all_run_id", "Mutliple Run IDs", c(),multiple=TRUE), + actionButton("load", "Load Data"), + selectInput("workflow_id", "Workflow ID", c()), + selectInput("run_id", "Run ID", c()), selectInput("variable_name", "Variable Name", "") # selectInput("workflow_id", "Workflow ID", c(99000000077)), From 5bfa5afe5a10d4b7d52d680590f4c84be770189c Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sun, 18 Jun 2017 23:17:36 +0530 Subject: [PATCH 039/771] Added pecan-web image in docker-compose Added a new web config file to set the pecan web configuration at build time --- docker-compose.yml | 51 +++++++++++++--- docker/web/config.docker.php | 114 +++++++++++++++++++++++++++++++++++ 2 files changed, 157 insertions(+), 8 deletions(-) create mode 100644 docker/web/config.docker.php diff --git a/docker-compose.yml b/docker-compose.yml index c4d4c2eb6c9..5f656b5774b 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -6,22 +6,31 @@ networks: services: postgres: - image: 'mdillon/postgis:9.6' + image: 'mdillon/postgis:9.4' networks: - - net1 + net1: + aliases: + - pg ports: - '5432:5432' + environment: + - PGDATA=/var/lib/postgresql/data/pgdata + volumes: + - /home/skywalker/pgdata:/var/lib/postgresql/data/pgdata bety: depends_on: - postgres image: 'pecan/bety:latest' networks: - - net1 + net1: + aliases: + - bety ports: - '3000:3000' - links: - - postgres:pg + environment: + - PG_PORT_5432_TCP_ADDR=pg + - PG_PORT_5432_TCP_PORT=5432 pecan-core: depends_on: @@ -31,8 +40,34 @@ services: context: . dockerfile: Dockerfile networks: - - net1 - ports: - - '8787:8787' + net1: + aliases: + - pecan-core + environment: + - PG_HOST=pg + - PG_PORT=5432 + - PG_USER=bety + - PG_PASSWORD=bety + - PG_DATABASE_NAME=bety volumes: - /home/skywalker/pecandata:/pecandata + +pecan-web: + depends_on: + - postgres + - bety + build: + context: ./docker + dockerfile: Dockerfile + networks: + net1: + aliases: + - pecan-web + environment: + - PG_HOST=pg + - PG_PORT=5432 + - PG_USER=bety + - PG_PASSWORD=bety + - PG_DATABASE_NAME=bety + volumes: + - /home/skywalker/pecandata:/pecandata diff --git a/docker/web/config.docker.php b/docker/web/config.docker.php new file mode 100644 index 00000000000..37f016ce898 --- /dev/null +++ b/docker/web/config.docker.php @@ -0,0 +1,114 @@ + array(), + "geo.bu.edu" => + array("qsub" => "qsub -V -N @NAME@ -o @STDOUT@ -e @STDERR@ -S /bin/bash", + "jobid" => "Your job ([0-9]+) .*", + "qstat" => "qstat -j @JOBID@ || echo DONE", + "prerun" => "module load udunits R/R-3.0.0_gnu-4.4.6", + "postrun" => "sleep 60", + "models" => array("ED2" => + array("prerun" => "module load hdf5")))); + +# Folder where PEcAn is installed +$R_library_path="/home/carya/R/library"; + +# Location where PEcAn is installed, not really needed anymore +$pecan_home="/home/carya/pecan/"; + +# Folder where the runs are stored +$output_folder="/home/carya/output/"; + +# Folder where the generated files are stored +$dbfiles_folder=$output_folder . "/dbfiles"; + +# location of BETY DB set to empty to not create links, can be both +# relative or absolute paths or full URL's. Should point to the base +# of BETYDB +$betydb="/bety"; + +# ---------------------------------------------------------------------- +# SIMPLE EDITING OF BETY DATABSE +# ---------------------------------------------------------------------- +# Number of items to show on a page +$pagesize = 30; + +# Location where logs should be written +$logfile = "/home/carya/output/betydb.log"; + +# uncomment the following variable to enable the simple interface +#$simpleBETY = TRUE; + + +?> From 89ced0fdc53627eab6cfb97503b6eb1cd381d018 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sun, 18 Jun 2017 23:20:57 +0530 Subject: [PATCH 040/771] Added web configuration for the image to setup at build time --- docker/Dockerfile | 2 ++ 1 file changed, 2 insertions(+) diff --git a/docker/Dockerfile b/docker/Dockerfile index 63f3cbc130f..5226796b0a8 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -27,6 +27,8 @@ RUN mkdir -p /etc/service/rserver ; sync COPY apache2/runserver.sh /etc/service/rserver/run RUN chmod +x /etc/service/rserver/run +# add the pecan-web configuration +COPY web/config.docker.php /home/carya/pecan/web/config.php # Clean up APT when done. RUN apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* /build/* From f20fbae25f949299edf0e855829c7f5abae3f675 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sun, 18 Jun 2017 23:24:43 +0530 Subject: [PATCH 041/771] intendation fix in docker-compose.yml --- docker-compose.yml | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/docker-compose.yml b/docker-compose.yml index 5f656b5774b..fdb65eba3b6 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -52,22 +52,22 @@ services: volumes: - /home/skywalker/pecandata:/pecandata -pecan-web: - depends_on: - - postgres - - bety - build: - context: ./docker - dockerfile: Dockerfile - networks: - net1: - aliases: - - pecan-web - environment: - - PG_HOST=pg - - PG_PORT=5432 - - PG_USER=bety - - PG_PASSWORD=bety - - PG_DATABASE_NAME=bety - volumes: - - /home/skywalker/pecandata:/pecandata + pecan-web: + depends_on: + - postgres + - bety + build: + context: ./docker + dockerfile: Dockerfile + networks: + net1: + aliases: + - pecan-web + environment: + - PG_HOST=pg + - PG_PORT=5432 + - PG_USER=bety + - PG_PASSWORD=bety + - PG_DATABASE_NAME=bety + volumes: + - /home/skywalker/pecandata:/pecandata From d514254735de9c9eb72157054aa3a9d48c8a8d0e Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Mon, 19 Jun 2017 14:03:27 +0530 Subject: [PATCH 042/771] Added port maping for pecan-web in docker-compose.yml Added script to setup web config --- Dockerfile | 2 +- docker-compose.yml | 2 ++ docker/Dockerfile | 7 ++++--- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/Dockerfile b/Dockerfile index 7106d144857..28c7ece0548 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,5 +1,5 @@ FROM ubuntu:16.04 -MAINTAINER Aman Kumar (ak47su30ac@gmail.com) +MAINTAINER Aman Kumar (ak47su30@gmail.com) # updated ppa's RUN echo "deb http://cran.rstudio.com/bin/linux/ubuntu xenial/" > /etc/apt/sources.list.d/R.list &&\ diff --git a/docker-compose.yml b/docker-compose.yml index fdb65eba3b6..5e0ed4bd695 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -63,6 +63,8 @@ services: net1: aliases: - pecan-web + ports: + - '8080':'80' environment: - PG_HOST=pg - PG_PORT=5432 diff --git a/docker/Dockerfile b/docker/Dockerfile index 5226796b0a8..f94caf4d4e2 100644 --- a/docker/Dockerfile +++ b/docker/Dockerfile @@ -1,6 +1,6 @@ # Dockerfile for the pecan web -FROM amanskywalker/pecan-dev:latest -MAINTAINER Aman Kumar (ak47su30ac@gmail.com) +FROM amanskywalker/pecan-dev:0.1 +MAINTAINER Aman Kumar (ak47su30@gmail.com) # copy the installation script inside the container ADD . /build @@ -28,7 +28,8 @@ COPY apache2/runserver.sh /etc/service/rserver/run RUN chmod +x /etc/service/rserver/run # add the pecan-web configuration -COPY web/config.docker.php /home/carya/pecan/web/config.php +COPY web/config.docker.php /home/carya/pecan/web/config.php + # Clean up APT when done. RUN apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* /build/* From 8023aba533ae4fa275cb28d4d326528e44ac1250 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Mon, 19 Jun 2017 19:56:59 +0530 Subject: [PATCH 043/771] Added image for pecan-core as fallback if build failed in docker-compose.yml --- docker-compose.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/docker-compose.yml b/docker-compose.yml index 5e0ed4bd695..f94c272490d 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -39,6 +39,7 @@ services: build: context: . dockerfile: Dockerfile + image: amanskywalker/pecan-dev:0.1 networks: net1: aliases: From 0579d2b3a92ed9a2169f06ea4a92bfb32f392dc6 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Tue, 20 Jun 2017 19:22:05 +0530 Subject: [PATCH 044/771] Some minor fixes in docker-compose.yml docker/install_sipnet.sh --- docker-compose.yml | 2 +- docker/install_sipnet.sh | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/docker-compose.yml b/docker-compose.yml index f94c272490d..3f087eed7eb 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -65,7 +65,7 @@ services: aliases: - pecan-web ports: - - '8080':'80' + - '8080:80' environment: - PG_HOST=pg - PG_PORT=5432 diff --git a/docker/install_sipnet.sh b/docker/install_sipnet.sh index 2417c41aad0..9bab523b408 100644 --- a/docker/install_sipnet.sh +++ b/docker/install_sipnet.sh @@ -27,5 +27,5 @@ fi cd ${HOME}/sipnet_r136/ make clean make -sudo cp sipnet /usr/local/bin/sipnet.r136 +cp sipnet /usr/local/bin/sipnet.r136 make clean From 836c3ed26606c724fbce18b7e8275a3995e22c4b Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Tue, 20 Jun 2017 15:54:27 -0500 Subject: [PATCH 045/771] Changing load data button to load model outputs --- shiny/workflowPlot/ui.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index b7b938b43bb..a8db281f2bb 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -13,7 +13,7 @@ ui <- shinyUI(fluidPage( selectizeInput("all_workflow_id", "Mutliple Workflow IDs", c(),multiple=TRUE), p("Please select the run ID. You can select multiple IDs"), selectizeInput("all_run_id", "Mutliple Run IDs", c(),multiple=TRUE), - actionButton("load", "Load Data"), + actionButton("load", "Load Model outputs"), selectInput("workflow_id", "Workflow ID", c()), selectInput("run_id", "Run ID", c()), selectInput("variable_name", "Variable Name", "") From cb9e1cf054b15ccaf3195cb05806f16cb6163894 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Tue, 20 Jun 2017 20:14:54 -0500 Subject: [PATCH 046/771] Changes for backend --- shiny/workflowPlot/server.R | 109 ++++++++++++++++++++++++++++-------- 1 file changed, 86 insertions(+), 23 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 1dc303523c5..b725a84eadc 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -59,7 +59,7 @@ server <- shinyServer(function(input, output, session) { r_ids <- get_run_ids(bety, w_id) for(r_id in r_ids){ # . as a separator between multiple run ids - list_item <- paste0('workflow ',w_id,', run ',r_id, ';') + list_item <- paste0('workflow ',w_id,', run ',r_id) run_id_list <- c(run_id_list,list_item) } } @@ -72,38 +72,97 @@ server <- shinyServer(function(input, output, session) { # Update on load: workflow id for selected run ids (models) observe({ if(input$load){ - req(input$all_workflow_id) + req(input$all_run_id) # Selected `multiple' ids - selected_id <- strsplit(input$all_workflow_id,' ') - # To allow caching - display_id <- selected_id + selected_id <- parse_ids_from_input_runID(input$all_run_id)$wID + # To allow caching later + display_id <- c(input$workflow_id,selected_id) updateSelectizeInput(session, "workflow_id", choices=display_id) } else{ session_workflow_id <- get_workflow_ids_all(bety, session) updateSelectizeInput(session, "workflow_id", choices=session_workflow_id) } + + # if(input$load){ + # req(input$all_workflow_id) + # # Selected `multiple' ids + # selected_id <- strsplit(input$all_workflow_id,' ') + # # To allow caching later + # display_id <- selected_id + # updateSelectizeInput(session, "workflow_id", choices=display_id) + # } else{ + # session_workflow_id <- get_workflow_ids_all(bety, session) + # updateSelectizeInput(session, "workflow_id", choices=session_workflow_id) + # } + }) # Update run id for selected workflow id (model) - run_ids <- reactive({ + + observe({ req(input$workflow_id) - get_run_ids(bety, input$workflow_id) + r_ID <- get_run_ids(bety, input$workflow_id) + if(input$load){ + req(input$all_run_id) + # Selected `multiple' ids + ids_DF <- parse_ids_from_input_runID(input$all_run_id) + ids_DF %>% filter(wID %in% input$workflow_id) + # To allow caching later + r_ID <- intersect(r_ID,ids_DF$runID) + } + updateSelectizeInput(session, "run_id", choices=r_ID) }) - observe({ - updateSelectizeInput(session, "run_id", choices=run_ids()) - }) - parse_ids_from_input_runID <- function(run_id_string){ - id_list <- c() - split_diff_ids <- strsplit(run_id_string,';')[[1]] - # run_id_string: 'workflow' workflow_ID, 'run' run_id - for(diff_ids in split_diff_ids){ - split_string <- strsplit(diff_ids,',')[[1]] - wID <- as.numeric(strsplit(trimws(split_string[1],which = c("both")),' ')[[1]][2]) - runID <- as.numeric(strsplit(trimws(split_string[2],which = c("both")),' ')[[1]][2]) - ids <- list(wID,runID) - } - id_list <- c(id_list,ids) - return(id_list) + + + + + # run_ids <- reactive({ + # req(input$workflow_id) + # r_ID <- get_run_ids(bety, input$workflow_id) + # if(input$load){ + # req(input$all_run_id) + # # Selected `multiple' ids + # selected_id <- parse_ids_from_input_runID(input$all_run_id)$wID + # # To allow caching later + # display_id <- c(input$workflow_id,selected_id) + # updateSelectizeInput(session, "workflow_id", choices=display_id) + # } else{ + # session_workflow_id <- get_workflow_ids_all(bety, session) + # updateSelectizeInput(session, "workflow_id", choices=session_workflow_id) + # } + # + # }) + # observe({ + # updateSelectizeInput(session, "run_id", choices=run_ids()) + # }) + return_DF_from_run_ID <- function(diff_ids){ + # Called by the function parse_ids_from_input_runID + # Returns a DF for a particular run_id + # print(diff_ids) + split_string <- strsplit(diff_ids,',')[[1]] + # Workflow id is the first element. Trim leading and ending white spaces. Split by space now + wID <- as.numeric(strsplit(trimws(split_string[1],which = c("both")),' ')[[1]][2]) + # Run id is the second element + runID <- as.numeric(strsplit(trimws(split_string[2],which = c("both")),' ')[[1]][2]) + return(data.frame(wID,runID)) } + parse_ids_from_input_runID <- function(run_id_list){ + # global_id_DF <- data.frame() + # split_diff_ids <- strsplit(run_id_string,';')[[1]] + # for(diff_ids in split_diff_ids){ + # # run_id_string: 'workflow' workflow_ID, 'run' run_id + # # Split by comma to get workflow and run ids + # + # + globalDF <- data.frame() + for(w_run_id in run_id_list){ + globalDF <- rbind(globalDF,return_DF_from_run_ID(w_run_id)) + } + # split_ids <- lapply(split_diff_ids , function(x) list_workflow_run_id(x)) + # local_id_DF <- data.frame(wID,runID) + # global_id_DF <- rbind(global_id_DF,local_id_DF) + return(globalDF) + } + # } # Update variables if user changes run # get_var_names_for_ID <- function(bety,wID,runID){ # var_names <- get_var_names(bety, wID, runID) @@ -153,7 +212,10 @@ server <- shinyServer(function(input, output, session) { # all_workflow_id <- strsplit(input$all_workflow_id,',') # } # d <- typeof(all_workflow_id) - paste0(input$all_run_id) + # paste0(input$all_run_id) + + paste0(parse_ids_from_input_runID(input$all_run_id)$wID) + # paste0(input$all_run_id[length(input$all_run_id)]) # paste0(input$variable_name) # paste0(run_ids(),length(run_ids()),ids) # ,session$clientData$url_search) @@ -224,6 +286,7 @@ server <- shinyServer(function(input, output, session) { output$info1 <- renderText({ paste0(nrow(masterDF)) }) + # Error messages validate( need(input$workflow_id, 'Found workflow id'), need(input$run_id, 'Run id detected'), From c51eee9482d924047bf801619f5c53b84173bd09 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 21 Jun 2017 15:05:35 +0530 Subject: [PATCH 047/771] Minor fix in docker/web/config.docker.php --- docker/web/config.docker.php | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/docker/web/config.docker.php b/docker/web/config.docker.php index 37f016ce898..46e3900378d 100644 --- a/docker/web/config.docker.php +++ b/docker/web/config.docker.php @@ -2,11 +2,26 @@ # Information to connect to the BETY database $db_bety_type="pgsql"; -$db_bety_hostname=getenv('PG_HOST'); -$db_bety_port=getenv('PG_PORT'); -$db_bety_username=getenv('PG_USER'); -$db_bety_password=getenv('PG_PASSWORD'); -$db_bety_database=getenv('PG_DATABASE_NAME'); +$db_bety_hostname="pg"; +$db_bety_port="5432"; +$db_bety_username="postgres"; +$db_bety_password="bety"; +$db_bety_database="bety"; + +// under development code to get the data from the environment variables +// $db_bety_hostname=getenv('PG_HOST'); +// $db_bety_port=getenv('PG_PORT'); +// $db_bety_username=getenv('PG_USER'); +// $db_bety_password=getenv('PG_PASSWORD'); +// $db_bety_database=getenv('PG_DATABASE_NAME'); + +# use only for debuging +#var_dump($db_bety_type); +#var_dump($db_bety_hostname); +#var_dump($db_bety_port); +#var_dump($db_bety_username); +#var_dump($db_bety_password); +#var_dump($db_bety_database); # Information to connect to the FIA database # leave this blank if you do not have the FIA database installed. @@ -28,7 +43,7 @@ $SSHtunnel=dirname(__FILE__) . DIRECTORY_SEPARATOR . "sshtunnel.sh"; # google map key -$googleMapKey=""; +$googleMapKey="AIzaSyDBBrRM8Ygo-wGAnubrtVGZklK3bmXlUPI"; # Require username/password, can set min level to 0 so nobody can run/delete. # 4 = viewer From 78e26feaae72cb6d6b3c01928a875d9740143c70 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Wed, 21 Jun 2017 04:41:25 -0500 Subject: [PATCH 048/771] Working demo. Caching not done yet --- shiny/workflowPlot/server.R | 141 +++++++++++++++++------------------- 1 file changed, 68 insertions(+), 73 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index b725a84eadc..8188df3822a 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -82,19 +82,6 @@ server <- shinyServer(function(input, output, session) { session_workflow_id <- get_workflow_ids_all(bety, session) updateSelectizeInput(session, "workflow_id", choices=session_workflow_id) } - - # if(input$load){ - # req(input$all_workflow_id) - # # Selected `multiple' ids - # selected_id <- strsplit(input$all_workflow_id,' ') - # # To allow caching later - # display_id <- selected_id - # updateSelectizeInput(session, "workflow_id", choices=display_id) - # } else{ - # session_workflow_id <- get_workflow_ids_all(bety, session) - # updateSelectizeInput(session, "workflow_id", choices=session_workflow_id) - # } - }) # Update run id for selected workflow id (model) @@ -111,10 +98,6 @@ server <- shinyServer(function(input, output, session) { } updateSelectizeInput(session, "run_id", choices=r_ID) }) - - - - # run_ids <- reactive({ # req(input$workflow_id) # r_ID <- get_run_ids(bety, input$workflow_id) @@ -129,7 +112,6 @@ server <- shinyServer(function(input, output, session) { # session_workflow_id <- get_workflow_ids_all(bety, session) # updateSelectizeInput(session, "workflow_id", choices=session_workflow_id) # } - # # }) # observe({ # updateSelectizeInput(session, "run_id", choices=run_ids()) @@ -168,6 +150,7 @@ server <- shinyServer(function(input, output, session) { # var_names <- get_var_names(bety, wID, runID) # return(var_names) # } + var_names <- reactive({ # run_ids <- get_run_ids(bety, workflow_id()) # var_names <- get_var_names(bety, workflow_id(), run_ids[1]) @@ -176,11 +159,6 @@ server <- shinyServer(function(input, output, session) { workflow_id <- input$workflow_id run_id <- input$run_id var_names <- get_var_names(bety, workflow_id, run_id) - - # # for(rID in run_ids){ - # id_list <- parse_workflowID_runID_from_input(run_ids) - # # var_names <- get_var_names_for_ID(bety,id_list[1],id_list[2]) - # # # } removeVarNames <- c('Year','FracJulianDay') var_names <-var_names[!var_names %in% removeVarNames] return(var_names) @@ -215,64 +193,56 @@ server <- shinyServer(function(input, output, session) { # paste0(input$all_run_id) paste0(parse_ids_from_input_runID(input$all_run_id)$wID) + # paste0(input$load) # paste0(input$all_run_id[length(input$all_run_id)]) # paste0(input$variable_name) # paste0(run_ids(),length(run_ids()),ids) # ,session$clientData$url_search) # paste0("x=", input$plot_dblclick$x, "\ny=", input$plot_dblclick$y) }) - workFlowData <-eventReactive(input$load,{ - # workflow_id = 99000000077 - # run_id = 99000000002 - # var_name = var_names + + load_data_single_run <- function(workflow_id,run_id){ globalDF <- data.frame() - ids - for(workflow_id in ids){ - run_ids <- get_run_ids(bety,workflow_id) - for(run_id in run_ids){ - var_names <- get_var_names(bety, workflow_id, run_id) - removeVarNames <- c('Year','FracJulianDay') - var_names <-var_names[!var_names %in% removeVarNames] - # if (workflow_id != "" && run_id != "" && var_name != "") { - workflow <- collect(workflow(bety, workflow_id)) - if(nrow(workflow) > 0) { - outputfolder <- file.path(workflow$folder, 'out', run_id) - files <- list.files(outputfolder, "*.nc$", full.names=TRUE) - for(file in files) { - nc <- nc_open(file) - for(var_name in var_names){ - dates <- NA - vals <- NA - title <- var_name - ylab <- "" - var <- ncdf4::ncatt_get(nc, var_name) - #sw <- if ('Swdown' %in% names(nc$var)) ncdf4::ncvar_get(nc, 'Swdown') else TRUE - sw <- TRUE - if(!is.null(var$long_name)){ - title <- var$long_name - } - if(!is.null(var$units)){ - ylab <- var$units - } - x <- ncdays2date(ncdf4::ncvar_get(nc, 'time'), ncdf4::ncatt_get(nc, 'time')) - y <- ncdf4::ncvar_get(nc, var_name) - b <- !is.na(x) & !is.na(y) & sw != 0 - dates <- if(is.na(dates)) x[b] else c(dates, x[b]) - dates <- as.Date(dates) - vals <- if(is.na(vals)) y[b] else c(vals, y[b]) - xlab <- "Time" - # Not required to change xlab by ranges. Using ggplotly. - # xlab <- if (is.null(ranges$x)) "Time" else paste(ranges$x, collapse=" - ") - valuesDF <- data.frame(dates,vals) - metaDF <- data.frame(workflow_id,run_id,title,xlab,ylab,var_name) - # Populating metaDF as same length of values DF - # metaDF1<-metaDF[rep(seq_len(nrow(valuesDF))),] - currentDF <- cbind(valuesDF,metaDF) - globalDF <- rbind(globalDF,currentDF) - } - ncdf4::nc_close(nc) + workflow <- collect(workflow(bety, workflow_id)) + var_names <- get_var_names(bety, workflow_id, run_id) + removeVarNames <- c('Year','FracJulianDay') + var_names <-var_names[!var_names %in% removeVarNames] + if(nrow(workflow) > 0) { + outputfolder <- file.path(workflow$folder, 'out', run_id) + files <- list.files(outputfolder, "*.nc$", full.names=TRUE) + for(file in files) { + nc <- nc_open(file) + for(var_name in var_names){ + dates <- NA + vals <- NA + title <- var_name + ylab <- "" + var <- ncdf4::ncatt_get(nc, var_name) + #sw <- if ('Swdown' %in% names(nc$var)) ncdf4::ncvar_get(nc, 'Swdown') else TRUE + sw <- TRUE + if(!is.null(var$long_name)){ + title <- var$long_name } + if(!is.null(var$units)){ + ylab <- var$units + } + x <- ncdays2date(ncdf4::ncvar_get(nc, 'time'), ncdf4::ncatt_get(nc, 'time')) + y <- ncdf4::ncvar_get(nc, var_name) + b <- !is.na(x) & !is.na(y) & sw != 0 + dates <- if(is.na(dates)) x[b] else c(dates, x[b]) + dates <- as.Date(dates) + vals <- if(is.na(vals)) y[b] else c(vals, y[b]) + xlab <- "Time" + # Not required to change xlab by ranges. Using ggplotly. + # xlab <- if (is.null(ranges$x)) "Time" else paste(ranges$x, collapse=" - ") + valuesDF <- data.frame(dates,vals) + metaDF <- data.frame(workflow_id,run_id,title,xlab,ylab,var_name) + # Populating metaDF as same length of values DF + # metaDF1<-metaDF[rep(seq_len(nrow(valuesDF))),] + currentDF <- cbind(valuesDF,metaDF) + globalDF <- rbind(globalDF,currentDF) } + ncdf4::nc_close(nc) } } globalDF$title <- as.character(globalDF$title) @@ -280,9 +250,34 @@ server <- shinyServer(function(input, output, session) { globalDF$ylab <- as.character(globalDF$ylab) globalDF$var_name <- as.character(globalDF$var_name) return(globalDF) + } + + + + loadNewData <-eventReactive(input$load,{ + # workflow_id = 99000000077 + # run_id = 99000000002 + # var_name = var_names + req(input$all_run_id) + globalDF <- data.frame() + ids_DF <- parse_ids_from_input_runID(input$all_run_id) + for(i in nrow(ids_DF)){ + globalDF <- rbind(globalDF, load_data_single_run(ids_DF$wID[i],ids_DF$runID[i])) + } + return(globalDF) + # for(workflow_id in ids){ + # run_ids <- get_run_ids(bety,workflow_id) + # for(run_id in run_ids){ + # var_names <- get_var_names(bety, workflow_id, run_id) + # removeVarNames <- c('Year','FracJulianDay') + # var_names <-var_names[!var_names %in% removeVarNames] + # # if (workflow_id != "" && run_id != "" && var_name != "") { + # } + # } }) output$outputPlot <- renderPlotly({ - masterDF <- workFlowData() + masterDF <- load_data_single_run(input$workflow_id,input$run_id) + masterDF <- rbind(masterDF,loadNewData()) output$info1 <- renderText({ paste0(nrow(masterDF)) }) From 7130b9ee05f895c0ad61f93d6cf6448fd3a35504 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 21 Jun 2017 19:52:17 +0530 Subject: [PATCH 049/771] Minor fix Removed sudo from docker/install_sipnet.sh --- docker/install_sipnet.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/docker/install_sipnet.sh b/docker/install_sipnet.sh index 9bab523b408..cd251803cd7 100644 --- a/docker/install_sipnet.sh +++ b/docker/install_sipnet.sh @@ -14,7 +14,7 @@ fi cd ${HOME}/sipnet_unk/ make clean make -sudo cp sipnet /usr/local/bin/sipnet.runk +cp sipnet /usr/local/bin/sipnet.runk make clean if [ ! -e ${HOME}/sipnet_r136 ]; then From 64acd9dded29f43c6503251e9eaae717f03ba51e Mon Sep 17 00:00:00 2001 From: Ann Raiho Date: Wed, 21 Jun 2017 21:59:08 -0400 Subject: [PATCH 050/771] Changing units and a testing sda.enkf as a function --- models/linkages/R/read_restart.LINKAGES.R | 2 +- models/linkages/R/write_restart.LINKAGES.R | 2 +- models/sipnet/R/read_restart.SIPNET.R | 2 +- models/sipnet/R/write_restart.SIPNET.R | 2 +- .../assim.sequential/R/load_data_paleon_sda.R | 14 +++++------ modules/assim.sequential/R/sda.enkf.R | 13 ++++++---- modules/assim.sequential/inst/paleon_sda.R | 24 ++++++++++++++----- 7 files changed, 37 insertions(+), 22 deletions(-) diff --git a/models/linkages/R/read_restart.LINKAGES.R b/models/linkages/R/read_restart.LINKAGES.R index 81e83c1a1db..54dce1b1761 100644 --- a/models/linkages/R/read_restart.LINKAGES.R +++ b/models/linkages/R/read_restart.LINKAGES.R @@ -42,7 +42,7 @@ read_restart.LINKAGES <- function(outdir, runid, stop.time, settings, var.names forecast <- list() if ("AGB.pft" %in% var.names) { - forecast[[1]] <- udunits2::ud.convert(ens$AGB.pft, "kg/m^2", "Mg/ha") #already has C #* unit.conv + forecast[[1]] <- ens$AGB.pft #already has C #* unit.conv names(forecast[[1]]) <- paste0('AGB.pft.',pft.names) } diff --git a/models/linkages/R/write_restart.LINKAGES.R b/models/linkages/R/write_restart.LINKAGES.R index c1fc9227cdf..0b116ca1d0e 100644 --- a/models/linkages/R/write_restart.LINKAGES.R +++ b/models/linkages/R/write_restart.LINKAGES.R @@ -41,7 +41,7 @@ write_restart.LINKAGES <- function(outdir, runid, start.time, stop.time, setting names.keep <- names(new.state) - new.state <- udunits2::ud.convert(as.matrix(new.state), "Mg/ha", "kg/m^2") + new.state <- as.matrix(new.state) names(new.state) <- names.keep diff --git a/models/sipnet/R/read_restart.SIPNET.R b/models/sipnet/R/read_restart.SIPNET.R index 1725bb70918..413ee154455 100644 --- a/models/sipnet/R/read_restart.SIPNET.R +++ b/models/sipnet/R/read_restart.SIPNET.R @@ -38,7 +38,7 @@ read_restart.SIPNET <- function(outdir, runid, stop.time, settings, var.names, p #### PEcAn Standard Outputs if ("NPP" %in% var.names) { - forecast[[1]] <- udunits2::ud.convert(mean(ens$NPP), "kg/m^2/s", "Mg/ha/yr") #* unit.conv + forecast[[1]] <- mean(ens$NPP) #* unit.conv names(forecast[[1]]) <- c("NPP") } diff --git a/models/sipnet/R/write_restart.SIPNET.R b/models/sipnet/R/write_restart.SIPNET.R index bedd1c34642..acf4c919b16 100644 --- a/models/sipnet/R/write_restart.SIPNET.R +++ b/models/sipnet/R/write_restart.SIPNET.R @@ -50,7 +50,7 @@ write_restart.SIPNET <- function(outdir, runid, start.time, stop.time, settings, analysis.save <- list() if ("NPP" %in% variables) { - analysis.save[[1]] <- new.state$NPP #*unit.conv -> Mg/ha/yr + analysis.save[[1]] <- udunits2::ud.convert(new.state$NPP, "kg/m^2/s", "Mg/ha/yr") #*unit.conv -> Mg/ha/yr names(analysis.save[[1]]) <- c("NPP") } diff --git a/modules/assim.sequential/R/load_data_paleon_sda.R b/modules/assim.sequential/R/load_data_paleon_sda.R index 73bf153fb18..7557d7c0961 100644 --- a/modules/assim.sequential/R/load_data_paleon_sda.R +++ b/modules/assim.sequential/R/load_data_paleon_sda.R @@ -52,7 +52,7 @@ load_data_paleon_sda <- function(settings){ obs.cov <- obs.cov.tmp <- list() obs.times <- seq(as.Date(start_date), as.Date(end_date), by = settings$state.data.assimilation$forecast.time.step) - obs.times <- year(obs.times) + obs.times <- lubridate::year(obs.times) biomass2carbon <- 0.48 @@ -97,9 +97,9 @@ load_data_paleon_sda <- function(settings){ logger.info('Now, mapping data species to model PFTs') dataset$pft.cat <- x[dataset$species_id] - dataset <- dataset[dataset$pft.cat!='NA_AbvGrndWood',] + dataset <- dataset[dataset$pft.cat!='AGB.pft.NA',] - variable <- sub('AGB.pft','AbvGrndWood',variable) + variable <- c('AbvGrndWood') arguments <- list(.(year, MCMC_iteration, site_id, pft.cat), .(variable)) arguments2 <- list(.(year, pft.cat), .(variable)) arguments3 <- list(.(MCMC_iteration), .(pft.cat, variable), .(year)) @@ -118,12 +118,12 @@ load_data_paleon_sda <- function(settings){ cov.test <- apply(iter_mat,3,function(x){cov(x)}) for(t in seq_along(obs.times)){ - obs.mean.tmp[[t]] <- mean_mat[mean_mat[,time.type]==obs.times[t], variable] #THIS WONT WORK IF TIMESTEP ISNT ANNUAL + obs.mean.tmp[[t]] <- mean_mat[mean_mat[,time.type]==obs.times[t], -c(1)] #THIS WONT WORK IF TIMESTEP ISNT ANNUAL if(any(var.names == 'AGB.pft')){ - obs.mean.tmp[[t]] <- rep(NA, length(x)) - names(obs.mean.tmp[[t]]) <- sort(x) - for(r in seq_along(x)){ + obs.mean.tmp[[t]] <- rep(NA, length(unique(dataset$pft.cat))) + names(obs.mean.tmp[[t]]) <- sort(unique(dataset$pft.cat)) + for(r in seq_along(unique(dataset$pft.cat))){ k <- mean_mat[mean_mat$year==obs.times[t] & mean_mat$pft.cat==names(obs.mean.tmp[[t]][r]), variable] if(any(k)){ obs.mean.tmp[[t]][r] <- k diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index d3b4a1c6226..b2ada4c422c 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -206,7 +206,8 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ## start model runs start.model.runs(settings, settings$database$bety$write) - #save.image(file.path(outdir, "sda.initial.runs.Rdata")) + save(list = ls(envir = environment(), all.names = TRUE), + file = file.path(outdir, "sda.initial.runs.Rdata"), envir = environment()) ###-------------------------------------------------------------------### ### tests before data assimilation ### @@ -336,7 +337,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ###-------------------------------------------------------------------### ### loop over time ### ###-------------------------------------------------------------------### - for (t in seq_len(nt)) {# + for (t in 1:2) {# ###-------------------------------------------------------------------### ### read restart ### @@ -377,8 +378,10 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { choose <- na.omit(charmatch(colnames(X),names(obs.mean[[t]]))) Y <- unlist(obs.mean[[t]][choose]) + Y[is.na(Y)] <- 0 R <- as.matrix(obs.cov[[t]][choose,choose]) + R[is.na(R)]<-0 if (length(obs.mean[[t]]) > 1) { for (s in seq_along(obs.mean[[t]])) { @@ -459,7 +462,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # H[i, i] <- 1/sum(mu.f) #? this seems to get us on the right track. mu.f[i]/sum(mu.f) doesn't work. # } ## process error - if (exists("Q")) { + if (!is.null(Q)) { Pf <- Pf + Q } ## Kalman Gain @@ -604,7 +607,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { constants.tobit = list(N = ncol(X), YN = length(y.ind)) #, nc = 1 dimensions.tobit = list(X = ncol(X), X.mod = ncol(X), Q = c(ncol(X),ncol(X))) # b = dim(inits.pred$b), - data.tobit = list(muf = as.vector(mu.f), pf = Pf, aq = aqq[t,,], bq = bqq[t], + data.tobit = list(muf = as.vector(mu.f), pf = solve(Pf), aq = aqq[t,,], bq = bqq[t], y.ind = y.ind, y.censored = y.censored, r = solve(R)) @@ -644,7 +647,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { Cmodel$aq <- aqq[t,,] Cmodel$bq <- bqq[t] Cmodel$muf <- mu.f - Cmodel$pf <- Pf + Cmodel$pf <- solve(Pf) Cmodel$r <- solve(R) for(i in 1:length(y.ind)) { diff --git a/modules/assim.sequential/inst/paleon_sda.R b/modules/assim.sequential/inst/paleon_sda.R index 3374d3e40fd..304b7a26996 100644 --- a/modules/assim.sequential/inst/paleon_sda.R +++ b/modules/assim.sequential/inst/paleon_sda.R @@ -1,13 +1,23 @@ library(PEcAn.all) library(PEcAn.SIPNET) +library(PEcAn.LINKAGES) library(PEcAn.assim.sequential) +library(nimble) +library(lubridate) + +ciEnvelope <- function(x,ylo,yhi,...){ + polygon(cbind(c(x, rev(x), x[1]), c(ylo, rev(yhi), + ylo[1])), border = NA,...) +} #LINKAGES #AGB.pft #Harvard Forest -#setwd('/fs/data2/output//PEcAn_1000003314/') +setwd('/fs/data2/output//PEcAn_1000003314/') #SIPNET -setwd('/fs/data2/output//PEcAn_1000003356') +#setwd('/fs/data2/output//PEcAn_1000003356') +#TO DO: Normalize state vector because NPP is too small. +#See talk with with Mike on 6/21/17 #---------------- Load PEcAn settings file. --------------------------------# # Open and read in settings file for PEcAn run. @@ -15,10 +25,12 @@ settings <- read.settings("pecan.SDA.xml") obs.list <- PEcAn.assim.sequential::load_data_paleon_sda(settings = settings) -status.start("IC") -ne <- as.numeric(settings$state.data.assimilation$n.ensemble) -IC <- sample.IC.SIPNET(ne, state = c('AGB','NPP')) -status.end() +IC <- NULL + +# status.start("IC") +# ne <- as.numeric(settings$state.data.assimilation$n.ensemble) +# IC <- sample.IC.SIPNET(ne, state = c('AGB','NPP')) +# status.end() sda.enkf(settings, obs.mean = obs.list$obs.mean, obs.cov = obs.list$obs.cov, IC = IC) From de1e091fad268e64211091530d2f8e32399134d2 Mon Sep 17 00:00:00 2001 From: Ann Raiho Date: Thu, 22 Jun 2017 13:18:32 -0400 Subject: [PATCH 051/771] making some changes to be able to redo years in sda without any hassle. Now, .nc files will be remade instead of skipped if they already exist (might want to look back into if that's an okay thing to do). And the restart files will look for old output if the new output isn't there. (might want to think about always looking for the output related to time) --- models/linkages/R/model2netcdf.LINKAGES.R | 8 ++++---- models/linkages/R/write.config.LINKAGES.R | 10 +++++----- models/linkages/R/write_restart.LINKAGES.R | 6 ++++-- models/sipnet/R/model2netcdf.SIPNET.R | 6 +++--- modules/assim.sequential/R/load_data_paleon_sda.R | 3 ++- 5 files changed, 18 insertions(+), 15 deletions(-) diff --git a/models/linkages/R/model2netcdf.LINKAGES.R b/models/linkages/R/model2netcdf.LINKAGES.R index e944f3b9c4a..76a6200b68f 100644 --- a/models/linkages/R/model2netcdf.LINKAGES.R +++ b/models/linkages/R/model2netcdf.LINKAGES.R @@ -26,7 +26,7 @@ model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, e # , PFTs) { logger.severe('NOT IMPLEMENTED') library(PEcAn.utils) - + ### Read in model output in linkages format load(file.path(outdir, "linkages.out.Rdata")) # linkages.output.dims <- dim(linkages.output) @@ -39,9 +39,9 @@ model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, e ### Loop over years in linkages output to create separate netCDF outputs for (y in seq_along(years)) { - if (file.exists(file.path(outdir, paste(years[y], "nc", sep = ".")))) { - next - } + # if (file.exists(file.path(outdir, paste(years[y], "nc", sep = "."))) & overwrite ==FALSE) { + # next + # } print(paste("---- Processing year: ", years[y])) # turn on for debugging ## Subset data for processing sub.linkages.output <- subset(linkages.output, year == y) diff --git a/models/linkages/R/write.config.LINKAGES.R b/models/linkages/R/write.config.LINKAGES.R index 3e66072f730..af0b7afa138 100644 --- a/models/linkages/R/write.config.LINKAGES.R +++ b/models/linkages/R/write.config.LINKAGES.R @@ -124,8 +124,8 @@ write.config.LINKAGES <- function(defaults = NULL, trait.values, settings, run.i vals <- trait.values[[group]] # replace defaults with traits - new.params.locs <- which(names(spp.params) %in% names(vals)) - new.vals.locs <- which(names(vals) %in% names(spp.params)) + #new.params.locs <- which(names(spp.params) %in% names(vals)) + #new.vals.locs <- which(names(vals) %in% names(spp.params)) #spp.params[which(spp.params$Spp_Name == group), new.params.locs] <- vals[new.vals.locs] # conversion of some traits to match what LINKAGES needs Going to have to look up this paper @@ -150,11 +150,11 @@ write.config.LINKAGES <- function(defaults = NULL, trait.values, settings, run.i if ("DMIN" %in% names(vals)) { spp.params[spp.params$Spp_Name == group, ]$DMIN <- vals$DMIN } - if ("AGEMAX" %in% names(vals)) { - spp.params[spp.params$Spp_Name == group, ]$AGEMAX <- vals$AGEMAX + if ("AGEMX" %in% names(vals)) { + spp.params[spp.params$Spp_Name == group, ]$AGEMX <- vals$AGEMX } if ("G" %in% names(vals)) { - spp.params[spp.params$Spp_Name == group, ]$G <- vals$Gmax + spp.params[spp.params$Spp_Name == group, ]$G <- vals$G } if ("SPRTND" %in% names(vals)) { spp.params[spp.params$Spp_Name == group, ]$SPRTND <- vals$SPRTND diff --git a/models/linkages/R/write_restart.LINKAGES.R b/models/linkages/R/write_restart.LINKAGES.R index 0b116ca1d0e..fcde7ef0bb4 100644 --- a/models/linkages/R/write_restart.LINKAGES.R +++ b/models/linkages/R/write_restart.LINKAGES.R @@ -129,8 +129,10 @@ write_restart.LINKAGES <- function(outdir, runid, start.time, stop.time, setting # skip ensemble member if no file availible outfile <- file.path(outdir, runid, "linkages.out.Rdata") if (!file.exists(outfile)) { - print(paste0("missing outfile ens #", runid)) - next + outfile <- file.path(outdir, runid, paste0(start.time, "linkages.out.Rdata")) + if (!file.exists(outfile)) { + logger.severe(paste0("missing outfile ens #", runid)) + } } print(paste0("runid = ", runid)) diff --git a/models/sipnet/R/model2netcdf.SIPNET.R b/models/sipnet/R/model2netcdf.SIPNET.R index 6b22c750443..cd1ba769240 100644 --- a/models/sipnet/R/model2netcdf.SIPNET.R +++ b/models/sipnet/R/model2netcdf.SIPNET.R @@ -36,9 +36,9 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, ### Loop over years in SIPNET output to create separate netCDF outputs for (y in years) { - if (file.exists(file.path(outdir, paste(y, "nc", sep = ".")))) { - next - } + # if (file.exists(file.path(outdir, paste(y, "nc", sep = "."))) & overwrite == FALSE) { + # next + # } print(paste("---- Processing year: ", y)) # turn on for debugging ## Subset data for processing diff --git a/modules/assim.sequential/R/load_data_paleon_sda.R b/modules/assim.sequential/R/load_data_paleon_sda.R index 7557d7c0961..b54841a05cf 100644 --- a/modules/assim.sequential/R/load_data_paleon_sda.R +++ b/modules/assim.sequential/R/load_data_paleon_sda.R @@ -71,7 +71,6 @@ load_data_paleon_sda <- function(settings){ logger.info(paste('Using PEcAn.benchmark::load_data.R on format_id',format_id[[i]],'-- may take a few minutes')) obvs[[i]] <- PEcAn.benchmark::load_data(data.path, format, start_year = lubridate::year(start_date), end_year = lubridate::year(end_date), site) - dataset <- obvs[[i]] variable <- intersect(var.names,colnames(obvs[[i]])) ### Tree Ring Data Product @@ -86,6 +85,8 @@ load_data_paleon_sda <- function(settings){ logger.severe('ERROR: This data format has not been added to this function (ツ)_/¯ ') } + dataset <- obvs[[i]] + ### Map species to model specific PFTs if(any(var.names == 'AGB.pft')){ spp_id <- match_species_id(unique(dataset$species_id),format_name = 'usda',bety) From a33f6310b7371626b190c7834304011f23c7d1c9 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Thu, 22 Jun 2017 15:39:42 -0500 Subject: [PATCH 052/771] Allowing multiple load. Modified server.R --- shiny/workflowPlot/server.R | 77 +++++++++++++++---------------------- 1 file changed, 30 insertions(+), 47 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 8188df3822a..97362bfb00d 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -39,6 +39,7 @@ server <- shinyServer(function(input, output, session) { # Get all workflow IDs ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% .[["workflow_id"]] %>% sort(decreasing = TRUE) + # pull(.,workflow_id) %>% sort(decreasing = TRUE) } return(ids) } # get_workflow_ids @@ -91,13 +92,13 @@ server <- shinyServer(function(input, output, session) { if(input$load){ req(input$all_run_id) # Selected `multiple' ids - ids_DF <- parse_ids_from_input_runID(input$all_run_id) - ids_DF %>% filter(wID %in% input$workflow_id) + ids_DF <- parse_ids_from_input_runID(input$all_run_id) %>% filter(wID %in% input$workflow_id) # To allow caching later + # Change variable name r_ID <- intersect(r_ID,ids_DF$runID) } updateSelectizeInput(session, "run_id", choices=r_ID) - }) + }) # run_ids <- reactive({ # req(input$workflow_id) # r_ID <- get_run_ids(bety, input$workflow_id) @@ -167,21 +168,6 @@ server <- shinyServer(function(input, output, session) { observe({ updateSelectizeInput(session, "variable_name", choices=var_names()) }) - # observe({ - # ignore <- input$variable_name - # ranges$x <- NULL - # ranges$y <- NULL - # }) - # observeEvent(input$plot_dblclick, { - # brush <- input$plot_brush - # if (!is.null(brush)) { - # ranges$x <- as.POSIXct(c(brush$xmin, brush$xmax), origin = "1970-01-01", tz = "UTC") - # ranges$y <- c(brush$ymin, brush$ymax) - # } else { - # ranges$x <- NULL - # ranges$y <- NULL - # } - # }) # If want to render text output$info <- renderText({ # indicators <- strsplit(input$indicators, ",")[[1]] @@ -192,7 +178,7 @@ server <- shinyServer(function(input, output, session) { # d <- typeof(all_workflow_id) # paste0(input$all_run_id) - paste0(parse_ids_from_input_runID(input$all_run_id)$wID) + paste0(parse_ids_from_input_runID(input$all_run_id)$runID) # paste0(input$load) # paste0(input$all_run_id[length(input$all_run_id)]) # paste0(input$variable_name) @@ -251,9 +237,7 @@ server <- shinyServer(function(input, output, session) { globalDF$var_name <- as.character(globalDF$var_name) return(globalDF) } - - - + loadNewData <-eventReactive(input$load,{ # workflow_id = 99000000077 # run_id = 99000000002 @@ -261,40 +245,39 @@ server <- shinyServer(function(input, output, session) { req(input$all_run_id) globalDF <- data.frame() ids_DF <- parse_ids_from_input_runID(input$all_run_id) - for(i in nrow(ids_DF)){ - globalDF <- rbind(globalDF, load_data_single_run(ids_DF$wID[i],ids_DF$runID[i])) + for(row_num in 1:nrow(ids_DF)){ + globalDF <- rbind(globalDF, load_data_single_run(ids_DF$wID[row_num],ids_DF$runID[row_num])) } return(globalDF) - # for(workflow_id in ids){ - # run_ids <- get_run_ids(bety,workflow_id) - # for(run_id in run_ids){ - # var_names <- get_var_names(bety, workflow_id, run_id) - # removeVarNames <- c('Year','FracJulianDay') - # var_names <-var_names[!var_names %in% removeVarNames] - # # if (workflow_id != "" && run_id != "" && var_name != "") { - # } - # } }) output$outputPlot <- renderPlotly({ - masterDF <- load_data_single_run(input$workflow_id,input$run_id) - masterDF <- rbind(masterDF,loadNewData()) + # masterDF <- load_data_single_run(input$workflow_id,input$run_id) + masterDF <- loadNewData() output$info1 <- renderText({ paste0(nrow(masterDF)) + paste0(length(unique(masterDF$run_id))) }) # Error messages validate( - need(input$workflow_id, 'Found workflow id'), - need(input$run_id, 'Run id detected'), + # need(input$workflow_id, 'Found workflow id'), + # need(input$run_id, 'Run id detected'), need(input$variable_name, 'Please wait! Loading data') ) masterDF$var_name <- as.character(masterDF$var_name) + masterDF$run_id <- as.factor(as.character(masterDF$run_id)) + # masterDF$var_name = as.factor(masterDF$var_name) # df1<-subset(masterDF,var_name==var_name) - df <- masterDF %>% - dplyr::filter(workflow_id == input$workflow_id & - run_id == input$run_id & - var_name == input$variable_name) %>% - dplyr::select(dates,vals) + + # Drop filtering + df <- masterDF %>% + dplyr::filter( + # workflow_id == input$workflow_id & + # run_id == input$run_id & + var_name == input$variable_name) + # %>% + # dplyr::select(dates,vals,workflow_id,run_id) + title <- unique(df$title)[1] xlab <- unique(df$xlab)[1] ylab <- unique(df$ylab)[1] @@ -311,16 +294,16 @@ server <- shinyServer(function(input, output, session) { # workflow_id %in% workflow_id) # & run_id == run_id & var_name == var_name) # df<-masterDF %>% dplyr::filter(workflow_id == input$workflow_id) - plt <- ggplot(df, aes(x=dates, y=vals)) + + plt <- ggplot(df, aes(x=dates, y=vals, color=run_id)) + # geom_point(aes(color="Model output")) + - geom_point() + + geom_point() # geom_smooth(aes(fill = "Spline fit")) + # coord_cartesian(xlim = ranges$x, ylim = ranges$y) + # scale_y_continuous(labels=fancy_scientific) + - labs(title=title, x=xlab, y=ylab) + + # labs(title=title, x=xlab, y=ylab) + # labs(title=unique(df$title)[1], x=unique(df$xlab)[1], y=unique(df$ylab)[1]) + - scale_color_manual(name = "", values = "black") + - scale_fill_manual(name = "", values = "grey50") + # scale_color_manual(name = "", values = "black") + + # scale_fill_manual(name = "", values = "grey50") # theme(axis.text.x = element_text(angle = -90)) plt<-ggplotly(plt) # plot(plt) From 95987d9303f215461fa164d159845b0549e2884e Mon Sep 17 00:00:00 2001 From: Ann Raiho Date: Thu, 22 Jun 2017 21:13:44 -0400 Subject: [PATCH 053/771] fixing sda plots --- modules/assim.sequential/R/sda.enkf.R | 59 ++++++++++++---------- modules/assim.sequential/inst/paleon_sda.R | 3 ++ 2 files changed, 35 insertions(+), 27 deletions(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index b2ada4c422c..eea264df2cb 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -337,7 +337,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ###-------------------------------------------------------------------### ### loop over time ### ###-------------------------------------------------------------------### - for (t in 1:2) {# + for (t in 11:20) {# ###-------------------------------------------------------------------### ### read restart ### @@ -607,7 +607,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { constants.tobit = list(N = ncol(X), YN = length(y.ind)) #, nc = 1 dimensions.tobit = list(X = ncol(X), X.mod = ncol(X), Q = c(ncol(X),ncol(X))) # b = dim(inits.pred$b), - data.tobit = list(muf = as.vector(mu.f), pf = solve(Pf), aq = aqq[t,,], bq = bqq[t], + data.tobit = list(muf = as.vector(mu.f), pf = Pf, aq = aqq[t,,], bq = bqq[t], y.ind = y.ind, y.censored = y.censored, r = solve(R)) @@ -647,7 +647,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { Cmodel$aq <- aqq[t,,] Cmodel$bq <- bqq[t] Cmodel$muf <- mu.f - Cmodel$pf <- solve(Pf) + Cmodel$pf <- Pf Cmodel$r <- solve(R) for(i in 1:length(y.ind)) { @@ -781,7 +781,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { }))) par(mfrow = c(2, 1)) - for (i in 1:2) {# + for (i in 1:14) {# t1 <- 1 Xbar <- plyr::laply(FORECAST[t1:t], function(x) { mean(x[, i], na.rm = TRUE) }) Xci <- plyr::laply(FORECAST[t1:t], function(x) { quantile(x[, i], c(0.025, 0.975)) }) @@ -794,7 +794,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { plot(as.Date(obs.times[t1:t]), Xbar, - ylim = range(c(XaCI, Xci), na.rm = TRUE), + ylim = c(0,8),#range(c(XaCI, Xci), na.rm = TRUE), type = "n", xlab = "Year", ylab = ylab.names[grep(colnames(X)[i], var.names)], @@ -887,12 +887,11 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { print("climate diagnostics under development") } - ### Diagnostic graphs - pdf(file.path(settings$outdir, "EnKF.pdf")) ###-------------------------------------------------------------------### ### time series ### ###-------------------------------------------------------------------### + pdf(file.path(settings$outdir, "sda.enkf.time-series.pdf")) names.y <- unique(unlist(lapply(obs.mean[t1:t], function(x) { names(x) }))) Ybar <- t(sapply(obs.mean[t1:t], function(x) { @@ -910,11 +909,9 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { sqrt(diag(x)) }))) #need to make this from quantiles for lyford plot data # YCI = YCI[,pmatch(colnames(X), names(obs.mean[[nt]][[1]]))] - Xsum <- plyr::laply(FORECAST, function(x) { mean(rowSums(x[,1:9], na.rm = TRUE)) }) + Xsum <- plyr::laply(FORECAST, function(x) { mean(rowSums(x[,1:length(names.y)], na.rm = TRUE)) })[t1:t] - pdf('fcomp.kalman.filter.pdf') for (i in seq_len(ncol(X))) { - #t1 <- 1 Xbar <- plyr::laply(FORECAST[t1:t], function(x) { mean(x[, i], na.rm = TRUE) }) Xci <- plyr::laply(FORECAST[t1:t], function(x) { quantile(x[, i], c(0.025, 0.975)) }) Xci[is.na(Xci)]<-0 @@ -948,13 +945,15 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # analysis ciEnvelope(as.Date(obs.times[t1:t]), XaCI[, 1], XaCI[, 2], col = alphapink) lines(as.Date(obs.times[t1:t]), Xa, col = "black", lty = 2, lwd = 2) - } + legend('topright',c('Forecast','Data','Analysis'),col=c(alphablue,alphagreen,alphapink),lty=1,lwd=5) + + } + dev.off() ###-------------------------------------------------------------------### ### bias diagnostics ### - ###-------------------------------------------------------------------### - # legend('topleft',c('Data','Forecast','Analysis'),col=c(4,2,3),lty=1,cex=1) Forecast minus data = - # error + ###-------------------------------------------------------------------### + pdf(file.path(settings$outdir, "bias.diagnostic.pdf")) for (i in seq_along(obs.mean[[1]])) { Xbar <- plyr::laply(FORECAST[t1:t], function(x) { mean(x[, i], na.rm = TRUE) }) Xci <- plyr::laply(FORECAST[t1:t], function(x) { quantile(x[, i], c(0.025, 0.975)) }) @@ -962,17 +961,18 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { Xa <- plyr::laply(ANALYSIS[t1:t], function(x) { mean(x[, i], na.rm = TRUE) }) XaCI <- plyr::laply(ANALYSIS[t1:t], function(x) { quantile(x[, i], c(0.025, 0.975)) }) - reg <- lm(Xbar[t1:t]/Xsum - unlist(Ybar[t1:t, i]) ~ c(t1:t)) + if(length(which(is.na(Ybar[,i])))>=length(t1:t)) next() + reg <- lm(Xbar[t1:t]/Xsum - unlist(Ybar[, i]) ~ c(t1:t)) plot(t1:t, - Xbar[t1:t]/Xsum - unlist(Ybar[t1:t, i]), + Xbar/Xsum - unlist(Ybar[, i]), pch = 16, cex = 1, - ylim = c(min(Xci[t1:t, 1]/Xsum - unlist(Ybar[t1:t, i])), max(Xci[t1:t, 2]/Xsum - unlist(Ybar[t1:t, i]))), + ylim = c(min(Xci[, 1]/Xsum - unlist(Ybar[, i])), max(Xci[,2]/Xsum - unlist(Ybar[, i]))), xlab = "Time", ylab = "Error", main = paste(colnames(X)[i], " Error = Forecast - Data")) ciEnvelope(rev(t1:t), - rev(Xci[t1:t, 1]/Xsum - unlist(Ybar[t1:t, i])), - rev(Xci[t1:t, 2]/Xsum - unlist(Ybar[t1:t, i])), + rev(Xci[, 1]/Xsum - unlist(Ybar[, i])), + rev(Xci[, 2]/Xsum - unlist(Ybar[, i])), col = alphapink) abline(h = 0, lty = 2, lwd = 2) abline(reg) @@ -981,17 +981,17 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # d<-density(c(Xbar[t1:t] - unlist(Ybar[t1:t,i]))) lines(d$y+1,d$x) # forecast minus analysis = update - reg1 <- lm(Xbar[t1:t]/Xsum - Xa[t1:t]/Xsum ~ c(t1:t)) + reg1 <- lm(Xbar/Xsum - Xa/Xsum ~ c(t1:t)) plot(t1:t, - Xbar[t1:t]/Xsum - Xa[t1:t]/Xsum, + Xbar/Xsum - Xa/Xsum, pch = 16, cex = 1, - ylim = c(min(Xbar[t1:t]/Xsum - XaCI[t1:t, 2]/Xsum), max(Xbar[t1:t]/Xsum - XaCI[t1:t, 1]/Xsum)), + ylim = c(min(Xbar/Xsum - XaCI[, 2]/Xsum), max(Xbar/Xsum - XaCI[, 1]/Xsum)), xlab = "Time", ylab = "Update", main = paste(colnames(X)[i], "Update = Forecast - Analysis")) ciEnvelope(rev(t1:t), - rev(Xbar[t1:t]/Xsum - XaCI[t1:t, 1]/Xsum), - rev(Xbar[t1:t]/Xsum - XaCI[t1:t, 2]/Xsum), + rev(Xbar/Xsum - XaCI[, 1]/Xsum), + rev(Xbar/Xsum - XaCI[, 2]/Xsum), col = alphagreen) abline(h = 0, lty = 2, lwd = 2) abline(reg1) @@ -1000,20 +1000,27 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { digits = 3))) # d<-density(c(Xbar[t1:t] - Xa[t1:t])) lines(d$y+1,d$x) } + dev.off() + ###-------------------------------------------------------------------### ### process variance plots ### ###-------------------------------------------------------------------### if (processvar) { + library(corrplot) + pdf('process.var.plots.pdf') + cor.mat <- cov2cor(aqq[t, , ] / bqq[t]) colnames(cor.mat) <- colnames(X) rownames(cor.mat) <- colnames(X) par(mfrow = c(1, 1), mai = c(1, 1, 4, 1)) - corrplot(cor.mat, type = "upper", tl.srt = 45, addCoef.col = "black") + corrplot(cor.mat, type = "upper", tl.srt = 45,order='AOE') plot(as.Date(obs.times[t1:t]), bqq[t1:t], pch = 16, cex = 1, ylab = "Degrees of Freedom", xlab = "Time") + + dev.off() } ###-------------------------------------------------------------------### @@ -1042,6 +1049,4 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # cex=1, xlab="Total Yearly Precip", # ylab="Update",main=colnames(Ybar)[i]) - dev.off() - } # sda.enkf diff --git a/modules/assim.sequential/inst/paleon_sda.R b/modules/assim.sequential/inst/paleon_sda.R index 304b7a26996..925cadf87a7 100644 --- a/modules/assim.sequential/inst/paleon_sda.R +++ b/modules/assim.sequential/inst/paleon_sda.R @@ -32,6 +32,9 @@ IC <- NULL # IC <- sample.IC.SIPNET(ne, state = c('AGB','NPP')) # status.end() +#TO DO: Having problem with running proc.var == TRUE because nimble isn't keeping the toggle sampler in the function environment. +#TO DO: Intial conditions for linkages are messed up. Need to calibrate. + sda.enkf(settings, obs.mean = obs.list$obs.mean, obs.cov = obs.list$obs.cov, IC = IC) From 8700cbdb7362d09003db579d79a275814f6afa53 Mon Sep 17 00:00:00 2001 From: Ann Raiho Date: Fri, 23 Jun 2017 00:02:21 -0400 Subject: [PATCH 054/771] Added scaling to ensemble kalman filter to fix problem with state variables on different scales. --- modules/assim.sequential/R/sda.enkf.R | 33 ++++++++++++++++++++------- 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index eea264df2cb..cb84dbedcc6 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -337,7 +337,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ###-------------------------------------------------------------------### ### loop over time ### ###-------------------------------------------------------------------### - for (t in 11:20) {# + for(t in seq_len(nt)) {# ###-------------------------------------------------------------------### ### read restart ### @@ -465,11 +465,28 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { if (!is.null(Q)) { Pf <- Pf + Q } + + mu.f.scale <- scale(mu.f, center = mean(mu.f), scale = 1) + Pf.scale <- cov(scale(X, center = mu.f, scale = rep(1,length(mu.f)))) + Pf.scale[is.na(Pf.scale)]<-0 + R.scale <- matrix(scale(as.vector(R), center = mean(mu.f), scale = 1),2,2) + Y.scale <- scale(Y, center = mean(mu.f[1:2]), scale = 1) + + ## Kalman Gain + K <- Pf.scale %*% t(H) %*% solve((R.scale + H %*% Pf.scale %*% t(H))) + ## Analysis + mu.a.scale <- mu.f.scale + K %*% (Y.scale - H %*% mu.f.scale) + Pa.scale <- (diag(ncol(X)) - K %*% H) %*% Pf.scale + + Pa <- Pa.scale * attr(mu.f.scale, 'scaled:scale') + attr(mu.f.scale, 'scaled:center') + mu.a <- mu.a.scale * attr(mu.f.scale, 'scaled:scale') + attr(mu.f.scale, 'scaled:center') + + ## Kalman Gain - K <- Pf %*% t(H) %*% solve((R + H %*% Pf %*% t(H))) + #K <- Pf %*% t(H) %*% solve((R + H %*% Pf %*% t(H))) ## Analysis - mu.a <- mu.f + K %*% (Y - H %*% mu.f) - Pa <- (diag(ncol(X)) - K %*% H) %*% Pf + #mu.a <- mu.f + K %*% (Y - H %*% mu.f) + #Pa <- (diag(ncol(X)) - K %*% H) %*% Pf enkf.params[[t]] <- list(mu.f = mu.f, Pf = Pf, mu.a = mu.a, Pa = Pa) } else { @@ -781,7 +798,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { }))) par(mfrow = c(2, 1)) - for (i in 1:14) {# + for (i in 1:ncol(FORECAST[[t]])) {# t1 <- 1 Xbar <- plyr::laply(FORECAST[t1:t], function(x) { mean(x[, i], na.rm = TRUE) }) Xci <- plyr::laply(FORECAST[t1:t], function(x) { quantile(x[, i], c(0.025, 0.975)) }) @@ -794,7 +811,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { plot(as.Date(obs.times[t1:t]), Xbar, - ylim = c(0,8),#range(c(XaCI, Xci), na.rm = TRUE), + ylim = range(c(XaCI, Xci), na.rm = TRUE), type = "n", xlab = "Year", ylab = ylab.names[grep(colnames(X)[i], var.names)], @@ -820,6 +837,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # analysis ciEnvelope(as.Date(obs.times[t1:t]), XaCI[, 1], XaCI[, 2], col = alphapink) lines(as.Date(obs.times[t1:t]), Xa, col = "black", lty = 2, lwd = 2) + legend('topright',c('Forecast','Data','Analysis'),col=c(alphablue,alphagreen,alphapink),lty=1,lwd=5) } } @@ -907,8 +925,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { rep(NA, length(names.y)) } sqrt(diag(x)) - }))) #need to make this from quantiles for lyford plot data - # YCI = YCI[,pmatch(colnames(X), names(obs.mean[[nt]][[1]]))] + }))) Xsum <- plyr::laply(FORECAST, function(x) { mean(rowSums(x[,1:length(names.y)], na.rm = TRUE)) })[t1:t] for (i in seq_len(ncol(X))) { From 648e22b540879025c1e3eb9843f73c0a6b4a45f4 Mon Sep 17 00:00:00 2001 From: Ann Raiho Date: Fri, 23 Jun 2017 00:15:38 -0400 Subject: [PATCH 055/771] added ensemble adjustment --- modules/assim.sequential/R/sda.enkf.R | 41 ++++++++++++++++++++-- modules/assim.sequential/inst/paleon_sda.R | 21 +++++------ 2 files changed, 50 insertions(+), 12 deletions(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index cb84dbedcc6..0b34db78727 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -759,8 +759,45 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { enkf.params[[t]] <- list(mu.f = mu.f, Pf = Pf, mu.a = mu.a, Pa = Pa) } - ## update state matrix - analysis <- as.data.frame(rmvnorm(as.numeric(nens), mu.a, Pa, method = "svd")) + ###-------------------------------------------------------------------### + ### update state matrix ### + ###-------------------------------------------------------------------### + S_f <- svd(Pf) + L_f <- S_f$d + V_f <- S_f$v + + ## normalize + Z <- X*0 + for(i in seq_len(nens)){ + Z[i,] <- 1/sqrt(L_f) * t(V_f)%*%(X[i,]-mu.f) + } + Z[is.na(Z)]<-0 + + ## analysis + #mu_a <- c(10,-3) + #D <- sqrt(diag(c(3,1))) + #R <- matrix(c(1,-0.75,-0.75,1),2,2) + #P_a <- D%*%R%*%D + S_a <- svd(Pa) + L_a <- S_a$d + V_a <- S_a$v + + ## analysis ensemble + X_a <- X*0 + for(i in seq_len(nens)){ + X_a[i,] <- V_a %*%diag(sqrt(L_a))%*%Z[i,]+mu.a + } + + # par(mfrow=c(1,1)) + # plot(X_a) + # ## check if ensemble mean is correct + # cbind(mu.a,colMeans(X_a)) + # ## check if ensemble var is correct + # cbind(as.vector(Pa),as.vector(cov(X_a))) + # + # analysis <- as.data.frame(rmvnorm(as.numeric(nens), mu.a, Pa, method = "svd")) + + analysis <- as.data.frame(X_a) colnames(analysis) <- colnames(X) ##### Mapping analysis vectors to be in bounds of state variables diff --git a/modules/assim.sequential/inst/paleon_sda.R b/modules/assim.sequential/inst/paleon_sda.R index 925cadf87a7..51098cf2283 100644 --- a/modules/assim.sequential/inst/paleon_sda.R +++ b/modules/assim.sequential/inst/paleon_sda.R @@ -12,11 +12,14 @@ ciEnvelope <- function(x,ylo,yhi,...){ } #LINKAGES #AGB.pft #Harvard Forest -setwd('/fs/data2/output//PEcAn_1000003314/') +#setwd('/fs/data2/output//PEcAn_1000003314/') +#TO DO: Having problem with running proc.var == TRUE because nimble isn't keeping the toggle sampler in the function environment. +#TO DO: Intial conditions for linkages are messed up. Need to calibrate. + #SIPNET -#setwd('/fs/data2/output//PEcAn_1000003356') -#TO DO: Normalize state vector because NPP is too small. +setwd('/fs/data2/output//PEcAn_1000003356') +#TO DO: Skip ensemble members that fail or are missing in read.restart #See talk with with Mike on 6/21/17 #---------------- Load PEcAn settings file. --------------------------------# @@ -27,15 +30,13 @@ obs.list <- PEcAn.assim.sequential::load_data_paleon_sda(settings = settings) IC <- NULL -# status.start("IC") -# ne <- as.numeric(settings$state.data.assimilation$n.ensemble) -# IC <- sample.IC.SIPNET(ne, state = c('AGB','NPP')) -# status.end() +status.start("IC") +ne <- as.numeric(settings$state.data.assimilation$n.ensemble) +IC <- sample.IC.SIPNET(ne, state = c('AGB','NPP')) +status.end() -#TO DO: Having problem with running proc.var == TRUE because nimble isn't keeping the toggle sampler in the function environment. -#TO DO: Intial conditions for linkages are messed up. Need to calibrate. -sda.enkf(settings, obs.mean = obs.list$obs.mean, obs.cov = obs.list$obs.cov, IC = IC) +PEcAn.assim.sequential::sda.enkf(settings, obs.mean = obs.list$obs.mean, obs.cov = obs.list$obs.cov, IC = IC) From a2ebfb844dae09bac527c32dcaaa6273ee8043fe Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Fri, 23 Jun 2017 19:22:50 -0500 Subject: [PATCH 056/771] Multiple run ids. Removed debugging text. Need to clean code --- shiny/workflowPlot/server.R | 161 ++++++++++++++++++++---------------- shiny/workflowPlot/ui.R | 14 ++-- 2 files changed, 95 insertions(+), 80 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 97362bfb00d..ca813ea7fe7 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -71,34 +71,34 @@ server <- shinyServer(function(input, output, session) { updateSelectizeInput(session, "all_run_id", choices=all_run_ids()) }) # Update on load: workflow id for selected run ids (models) - observe({ - if(input$load){ - req(input$all_run_id) - # Selected `multiple' ids - selected_id <- parse_ids_from_input_runID(input$all_run_id)$wID - # To allow caching later - display_id <- c(input$workflow_id,selected_id) - updateSelectizeInput(session, "workflow_id", choices=display_id) - } else{ - session_workflow_id <- get_workflow_ids_all(bety, session) - updateSelectizeInput(session, "workflow_id", choices=session_workflow_id) - } - }) + # observe({ + # if(input$load){ + # req(input$all_run_id) + # # Selected `multiple' ids + # selected_id <- parse_ids_from_input_runID(input$all_run_id)$wID + # # To allow caching later + # display_id <- c(input$workflow_id,selected_id) + # updateSelectizeInput(session, "workflow_id", choices=display_id) + # } else{ + # session_workflow_id <- get_workflow_ids_all(bety, session) + # updateSelectizeInput(session, "workflow_id", choices=session_workflow_id) + # } + # }) # Update run id for selected workflow id (model) - observe({ - req(input$workflow_id) - r_ID <- get_run_ids(bety, input$workflow_id) - if(input$load){ - req(input$all_run_id) - # Selected `multiple' ids - ids_DF <- parse_ids_from_input_runID(input$all_run_id) %>% filter(wID %in% input$workflow_id) - # To allow caching later - # Change variable name - r_ID <- intersect(r_ID,ids_DF$runID) - } - updateSelectizeInput(session, "run_id", choices=r_ID) - }) + # observe({ + # req(input$workflow_id) + # r_ID <- get_run_ids(bety, input$workflow_id) + # if(input$load){ + # req(input$all_run_id) + # # Selected `multiple' ids + # ids_DF <- parse_ids_from_input_runID(input$all_run_id) %>% filter(wID %in% input$workflow_id) + # # To allow caching later + # # Change variable name + # r_ID <- intersect(r_ID,ids_DF$runID) + # } + # updateSelectizeInput(session, "run_id", choices=r_ID) + # }) # run_ids <- reactive({ # req(input$workflow_id) # r_ID <- get_run_ids(bety, input$workflow_id) @@ -152,47 +152,62 @@ server <- shinyServer(function(input, output, session) { # return(var_names) # } - var_names <- reactive({ - # run_ids <- get_run_ids(bety, workflow_id()) - # var_names <- get_var_names(bety, workflow_id(), run_ids[1]) - # Removing the variables "Year" and "FracJulianDay" from the Variable Name input in the app - req(input$workflow_id,input$run_id) - workflow_id <- input$workflow_id - run_id <- input$run_id + var_names_all <- function(workflow_id, run_id){ var_names <- get_var_names(bety, workflow_id, run_id) removeVarNames <- c('Year','FracJulianDay') var_names <-var_names[!var_names %in% removeVarNames] return(var_names) - # return(id_list) - }) + } + + # var_names1 <- reactive({ + # # run_ids <- get_run_ids(bety, workflow_id()) + # # var_names <- get_var_names(bety, workflow_id(), run_ids[1]) + # # Removing the variables "Year" and "FracJulianDay" from the Variable Name input in the app + # req(input$workflow_id,input$run_id) + # workflow_id <- input$workflow_id + # run_id <- input$run_id + # var_names <- get_var_names(bety, workflow_id, run_id) + # removeVarNames <- c('Year','FracJulianDay') + # var_names <-var_names[!var_names %in% removeVarNames] + # return(var_names) + # # return(id_list) + # }) observe({ - updateSelectizeInput(session, "variable_name", choices=var_names()) + req(input$all_run_id) + ids_DF <- parse_ids_from_input_runID(input$all_run_id) + var_name_list <- c() + for(row_num in 1:nrow(ids_DF)){ + var_name_list <- c(var_name_list,var_names_all(ids_DF$wID[row_num],ids_DF$runID[row_num])) + # var_name_list <- var_names_all(ids_DF$wID[row_num],ids_DF$runID[row_num]) + } + updateSelectizeInput(session, "variable_name", choices=var_name_list) }) # If want to render text - output$info <- renderText({ - # indicators <- strsplit(input$indicators, ",")[[1]] - - # if(input$load){ - # all_workflow_id <- strsplit(input$all_workflow_id,',') - # } - # d <- typeof(all_workflow_id) - # paste0(input$all_run_id) - - paste0(parse_ids_from_input_runID(input$all_run_id)$runID) - # paste0(input$load) - # paste0(input$all_run_id[length(input$all_run_id)]) - # paste0(input$variable_name) - # paste0(run_ids(),length(run_ids()),ids) - # ,session$clientData$url_search) - # paste0("x=", input$plot_dblclick$x, "\ny=", input$plot_dblclick$y) - }) + # output$info <- renderText({ + # # indicators <- strsplit(input$indicators, ",")[[1]] + # + # # if(input$load){ + # # all_workflow_id <- strsplit(input$all_workflow_id,',') + # # } + # # d <- typeof(all_workflow_id) + # # paste0(input$all_run_id) + # + # paste0(parse_ids_from_input_runID(input$all_run_id)$runID) + # # paste0(input$load) + # # paste0(input$all_run_id[length(input$all_run_id)]) + # # paste0(input$variable_name) + # # paste0(run_ids(),length(run_ids()),ids) + # # ,session$clientData$url_search) + # # paste0("x=", input$plot_dblclick$x, "\ny=", input$plot_dblclick$y) + # }) load_data_single_run <- function(workflow_id,run_id){ globalDF <- data.frame() workflow <- collect(workflow(bety, workflow_id)) - var_names <- get_var_names(bety, workflow_id, run_id) - removeVarNames <- c('Year','FracJulianDay') - var_names <-var_names[!var_names %in% removeVarNames] + # var_names <- get_var_names(bety, workflow_id, run_id) + # removeVarNames <- c('Year','FracJulianDay') + # var_names <-var_names[!var_names %in% removeVarNames] + var_names <- var_names_all(workflow_id,run_id) if(nrow(workflow) > 0) { outputfolder <- file.path(workflow$folder, 'out', run_id) files <- list.files(outputfolder, "*.nc$", full.names=TRUE) @@ -253,10 +268,10 @@ server <- shinyServer(function(input, output, session) { output$outputPlot <- renderPlotly({ # masterDF <- load_data_single_run(input$workflow_id,input$run_id) masterDF <- loadNewData() - output$info1 <- renderText({ - paste0(nrow(masterDF)) - paste0(length(unique(masterDF$run_id))) - }) + # output$info1 <- renderText({ + # paste0(nrow(masterDF)) + # paste0(length(unique(masterDF$run_id))) + # }) # Error messages validate( # need(input$workflow_id, 'Found workflow id'), @@ -278,17 +293,17 @@ server <- shinyServer(function(input, output, session) { # %>% # dplyr::select(dates,vals,workflow_id,run_id) - title <- unique(df$title)[1] - xlab <- unique(df$xlab)[1] - ylab <- unique(df$ylab)[1] - output$info2 <- renderText({ - paste0(nrow(df)) - # paste0(typeof(title)) - }) - output$info3 <- renderText({ - paste0('xlab') - # paste0(typeof(title)) - }) + title <- unique(df$title) + xlab <- unique(df$xlab) + ylab <- unique(df$ylab) + # output$info2 <- renderText({ + # paste0(nrow(df)) + # # paste0(typeof(title)) + # }) + # output$info3 <- renderText({ + # paste0('xlab') + # # paste0(typeof(title)) + # }) # df1<-masterDF %>% filter(masterDF$var_name %in% var_name) # workflow_id %in% workflow_id) @@ -296,11 +311,11 @@ server <- shinyServer(function(input, output, session) { # df<-masterDF %>% dplyr::filter(workflow_id == input$workflow_id) plt <- ggplot(df, aes(x=dates, y=vals, color=run_id)) + # geom_point(aes(color="Model output")) + - geom_point() + geom_point() + # geom_smooth(aes(fill = "Spline fit")) + # coord_cartesian(xlim = ranges$x, ylim = ranges$y) + # scale_y_continuous(labels=fancy_scientific) + - # labs(title=title, x=xlab, y=ylab) + + labs(title=title, x=xlab, y=ylab) # labs(title=unique(df$title)[1], x=unique(df$xlab)[1], y=unique(df$ylab)[1]) + # scale_color_manual(name = "", values = "black") + # scale_fill_manual(name = "", values = "grey50") diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index a8db281f2bb..a8f6db5d8cd 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -14,8 +14,8 @@ ui <- shinyUI(fluidPage( p("Please select the run ID. You can select multiple IDs"), selectizeInput("all_run_id", "Mutliple Run IDs", c(),multiple=TRUE), actionButton("load", "Load Model outputs"), - selectInput("workflow_id", "Workflow ID", c()), - selectInput("run_id", "Run ID", c()), + # selectInput("workflow_id", "Workflow ID", c()), + # selectInput("run_id", "Run ID", c()), selectInput("variable_name", "Variable Name", "") # selectInput("workflow_id", "Workflow ID", c(99000000077)), @@ -28,12 +28,12 @@ ui <- shinyUI(fluidPage( # brush = brushOpts(id = "plot_brush", # resetOnNew = TRUE), # dblclick = "plot_dblclick" - ), + ) # Checking variable names - verbatimTextOutput("info"), - verbatimTextOutput("info1"), - verbatimTextOutput("info2"), - verbatimTextOutput("info3") + # verbatimTextOutput("info"), + # verbatimTextOutput("info1"), + # verbatimTextOutput("info2"), + # verbatimTextOutput("info3") ) ) )) From c657700c8375baecada6866bd3172081020d818b Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sat, 24 Jun 2017 10:02:52 -0500 Subject: [PATCH 057/771] Refactored, commented and clean code. --- db/R/query.dplyr.R | 1 + shiny/workflowPlot/server.R | 262 +++++++++--------------------------- shiny/workflowPlot/ui.R | 24 +--- 3 files changed, 68 insertions(+), 219 deletions(-) diff --git a/db/R/query.dplyr.R b/db/R/query.dplyr.R index 5c36256a99b..17be1215dec 100644 --- a/db/R/query.dplyr.R +++ b/db/R/query.dplyr.R @@ -143,6 +143,7 @@ get_workflow_ids <- function(bety, session,all.ids=FALSE) { # Get all workflow IDs ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% .[["workflow_id"]] %>% sort(decreasing = TRUE) + # pull(.,workflow_id) %>% sort(decreasing = TRUE) } return(ids) } # get_workflow_ids diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index ca813ea7fe7..fae04a4272b 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -9,57 +9,29 @@ library(scales) library(dplyr) # Define server logic server <- shinyServer(function(input, output, session) { - # options(shiny.trace=TRUE) bety <- betyConnect() - # bety <- betyConnect('/home/carya/pecan/web/config.php') - # Ranges not required. - # ranges <- reactiveValues(x = NULL, y = NULL) - print("RESTART") - # set the workflow id(s) - # Retrieving all workflow ids. - # Creating a new function here so that we wont have to modify the original one. - # Ideally the get_workflow_ids function in db/R/query.dplyr.R should take a flag to check - # if we want to load all workflow ids. - # get_all_workflow_ids <- function(bety) { - # ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% - # .[["workflow_id"]] %>% sort(decreasing = TRUE) - # return(ids) - # } - # get_workflow_ids - # ids <- get_all_workflow_ids(bety) - # ids <- get_all_workflow_ids(bety, session) - # Get all workflow ids - # Using this function here for now. - get_workflow_ids_all <- function(bety, session,all.ids=FALSE) { - query <- isolate(parseQueryString(session$clientData$url_search)) - # If we dont want all workflow ids but only workflow id from the user url query - if (!all.ids & "workflow_id" %in% names(query)) { - ids <- unlist(query[names(query) == "workflow_id"], use.names = FALSE) - } else { - # Get all workflow IDs - ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% - .[["workflow_id"]] %>% sort(decreasing = TRUE) - # pull(.,workflow_id) %>% sort(decreasing = TRUE) - } - return(ids) - } # get_workflow_ids - # Update all workflow ids observe({ + # Ideally the get_workflow_ids function (line 137) in db/R/query.dplyr.R should take a flag to check + # if we want to load all workflow ids. # get_workflow_id function from query.dplyr.R - all_ids <- get_workflow_ids_all(bety, session,all.ids=TRUE) + all_ids <- get_workflow_ids(bety, session,all.ids=TRUE) updateSelectizeInput(session, "all_workflow_id", choices=all_ids) }) - # Retrieves all run ids for seleted workflow ids - # Returns ('workflow ',w_id,', run ',r_id) + # Update all run ids all_run_ids <- reactive({ + # Retrieves all run ids for seleted workflow ids + # Returns ('workflow ',w_id,', run ',r_id) req(input$all_workflow_id) w_ids <- input$all_workflow_id + # Will return a list run_id_list <- c() for(w_id in w_ids){ + # For all the workflow ids r_ids <- get_run_ids(bety, w_id) for(r_id in r_ids){ - # . as a separator between multiple run ids + # Each workflow id can have more than one run ids + # ',' as a separator between workflow id and run id list_item <- paste0('workflow ',w_id,', run ',r_id) run_id_list <- c(run_id_list,list_item) } @@ -70,57 +42,10 @@ server <- shinyServer(function(input, output, session) { observe({ updateSelectizeInput(session, "all_run_id", choices=all_run_ids()) }) - # Update on load: workflow id for selected run ids (models) - # observe({ - # if(input$load){ - # req(input$all_run_id) - # # Selected `multiple' ids - # selected_id <- parse_ids_from_input_runID(input$all_run_id)$wID - # # To allow caching later - # display_id <- c(input$workflow_id,selected_id) - # updateSelectizeInput(session, "workflow_id", choices=display_id) - # } else{ - # session_workflow_id <- get_workflow_ids_all(bety, session) - # updateSelectizeInput(session, "workflow_id", choices=session_workflow_id) - # } - # }) - # Update run id for selected workflow id (model) - - # observe({ - # req(input$workflow_id) - # r_ID <- get_run_ids(bety, input$workflow_id) - # if(input$load){ - # req(input$all_run_id) - # # Selected `multiple' ids - # ids_DF <- parse_ids_from_input_runID(input$all_run_id) %>% filter(wID %in% input$workflow_id) - # # To allow caching later - # # Change variable name - # r_ID <- intersect(r_ID,ids_DF$runID) - # } - # updateSelectizeInput(session, "run_id", choices=r_ID) - # }) - # run_ids <- reactive({ - # req(input$workflow_id) - # r_ID <- get_run_ids(bety, input$workflow_id) - # if(input$load){ - # req(input$all_run_id) - # # Selected `multiple' ids - # selected_id <- parse_ids_from_input_runID(input$all_run_id)$wID - # # To allow caching later - # display_id <- c(input$workflow_id,selected_id) - # updateSelectizeInput(session, "workflow_id", choices=display_id) - # } else{ - # session_workflow_id <- get_workflow_ids_all(bety, session) - # updateSelectizeInput(session, "workflow_id", choices=session_workflow_id) - # } - # }) - # observe({ - # updateSelectizeInput(session, "run_id", choices=run_ids()) - # }) return_DF_from_run_ID <- function(diff_ids){ # Called by the function parse_ids_from_input_runID + # which is a wrapper of this function # Returns a DF for a particular run_id - # print(diff_ids) split_string <- strsplit(diff_ids,',')[[1]] # Workflow id is the first element. Trim leading and ending white spaces. Split by space now wID <- as.numeric(strsplit(trimws(split_string[1],which = c("both")),' ')[[1]][2]) @@ -128,86 +53,50 @@ server <- shinyServer(function(input, output, session) { runID <- as.numeric(strsplit(trimws(split_string[2],which = c("both")),' ')[[1]][2]) return(data.frame(wID,runID)) } + # Wrapper over return_DF_from_run_ID + # @param list of multiple run ids + # run_id_string: ('workflow' workflow_ID, 'run' run_id) + # @return Data Frame of workflow and run ids parse_ids_from_input_runID <- function(run_id_list){ - # global_id_DF <- data.frame() - # split_diff_ids <- strsplit(run_id_string,';')[[1]] - # for(diff_ids in split_diff_ids){ - # # run_id_string: 'workflow' workflow_ID, 'run' run_id - # # Split by comma to get workflow and run ids - # - # - globalDF <- data.frame() - for(w_run_id in run_id_list){ + globalDF <- data.frame() + for(w_run_id in run_id_list){ globalDF <- rbind(globalDF,return_DF_from_run_ID(w_run_id)) - } - # split_ids <- lapply(split_diff_ids , function(x) list_workflow_run_id(x)) - # local_id_DF <- data.frame(wID,runID) - # global_id_DF <- rbind(global_id_DF,local_id_DF) - return(globalDF) - } - # } - # Update variables if user changes run - # get_var_names_for_ID <- function(bety,wID,runID){ - # var_names <- get_var_names(bety, wID, runID) - # return(var_names) - # } - + } + return(globalDF) + } + # Fetches variable names from DB + # @param workflow_id and run_id + # @return List of variable names var_names_all <- function(workflow_id, run_id){ + # Get variables for a particular workflow and run id var_names <- get_var_names(bety, workflow_id, run_id) + # Remove variables which should not be shown to the user removeVarNames <- c('Year','FracJulianDay') - var_names <-var_names[!var_names %in% removeVarNames] + var_names <- var_names[!var_names %in% removeVarNames] return(var_names) } - - # var_names1 <- reactive({ - # # run_ids <- get_run_ids(bety, workflow_id()) - # # var_names <- get_var_names(bety, workflow_id(), run_ids[1]) - # # Removing the variables "Year" and "FracJulianDay" from the Variable Name input in the app - # req(input$workflow_id,input$run_id) - # workflow_id <- input$workflow_id - # run_id <- input$run_id - # var_names <- get_var_names(bety, workflow_id, run_id) - # removeVarNames <- c('Year','FracJulianDay') - # var_names <-var_names[!var_names %in% removeVarNames] - # return(var_names) - # # return(id_list) - # }) + # Update variable names observe({ req(input$all_run_id) + # All information about a model is contained in 'all_run_id' string ids_DF <- parse_ids_from_input_runID(input$all_run_id) var_name_list <- c() for(row_num in 1:nrow(ids_DF)){ var_name_list <- c(var_name_list,var_names_all(ids_DF$wID[row_num],ids_DF$runID[row_num])) - # var_name_list <- var_names_all(ids_DF$wID[row_num],ids_DF$runID[row_num]) } updateSelectizeInput(session, "variable_name", choices=var_name_list) }) - # If want to render text - # output$info <- renderText({ - # # indicators <- strsplit(input$indicators, ",")[[1]] - # - # # if(input$load){ - # # all_workflow_id <- strsplit(input$all_workflow_id,',') - # # } - # # d <- typeof(all_workflow_id) - # # paste0(input$all_run_id) - # - # paste0(parse_ids_from_input_runID(input$all_run_id)$runID) - # # paste0(input$load) - # # paste0(input$all_run_id[length(input$all_run_id)]) - # # paste0(input$variable_name) - # # paste0(run_ids(),length(run_ids()),ids) - # # ,session$clientData$url_search) - # # paste0("x=", input$plot_dblclick$x, "\ny=", input$plot_dblclick$y) - # }) - + # Load data for a single run of the model + # @param workflow_id and run_id + # @return Dataframe for one run + # For a particular combination of workflow and run id, loads + # all variables from all files. load_data_single_run <- function(workflow_id,run_id){ globalDF <- data.frame() workflow <- collect(workflow(bety, workflow_id)) - # var_names <- get_var_names(bety, workflow_id, run_id) - # removeVarNames <- c('Year','FracJulianDay') - # var_names <-var_names[!var_names %in% removeVarNames] + # Use the function 'var_names_all' to get all variables var_names <- var_names_all(workflow_id,run_id) + # Using earlier code, refactored if(nrow(workflow) > 0) { outputfolder <- file.path(workflow$folder, 'out', run_id) files <- list.files(outputfolder, "*.nc$", full.names=TRUE) @@ -220,10 +109,13 @@ server <- shinyServer(function(input, output, session) { ylab <- "" var <- ncdf4::ncatt_get(nc, var_name) #sw <- if ('Swdown' %in% names(nc$var)) ncdf4::ncvar_get(nc, 'Swdown') else TRUE + # Snow water sw <- TRUE + # Check required bcoz many files dont contain title if(!is.null(var$long_name)){ title <- var$long_name } + # Check required bcoz many files dont contain units if(!is.null(var$units)){ ylab <- var$units } @@ -234,99 +126,73 @@ server <- shinyServer(function(input, output, session) { dates <- as.Date(dates) vals <- if(is.na(vals)) y[b] else c(vals, y[b]) xlab <- "Time" - # Not required to change xlab by ranges. Using ggplotly. - # xlab <- if (is.null(ranges$x)) "Time" else paste(ranges$x, collapse=" - ") + # Values of the data which we will plot valuesDF <- data.frame(dates,vals) + # Meta information about the data metaDF <- data.frame(workflow_id,run_id,title,xlab,ylab,var_name) - # Populating metaDF as same length of values DF - # metaDF1<-metaDF[rep(seq_len(nrow(valuesDF))),] currentDF <- cbind(valuesDF,metaDF) globalDF <- rbind(globalDF,currentDF) } ncdf4::nc_close(nc) } } + # Required to convert from factors to characters + # Otherwise error by ggplotly globalDF$title <- as.character(globalDF$title) globalDF$xlab <- as.character(globalDF$xlab) globalDF$ylab <- as.character(globalDF$ylab) globalDF$var_name <- as.character(globalDF$var_name) return(globalDF) } - + # Loads data for all workflow and run ids after the load button is pressed. + # All information about a model is contained in 'all_run_id' string + # Wrapper over 'load_data_single_run' loadNewData <-eventReactive(input$load,{ - # workflow_id = 99000000077 - # run_id = 99000000002 - # var_name = var_names req(input$all_run_id) - globalDF <- data.frame() + # Get IDs DF from 'all_run_id' string ids_DF <- parse_ids_from_input_runID(input$all_run_id) + globalDF <- data.frame() for(row_num in 1:nrow(ids_DF)){ globalDF <- rbind(globalDF, load_data_single_run(ids_DF$wID[row_num],ids_DF$runID[row_num])) } return(globalDF) }) + # Renders the ggplotly output$outputPlot <- renderPlotly({ - # masterDF <- load_data_single_run(input$workflow_id,input$run_id) - masterDF <- loadNewData() - # output$info1 <- renderText({ - # paste0(nrow(masterDF)) - # paste0(length(unique(masterDF$run_id))) - # }) # Error messages validate( - # need(input$workflow_id, 'Found workflow id'), - # need(input$run_id, 'Run id detected'), - need(input$variable_name, 'Please wait! Loading data') + need(input$all_workflow_id, 'Select workflow id'), + need(input$all_run_id, 'Select Run id'), + need(input$variable_name, 'Click the button to load data') ) + # Load data + masterDF <- loadNewData() + # Convert from factor to character. For subsetting masterDF$var_name <- as.character(masterDF$var_name) + # Convert to factor. Required for ggplot masterDF$run_id <- as.factor(as.character(masterDF$run_id)) - - # masterDF$var_name = as.factor(masterDF$var_name) - # df1<-subset(masterDF,var_name==var_name) - - # Drop filtering + # Filter by variable name df <- masterDF %>% - dplyr::filter( - # workflow_id == input$workflow_id & - # run_id == input$run_id & - var_name == input$variable_name) - # %>% - # dplyr::select(dates,vals,workflow_id,run_id) - + dplyr::filter(var_name == input$variable_name) + # Meta information about the plot title <- unique(df$title) xlab <- unique(df$xlab) ylab <- unique(df$ylab) - # output$info2 <- renderText({ - # paste0(nrow(df)) - # # paste0(typeof(title)) - # }) - # output$info3 <- renderText({ - # paste0('xlab') - # # paste0(typeof(title)) - # }) - - # df1<-masterDF %>% filter(masterDF$var_name %in% var_name) - # workflow_id %in% workflow_id) - # & run_id == run_id & var_name == var_name) - # df<-masterDF %>% dplyr::filter(workflow_id == input$workflow_id) + # ggplot function for now scatter plots. + # TODO Shubham allow line plots as well plt <- ggplot(df, aes(x=dates, y=vals, color=run_id)) + - # geom_point(aes(color="Model output")) + geom_point() + - # geom_smooth(aes(fill = "Spline fit")) + - # coord_cartesian(xlim = ranges$x, ylim = ranges$y) + + # Earlier smoothing and y labels + # geom_smooth(aes(fill = "Spline fit")) + # scale_y_continuous(labels=fancy_scientific) + labs(title=title, x=xlab, y=ylab) - # labs(title=unique(df$title)[1], x=unique(df$xlab)[1], y=unique(df$ylab)[1]) + + # Earlier color and fill values # scale_color_manual(name = "", values = "black") + # scale_fill_manual(name = "", values = "grey50") - # theme(axis.text.x = element_text(angle = -90)) plt<-ggplotly(plt) - # plot(plt) + # Not able to add icon over ggplotly # add_icon() - # } - # } }) - # Shiny server closes here }) diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index a8f6db5d8cd..a2c7673474a 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -1,39 +1,21 @@ library(shiny) source('helper.R') - # Define UI ui <- shinyUI(fluidPage( # Application title titlePanel("Workflow Plots"), - sidebarLayout( sidebarPanel( # helpText(), - p("Please select the workflow ID to continue. You can select multiple IDs"), + p("Please select the workflow IDs to continue. You can select multiple IDs"), selectizeInput("all_workflow_id", "Mutliple Workflow IDs", c(),multiple=TRUE), - p("Please select the run ID. You can select multiple IDs"), + p("Please select the run IDs. You can select multiple IDs"), selectizeInput("all_run_id", "Mutliple Run IDs", c(),multiple=TRUE), actionButton("load", "Load Model outputs"), - # selectInput("workflow_id", "Workflow ID", c()), - # selectInput("run_id", "Run ID", c()), selectInput("variable_name", "Variable Name", "") - - # selectInput("workflow_id", "Workflow ID", c(99000000077)), - # selectInput("run_id", "Run ID", c(99000000002)), - # selectInput("variable_name", "Variable Name", c("AutoResp","GPP")) ), mainPanel( - plotlyOutput("outputPlot" - ## brushOpts and dblclick not supported by plotly - # brush = brushOpts(id = "plot_brush", - # resetOnNew = TRUE), - # dblclick = "plot_dblclick" - ) - # Checking variable names - # verbatimTextOutput("info"), - # verbatimTextOutput("info1"), - # verbatimTextOutput("info2"), - # verbatimTextOutput("info3") + plotlyOutput("outputPlot") ) ) )) From 9f7185c23488e192f281f57f41157f05b9a224c6 Mon Sep 17 00:00:00 2001 From: Ann Raiho Date: Sat, 24 Jun 2017 18:54:04 -0400 Subject: [PATCH 058/771] small changes --- models/sipnet/R/sample.IC.SIPNET.R | 4 +- modules/assim.sequential/R/sda.enkf.R | 55 ++++++++++++++++++--------- 2 files changed, 39 insertions(+), 20 deletions(-) diff --git a/models/sipnet/R/sample.IC.SIPNET.R b/models/sipnet/R/sample.IC.SIPNET.R index 4c130a2187a..869d655d198 100644 --- a/models/sipnet/R/sample.IC.SIPNET.R +++ b/models/sipnet/R/sample.IC.SIPNET.R @@ -23,12 +23,12 @@ sample.IC.SIPNET <- function(ne, state, year = 1) { ## Mg C / ha / yr NPP NPP <- ifelse(rep("NPP" %in% names(state), ne), - state$NPP[1, sample.int(ncol(state$NPP), ne), year], # *.48, ## unit MgC/ha/yr + udunits2::ud.convert(state$NPP[sample.int(length(state$NPP), ne)],'kg/m^2/s','Mg/ha/yr'), # *.48, ## unit MgC/ha/yr runif(ne, 0, 10)) ## prior # g C * m-2 ground area in wood (above-ground + roots) plantWood <- ifelse(rep("AGB" %in% names(state), ne), - state$AGB[1, sample.int(ncol(state$AGB), ne), year] * (1/1000) * (1e+06/1), ## unit KgC/ha -> g C /m^2 + udunits2::ud.convert(state$AGB[sample.int(length(state$AGB), ne)],'kg/m^2','g/m^2'), ## unit KgC/ha -> g C /m^2 runif(ne, 0, 14000)) ## prior # initial leaf area, m2 leaves * m-2 ground area (multiply by leafCSpWt to diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index 0b34db78727..7ed0f77d369 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -466,11 +466,19 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { Pf <- Pf + Q } - mu.f.scale <- scale(mu.f, center = mean(mu.f), scale = 1) - Pf.scale <- cov(scale(X, center = mu.f, scale = rep(1,length(mu.f)))) + mu.f.scale <- mu.f / mu.f + mu.f.scale[is.na(mu.f.scale)]<-0 + map.mu.f <- H%*%mu.f + Y.scale <- Y/map.mu.f ##need H in here to match mu.f's to Y's + Pf.scale <- t(t(Pf/mu.f)/mu.f) Pf.scale[is.na(Pf.scale)]<-0 - R.scale <- matrix(scale(as.vector(R), center = mean(mu.f), scale = 1),2,2) - Y.scale <- scale(Y, center = mean(mu.f[1:2]), scale = 1) + R.scale <- t(t(R/as.vector(map.mu.f))/as.vector(map.mu.f)) + + # mu.f.scale <- scale(mu.f,center = FALSE, scale = mean(mu.f)) + # Pf.scale <- mu.f*Pf%*%t(t(mu.f)) + # Pf.scale[is.na(Pf.scale)]<-0 + # R.scale <- matrix(scale(as.vector(R), center = mean(mu.f), scale = 1),2,2) + # Y.scale <- scale(Y, center = mean(mu.f[1:2]), scale = 1) ## Kalman Gain K <- Pf.scale %*% t(H) %*% solve((R.scale + H %*% Pf.scale %*% t(H))) @@ -478,9 +486,8 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { mu.a.scale <- mu.f.scale + K %*% (Y.scale - H %*% mu.f.scale) Pa.scale <- (diag(ncol(X)) - K %*% H) %*% Pf.scale - Pa <- Pa.scale * attr(mu.f.scale, 'scaled:scale') + attr(mu.f.scale, 'scaled:center') - mu.a <- mu.a.scale * attr(mu.f.scale, 'scaled:scale') + attr(mu.f.scale, 'scaled:center') - + Pa <- t(t(Pa.scale*mu.f)*mu.f) + mu.a <- mu.a.scale * mu.f ## Kalman Gain #K <- Pf %*% t(H) %*% solve((R + H %*% Pf %*% t(H))) @@ -795,9 +802,9 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # ## check if ensemble var is correct # cbind(as.vector(Pa),as.vector(cov(X_a))) # - # analysis <- as.data.frame(rmvnorm(as.numeric(nens), mu.a, Pa, method = "svd")) + analysis <- as.data.frame(rmvnorm(as.numeric(nens), mu.a, Pa, method = "svd")) - analysis <- as.data.frame(X_a) + #analysis <- as.data.frame(X_a) colnames(analysis) <- colnames(X) ##### Mapping analysis vectors to be in bounds of state variables @@ -826,7 +833,8 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { tmp[mch] <- x[mch] tmp })) - Ybar <- Ybar[, na.omit(pmatch(colnames(X), colnames(Ybar)))] + Y.order <- na.omit(pmatch(colnames(X), colnames(Ybar))) + Ybar <- Ybar[,Y.order] YCI <- t(as.matrix(sapply(obs.cov[t1:t], function(x) { if (is.null(x)) { rep(NA, length(names.y)) @@ -834,6 +842,8 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { sqrt(diag(x)) }))) + YCI <- YCI[,Y.order] + par(mfrow = c(2, 1)) for (i in 1:ncol(FORECAST[[t]])) {# t1 <- 1 @@ -846,16 +856,17 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ylab.names <- unlist(sapply(settings$state.data.assimilation$state.variable, function(x) { x })[2, ], use.names = FALSE) - plot(as.Date(obs.times[t1:t]), - Xbar, - ylim = range(c(XaCI, Xci), na.rm = TRUE), - type = "n", - xlab = "Year", - ylab = ylab.names[grep(colnames(X)[i], var.names)], - main = colnames(X)[i]) + # observation / data if (i <= ncol(Ybar)) { + plot(as.Date(obs.times[t1:t]), + Xbar, + ylim = range(c(XaCI, Xci, Ybar[,i]), na.rm = TRUE), + type = "n", + xlab = "Year", + ylab = ylab.names[grep(colnames(X)[i], var.names)], + main = colnames(X)[i]) ciEnvelope(as.Date(obs.times[t1:t]), as.numeric(Ybar[, i]) - as.numeric(YCI[, i]) * 1.96, as.numeric(Ybar[, i]) + as.numeric(YCI[, i]) * 1.96, @@ -865,6 +876,14 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { type = "l", col = "darkgreen", lwd = 2) + }else{ + plot(as.Date(obs.times[t1:t]), + Xbar, + ylim = range(c(XaCI, Xci), na.rm = TRUE), + type = "n", + xlab = "Year", + ylab = ylab.names[grep(colnames(X)[i], var.names)], + main = colnames(X)[i]) } # forecast @@ -874,7 +893,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # analysis ciEnvelope(as.Date(obs.times[t1:t]), XaCI[, 1], XaCI[, 2], col = alphapink) lines(as.Date(obs.times[t1:t]), Xa, col = "black", lty = 2, lwd = 2) - legend('topright',c('Forecast','Data','Analysis'),col=c(alphablue,alphagreen,alphapink),lty=1,lwd=5) + #legend('topright',c('Forecast','Data','Analysis'),col=c(alphablue,alphagreen,alphapink),lty=1,lwd=5) } } From e14cbafbce6a122259b256331937d188c5848195 Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Wed, 28 Jun 2017 09:05:55 -0400 Subject: [PATCH 059/771] Updates to job templates. Cloning still doesn't work as it should --- models/fates/inst/template.job | 41 ++--- models/fates/inst/template.job.create_clone | 190 ++++++++++++++++++++ 2 files changed, 211 insertions(+), 20 deletions(-) create mode 100644 models/fates/inst/template.job.create_clone diff --git a/models/fates/inst/template.job b/models/fates/inst/template.job index 7ed2e9b05fd..8e72f806f70 100644 --- a/models/fates/inst/template.job +++ b/models/fates/inst/template.job @@ -64,8 +64,8 @@ export GFORTRAN_UNBUFFERED_PRECONNECTED=yes # Modifying : env_run.xml ./xmlchange -file env_run.xml -id REST_N -val 1 ./xmlchange -file env_run.xml -id REST_OPTION -val nyears -./xmlchange -file env_run.xml -id DATM_CLMNCEP_YR_START -val 1999 -./xmlchange -file env_run.xml -id DATM_CLMNCEP_YR_END -val 1999 +./xmlchange -file env_run.xml -id DATM_CLMNCEP_YR_START -val 1974 +./xmlchange -file env_run.xml -id DATM_CLMNCEP_YR_END -val 2004 ./xmlchange -file env_run.xml -id DIN_LOC_ROOT -val @INDIR@ ./xmlchange -file env_run.xml -id DIN_LOC_ROOT_CLMFORC -val '@INDIR@' ./xmlchange -file env_run.xml -id DOUT_S -val TRUE @@ -80,9 +80,9 @@ export GFORTRAN_UNBUFFERED_PRECONNECTED=yes ## ENV_BUILD update configurations ./xmlchange -file env_build.xml -id CIME_OUTPUT_ROOT -val @CASEDIR@ - #./xmlchange -file env_build.xml -id EXEROOT -val @BLD@ - ./xmlchange -file env_build.xml -id EXEROOT -val @CASEDIR@/bld - #./xmlchange -file env_build.xml -id BUILD_COMPLETE -val TRUE + #./xmlchange -file env_build.xml -id EXEROOT -val @BLD@ # this is the way it should be set, long term + ./xmlchange -file env_build.xml -id EXEROOT -val @CASEDIR@/bld # temporary fix + #./xmlchange -file env_build.xml -id BUILD_COMPLETE -val TRUE # TEMPORARY! This eventually needs to be uncommented so we don't build the model each time ! ## DATES -> ENV_RUN ./xmlchange -file env_run.xml -id RUNDIR -val @CASEDIR@/run @@ -134,8 +134,7 @@ EOF echo "*** Run case.build ***" sleep 10 - ./case.build - #./case.build --sharedlib-only + ./case.build # ! Long run, we should not be building the model. But current BUILD_COMPLETE doesn't seem to be working ! ## RUN echo "*** Run ***" @@ -146,20 +145,22 @@ EOF echo `pwd` echo `ls -altr` - ## RUNDIR FILE LINKS - if [ -e @RUNDIR@/datm_atm_in] - then - rm datm_atm_in - ln -s @RUNDIR@/datm_atm_in . - fi - if [ -e @RUNDIR@/datm.streams.txt.PEcAn_met] - then - rm datm.stream.txt.CLM_QIAN* - ln -s @RUNDIR@/datm.streams.txt.PEcAn_met . - fi + ## RUNDIR FILE LINKS -- CURRENTLY GETTING SEG FAULTS WHEN TRYING TO RUN WITH PECAN MET + #if [ -e @RUNDIR@/datm_atm_in ] + # then + # rm datm_atm_in datm_in + # ln -s @RUNDIR@/datm_atm_in . + # ln -s @RUNDIR@/datm_atm_in datm_in + #fi + #if [ -e @RUNDIR@/datm.streams.txt.PEcAn_met ] + # then + #rm datm.stream.txt.CLM_QIAN* + # rm datm.streams.txt.CLM_QIAN* # bug fix, s was missing! + # ln -s @RUNDIR@/datm.streams.txt.PEcAn_met . + #fi - #"@BINARY@" # EDITED BY SPS - "@CASEDIR@/bld/cesm.exe" # edited for testing + #"@BINARY@" # ! Long term, we should be running it this way ! + "@CASEDIR@/bld/cesm.exe" # edited for testing, ! TEMPORARY. NEED TO SWITCH BACK ONCE BUILD_COMPLETE works ! STATUS=$? diff --git a/models/fates/inst/template.job.create_clone b/models/fates/inst/template.job.create_clone new file mode 100644 index 00000000000..c2166a77f04 --- /dev/null +++ b/models/fates/inst/template.job.create_clone @@ -0,0 +1,190 @@ +#!/bin/bash -l + +# redirect output +exec 3>&1 +exec &> "@OUTDIR@/logfile.txt" + +# host specific setup +@HOST_SETUP@ + +# create output folder +mkdir -p "@OUTDIR@" + +# flag needed for ubuntu +export GFORTRAN_UNBUFFERED_PRECONNECTED=yes + +# see if application needs running +#if [ ! -e "@OUTDIR@/pecan.done" ]; then + + ## Figure out where CIME SCRIPTS are installed + cd @REFCASE@ + IFS=' ' read -ra SCRIPTROOT <<< `./xmlquery SCRIPTSROOT -value` + echo "CIME script root: " + echo ${SCRIPTROOT} + + ## Seem to be stuck having to build a new case. Will try and avoid this in the future + cd ${SCRIPTROOT} + echo "*** Run create_newcase ***" + echo " ----- Case details:" + echo @CASEDIR@ + #echo "Res: @RES@ " + #echo "Compset: @COMPSET@ " + #echo "Machine: @MACHINE@ " + #echo "Compiler: @COMPILER@ " + #echo "Project_name: @PROJECT@ " + echo "--------------------------" + #./create_newcase -case @CASEDIR@ -res 1x1_brazil -compset ICLM45ED -mach @MACHINE@ -compiler @COMPILER@ -project @PROJECT@ + ./create_clone --verbose --case @CASEDIR@ --clone @REFCASE@ --keepexe + + cd "@RUNDIR@" + + ## RECURSIVELY COPY/SYMLINK REFERENCE INPUTS DIRECTORY (DIN_LOC_ROOT) + ## create folders and symbolic links. Links will later be deleted when non-default files are specified + mkdir input + echo "PEcAn.FATES::recurse.create('input','@DEFAULT@')" | R --vanilla + + cd "@CASEDIR@" + + ## THINGS THAT ARE IN REFCASE + # Modifying : env_mach_pes.xml + echo "*** Modify XMLs ***" +./xmlchange -file env_mach_pes.xml -id NTASKS_ATM -val 1 +./xmlchange -file env_mach_pes.xml -id NTASKS_LND -val 1 +./xmlchange -file env_mach_pes.xml -id NTASKS_ICE -val 1 +./xmlchange -file env_mach_pes.xml -id NTASKS_OCN -val 1 +./xmlchange -file env_mach_pes.xml -id NTASKS_CPL -val 1 +./xmlchange -file env_mach_pes.xml -id NTASKS_GLC -val 1 +./xmlchange -file env_mach_pes.xml -id NTASKS_ROF -val 1 +./xmlchange -file env_mach_pes.xml -id NTASKS_WAV -val 1 +./xmlchange -file env_mach_pes.xml -id MAX_TASKS_PER_NODE -val 1 +./xmlchange -file env_mach_pes.xml -id TOTALPES -val 1 + # Modifying : env_build.xml +./xmlchange -file env_build.xml -id GMAKE -val make +./xmlchange -file env_build.xml -id DEBUG -val FALSE + # Modifying : env_run.xml +./xmlchange -file env_run.xml -id REST_N -val 1 +./xmlchange -file env_run.xml -id REST_OPTION -val nyears +./xmlchange -file env_run.xml -id DATM_CLMNCEP_YR_START -val 1974 +./xmlchange -file env_run.xml -id DATM_CLMNCEP_YR_END -val 2004 +./xmlchange -file env_run.xml -id DIN_LOC_ROOT -val @INDIR@ +./xmlchange -file env_run.xml -id DIN_LOC_ROOT_CLMFORC -val '@INDIR@' +./xmlchange -file env_run.xml -id DOUT_S -val TRUE +./xmlchange -file env_run.xml -id DOUT_S_ROOT -val '@CASEDIR@/run' +./xmlchange -file env_run.xml -id PIO_DEBUG_LEVEL -val 0 +./xmlchange -file env_run.xml -id ATM_DOMAIN_FILE -val 'domain.lnd.@SITE_NAME@.nc' +./xmlchange -file env_run.xml -id ATM_DOMAIN_PATH -val '@INDIR@/share/domains/domain.clm/' +./xmlchange -file env_run.xml -id LND_DOMAIN_FILE -val 'domain.lnd.@SITE_NAME@.nc' +./xmlchange -file env_run.xml -id LND_DOMAIN_PATH -val '@INDIR@/share/domains/domain.clm/' +./xmlchange -file env_run.xml -id CLM_USRDAT_NAME -val '@SITE_NAME@' +## END REFCASE + + ## ENV_BUILD update configurations + ./xmlchange -file env_build.xml -id CIME_OUTPUT_ROOT -val @CASEDIR@ + ./xmlchange -file env_build.xml -id EXEROOT -val @BLD@ # this is the way it should be set, long term + #./xmlchange -file env_build.xml -id EXEROOT -val @CASEDIR@/bld # temporary fix + ./xmlchange -file env_build.xml -id BUILD_COMPLETE -val TRUE # TEMPORARY! This eventually needs to be uncommented so we don't build the model each time ! + + ## DATES -> ENV_RUN + ./xmlchange -file env_run.xml -id RUNDIR -val @CASEDIR@/run + ./xmlchange -file env_run.xml -id RUN_STARTDATE -val @START_DATE@ + ./xmlchange -file env_run.xml -id STOP_OPTION -val ndays + ./xmlchange -file env_run.xml -id STOP_N -val @STOP_N@ + + ## SITE INFO --> DOMAIN FILE + rm @INDIR@/share/domains/domain.clm/* + ln -s @RUNDIR@/domain.lnd.@SITE_NAME@.nc @INDIR@/share/domains/domain.clm/ + + ## SURFDATA + rm @INDIR@/lnd/clm2/surfdata_map/surfdata* + ln -s @RUNDIR@/surfdata_@SITE_NAME@_simyr2000.nc @INDIR@/lnd/clm2/surfdata_map/ + SURFMAP=@INDIR@/lnd/clm2/surfdata_map/surfdata_@SITE_NAME@_simyr2000.nc +cat >> user_nl_clm << EOF +fsurdat = '@INDIR@/lnd/clm2/surfdata_map/surfdata_@SITE_NAME@_simyr2000.nc' +finidat = ' ' +EOF + + ## PARAMETERS + rm @INDIR@/lnd/clm2/paramdata/* + #ln -s @RUNDIR@/clm_params_ed.@RUN_ID@.nc @INDIR@/lnd/clm2/paramdata/ + ln -s @RUNDIR@/clm_params.@RUN_ID@.nc @INDIR@/lnd/clm2/paramdata/ + ln -s @RUNDIR@/fates_params.@RUN_ID@.nc @INDIR@/lnd/clm2/paramdata/ +#cat >> user_nl_clm << EOF +#paramfile = '@INDIR@/lnd/clm2/paramdata/clm_params_ed.@RUN_ID@.nc' +#EOF +cat >> user_nl_clm << EOF +fates_paramfile = '@INDIR@/lnd/clm2/paramdata/fates_params.@RUN_ID@.nc' +paramfile = '@INDIR@/lnd/clm2/paramdata/clm_params.@RUN_ID@.nc' +EOF + + ## APPLY CONFIG CHANGES + echo "*** Run case.setup ***" + ./case.setup + + ## ADDITIONAL MODS THAT ARE JUST ASSOCIATED WITH REFCASE - removed 'NEP' 'NPP_column' +cat >> user_nl_clm << EOF +hist_empty_htapes = .true. +hist_fincl1='EFLX_LH_TOT','TSOI_10CM','QVEGT','GPP','AR','ED_bleaf','ED_biomass','NPP','MAINT_RESP','GROWTH_RESP' +hist_mfilt = 8760 +hist_nhtfrq = -1 +EOF + +# Modify user_nl_datm +#cat >> user_nl_datm << EOF +#EOF + + echo "*** Run case.build ***" + sleep 10 + ./case.build # ! Long run, we should not be building the model. But current BUILD_COMPLETE doesn't seem to be working ! + + ## RUN + echo "*** Run ***" + now=`date` + echo "Simulation start: $now" + cd run + mkdir timing + echo `pwd` + echo `ls -altr` + + ## RUNDIR FILE LINKS -- CURRENTLY GETTING SEG FAULTS WHEN TRYING TO RUN WITH PECAN MET + #if [ -e @RUNDIR@/datm_atm_in ] + # then + # rm datm_atm_in datm_in + # ln -s @RUNDIR@/datm_atm_in . + # ln -s @RUNDIR@/datm_atm_in datm_in + #fi + #if [ -e @RUNDIR@/datm.streams.txt.PEcAn_met ] + # then + #rm datm.stream.txt.CLM_QIAN* + # rm datm.streams.txt.CLM_QIAN* # bug fix, s was missing! + # ln -s @RUNDIR@/datm.streams.txt.PEcAn_met . + #fi + + "@BINARY@" # ! Long term, we should be running it this way ! + #"@CASEDIR@/bld/cesm.exe" # edited for testing, ! TEMPORARY. NEED TO SWITCH BACK ONCE BUILD_COMPLETE works ! + STATUS=$? + + + # check the status + if [ $STATUS -ne 0 ]; then + echo -e "ERROR IN MODEL RUN\nLogfile is located at '@OUTDIR@/logfile.txt'" >&3 + exit $STATUS + fi + +# host specific post-run +@HOST_TEARDOWN@ + + # convert output + cp *clm2.h0.*.nc @OUTDIR@ + echo "library(PEcAn.FATES); model2netcdf.FATES('@OUTDIR@')" | R --vanilla + + + # copy readme with specs to output + cp "@RUNDIR@/README.txt" "@OUTDIR@/README.txt" + + # write tag so future execution knows run finished + echo $(date) >> "@OUTDIR@/pecan.done" + + sleep 60 + +# all done +echo -e "MODEL FINISHED\nLogfile is located at '@OUTDIR@/logfile.txt'" >&3 From a2e3e749ab4868f4b1954adeec90639704b90679 Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Thu, 29 Jun 2017 15:06:04 -0400 Subject: [PATCH 060/771] Update to template.job --- models/fates/inst/template.job | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/models/fates/inst/template.job b/models/fates/inst/template.job index 8e72f806f70..037fa96eed5 100644 --- a/models/fates/inst/template.job +++ b/models/fates/inst/template.job @@ -145,6 +145,7 @@ EOF echo `pwd` echo `ls -altr` + ## ----------- Disabled for now ## RUNDIR FILE LINKS -- CURRENTLY GETTING SEG FAULTS WHEN TRYING TO RUN WITH PECAN MET #if [ -e @RUNDIR@/datm_atm_in ] # then @@ -158,7 +159,8 @@ EOF # rm datm.streams.txt.CLM_QIAN* # bug fix, s was missing! # ln -s @RUNDIR@/datm.streams.txt.PEcAn_met . #fi - + ## ------------- MET needs to be re-enabled in a later PR + #"@BINARY@" # ! Long term, we should be running it this way ! "@CASEDIR@/bld/cesm.exe" # edited for testing, ! TEMPORARY. NEED TO SWITCH BACK ONCE BUILD_COMPLETE works ! STATUS=$? From e3c663d90e80a80a7c681fe8fcc750b4ad31b117 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sat, 1 Jul 2017 17:06:29 -0500 Subject: [PATCH 061/771] Moving functions from helper.R to query.dplyr.R --- db/R/query.dplyr.R | 83 +++++++++++++++++++++++++++++++++++++ shiny/workflowPlot/helper.R | 2 - shiny/workflowPlot/server.R | 41 +++++++++--------- visualization/DESCRIPTION | 6 ++- 4 files changed, 108 insertions(+), 24 deletions(-) diff --git a/db/R/query.dplyr.R b/db/R/query.dplyr.R index 17be1215dec..310df3460cd 100644 --- a/db/R/query.dplyr.R +++ b/db/R/query.dplyr.R @@ -210,3 +210,86 @@ get_var_names <- function(bety, workflow_id, run_id, remove_pool = TRUE) { } return(var_names) } # get_var_names + +#' Get vector of variable names for a particular workflow and run ID +#' @inheritParams dbHostInfo +#' @inheritParams workflow +#' @param run_id Run ID +#' @param workflow_id Workflow ID +#' @export +var_names_all <- function(bety, workflow_id, run_id) { + # @return List of variable names + # Get variables for a particular workflow and run id + var_names <- get_var_names(bety, workflow_id, run_id) + # Remove variables which should not be shown to the user + removeVarNames <- c('Year','FracJulianDay') + var_names <- var_names[!var_names %in% removeVarNames] + return(var_names) +} # var_names_all + +#' Load data for a single run of the model +#' @inheritParams dbHostInfo +#' @inheritParams workflow +#' @param run_id Run ID +#' @param workflow_id Workflow ID +#' @export +load_data_single_run <- function(bety, workflow_id,run_id) { + # For a particular combination of workflow and run id, loads + # all variables from all files. + # @return Dataframe for one run + # Adapted from earlier code in pecan/shiny/workflowPlot/server.R + globalDF <- data.frame() + workflow <- collect(workflow(bety, workflow_id)) + # Use the function 'var_names_all' to get all variables + removeVarNames <- c('Year','FracJulianDay') + var_names <- var_names_all(bety,workflow_id,run_id) + # Using earlier code, refactored + if(nrow(workflow) > 0) { + outputfolder <- file.path(workflow$folder, 'out', run_id) + files <- list.files(outputfolder, "*.nc$", full.names=TRUE) + for(file in files) { + nc <- nc_open(file) + for(var_name in var_names){ + dates <- NA + vals <- NA + title <- var_name + ylab <- "" + var <- ncdf4::ncatt_get(nc, var_name) + #sw <- if ('Swdown' %in% names(nc$var)) ncdf4::ncvar_get(nc, 'Swdown') else TRUE + # Snow water + sw <- TRUE + # Check required bcoz many files don't contain title + if(!is.null(var$long_name)){ + title <- var$long_name + } + # Check required bcoz many files don't contain units + if(!is.null(var$units)){ + ylab <- var$units + } + x <- ncdays2date(ncdf4::ncvar_get(nc, 'time'), ncdf4::ncatt_get(nc, 'time')) + y <- ncdf4::ncvar_get(nc, var_name) + b <- !is.na(x) & !is.na(y) & sw != 0 + dates <- if(is.na(dates)) x[b] else c(dates, x[b]) + dates <- as.Date(dates) + vals <- if(is.na(vals)) y[b] else c(vals, y[b]) + xlab <- "Time" + # Values of the data which we will plot + valuesDF <- data.frame(dates,vals) + # Meta information about the data. + metaDF <- data.frame(workflow_id,run_id,title,xlab,ylab,var_name) + # Meta and Values DF created differently because they would of different + # number of rows. cbind would repeat metaDF(1X6) to the size of valuesDF + currentDF <- cbind(valuesDF,metaDF) + globalDF <- rbind(globalDF,currentDF) + } + ncdf4::nc_close(nc) + } + } + # Required to convert from factors to characters + # Otherwise error by ggplotly + globalDF$title <- as.character(globalDF$title) + globalDF$xlab <- as.character(globalDF$xlab) + globalDF$ylab <- as.character(globalDF$ylab) + globalDF$var_name <- as.character(globalDF$var_name) + return(globalDF) +} #load_data_single_run diff --git a/shiny/workflowPlot/helper.R b/shiny/workflowPlot/helper.R index 9390b6d30b7..978e37e0a8a 100644 --- a/shiny/workflowPlot/helper.R +++ b/shiny/workflowPlot/helper.R @@ -10,5 +10,3 @@ isInstalled <- function(mypkg){ is.element(mypkg, installed.packages()[,1]) } checkAndDownload(c('plotly','scales','dplyr')) -# devtools::install_github('hadley/ggplot2') -# testVal = 5 \ No newline at end of file diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index fae04a4272b..6672a607510 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -3,6 +3,7 @@ library(PEcAn.DB) library(shiny) library(ncdf4) library(ggplot2) +# Helper allows to load functions and variables that could be shared both by server.R and ui.R source('helper.R') library(plotly) library(scales) @@ -12,7 +13,7 @@ server <- shinyServer(function(input, output, session) { bety <- betyConnect() # Update all workflow ids observe({ - # Ideally the get_workflow_ids function (line 137) in db/R/query.dplyr.R should take a flag to check + # Ideally get_workflow_ids function (line 137) in db/R/query.dplyr.R should take a flag to check # if we want to load all workflow ids. # get_workflow_id function from query.dplyr.R all_ids <- get_workflow_ids(bety, session,all.ids=TRUE) @@ -43,7 +44,7 @@ server <- shinyServer(function(input, output, session) { updateSelectizeInput(session, "all_run_id", choices=all_run_ids()) }) return_DF_from_run_ID <- function(diff_ids){ - # Called by the function parse_ids_from_input_runID + # Called by function parse_ids_from_input_runID # which is a wrapper of this function # Returns a DF for a particular run_id split_string <- strsplit(diff_ids,',')[[1]] @@ -67,14 +68,14 @@ server <- shinyServer(function(input, output, session) { # Fetches variable names from DB # @param workflow_id and run_id # @return List of variable names - var_names_all <- function(workflow_id, run_id){ - # Get variables for a particular workflow and run id - var_names <- get_var_names(bety, workflow_id, run_id) - # Remove variables which should not be shown to the user - removeVarNames <- c('Year','FracJulianDay') - var_names <- var_names[!var_names %in% removeVarNames] - return(var_names) - } + # var_names_all <- function(bety,workflow_id, run_id){ + # # Get variables for a particular workflow and run id + # var_names <- get_var_names(bety, workflow_id, run_id) + # # Remove variables which should not be shown to the user + # removeVarNames <- c('Year','FracJulianDay') + # var_names <- var_names[!var_names %in% removeVarNames] + # return(var_names) + # } # Update variable names observe({ req(input$all_run_id) @@ -82,20 +83,20 @@ server <- shinyServer(function(input, output, session) { ids_DF <- parse_ids_from_input_runID(input$all_run_id) var_name_list <- c() for(row_num in 1:nrow(ids_DF)){ - var_name_list <- c(var_name_list,var_names_all(ids_DF$wID[row_num],ids_DF$runID[row_num])) + var_name_list <- c(var_name_list,var_names_all(bety,ids_DF$wID[row_num],ids_DF$runID[row_num])) } updateSelectizeInput(session, "variable_name", choices=var_name_list) }) - # Load data for a single run of the model - # @param workflow_id and run_id - # @return Dataframe for one run - # For a particular combination of workflow and run id, loads - # all variables from all files. - load_data_single_run <- function(workflow_id,run_id){ + # # Load data for a single run of the model + # # @param workflow_id and run_id + # # @return Dataframe for one run + # # For a particular combination of workflow and run id, loads + # # all variables from all files. + load_data_single_run <- function(bety,workflow_id,run_id){ globalDF <- data.frame() workflow <- collect(workflow(bety, workflow_id)) # Use the function 'var_names_all' to get all variables - var_names <- var_names_all(workflow_id,run_id) + var_names <- var_names_all(bety,workflow_id,run_id) # Using earlier code, refactored if(nrow(workflow) > 0) { outputfolder <- file.path(workflow$folder, 'out', run_id) @@ -153,7 +154,7 @@ server <- shinyServer(function(input, output, session) { ids_DF <- parse_ids_from_input_runID(input$all_run_id) globalDF <- data.frame() for(row_num in 1:nrow(ids_DF)){ - globalDF <- rbind(globalDF, load_data_single_run(ids_DF$wID[row_num],ids_DF$runID[row_num])) + globalDF <- rbind(globalDF, load_data_single_run(bety,ids_DF$wID[row_num],ids_DF$runID[row_num])) } return(globalDF) }) @@ -193,7 +194,7 @@ server <- shinyServer(function(input, output, session) { # Not able to add icon over ggplotly # add_icon() }) - # Shiny server closes here +# Shiny server closes here }) # runApp(port=6480, launch.browser=FALSE) diff --git a/visualization/DESCRIPTION b/visualization/DESCRIPTION index 8cb0f6fc2f2..1fec24918f3 100644 --- a/visualization/DESCRIPTION +++ b/visualization/DESCRIPTION @@ -28,13 +28,15 @@ Depends: PEcAn.DB, RPostgreSQL, dplyr, - dbplyr + dbplyr, + plotly Imports: lubridate (>= 1.6.0), ncdf4 (>= 1.15), plyr (>= 1.8.4), stringr(>= 1.1.0), - udunits2 (>= 0.11) + udunits2 (>= 0.11), + plotly(>=4.6.0) Suggests: testthat (>= 1.0.2), png, From 17f1e88dc7ad28a50a7222e82d619c3b4eaf0303 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sat, 1 Jul 2017 21:04:19 -0500 Subject: [PATCH 062/771] Updating PR based on comments --- db/NAMESPACE | 2 + db/R/query.dplyr.R | 6 +-- db/man/get_workflow_ids.Rd | 2 +- db/man/load_data_single_run.Rd | 18 +++++++++ db/man/var_names_all.Rd | 18 +++++++++ shiny/workflowPlot/server.R | 69 ---------------------------------- 6 files changed, 41 insertions(+), 74 deletions(-) create mode 100644 db/man/load_data_single_run.Rd create mode 100644 db/man/var_names_all.Rd diff --git a/db/NAMESPACE b/db/NAMESPACE index 10a6ffa767b..772019202cf 100644 --- a/db/NAMESPACE +++ b/db/NAMESPACE @@ -30,6 +30,7 @@ export(get_run_ids) export(get_users) export(get_var_names) export(get_workflow_ids) +export(load_data_single_run) export(ncdays2date) export(query.base) export(query.base.con) @@ -45,5 +46,6 @@ export(rename.jags.columns) export(runModule.get.trait.data) export(runs) export(take.samples) +export(var_names_all) export(workflow) export(workflows) diff --git a/db/R/query.dplyr.R b/db/R/query.dplyr.R index 310df3460cd..042cb4e3bb9 100644 --- a/db/R/query.dplyr.R +++ b/db/R/query.dplyr.R @@ -212,8 +212,7 @@ get_var_names <- function(bety, workflow_id, run_id, remove_pool = TRUE) { } # get_var_names #' Get vector of variable names for a particular workflow and run ID -#' @inheritParams dbHostInfo -#' @inheritParams workflow +#' @inheritParams get_var_names #' @param run_id Run ID #' @param workflow_id Workflow ID #' @export @@ -228,8 +227,7 @@ var_names_all <- function(bety, workflow_id, run_id) { } # var_names_all #' Load data for a single run of the model -#' @inheritParams dbHostInfo -#' @inheritParams workflow +#' @inheritParams var_names_all #' @param run_id Run ID #' @param workflow_id Workflow ID #' @export diff --git a/db/man/get_workflow_ids.Rd b/db/man/get_workflow_ids.Rd index a95c3ca6695..ed6bc572f5a 100644 --- a/db/man/get_workflow_ids.Rd +++ b/db/man/get_workflow_ids.Rd @@ -4,7 +4,7 @@ \alias{get_workflow_ids} \title{Get vector of workflow IDs} \usage{ -get_workflow_ids(bety, session) +get_workflow_ids(bety, session, all.ids = FALSE) } \arguments{ \item{bety}{BETYdb connection, as opened by `betyConnect()`} diff --git a/db/man/load_data_single_run.Rd b/db/man/load_data_single_run.Rd new file mode 100644 index 00000000000..3205ae6445d --- /dev/null +++ b/db/man/load_data_single_run.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/query.dplyr.R +\name{load_data_single_run} +\alias{load_data_single_run} +\title{Load data for a single run of the model} +\usage{ +load_data_single_run(bety, workflow_id, run_id) +} +\arguments{ +\item{bety}{BETYdb connection, as opened by `betyConnect()`} + +\item{workflow_id}{Workflow ID} + +\item{run_id}{Run ID} +} +\description{ +Load data for a single run of the model +} diff --git a/db/man/var_names_all.Rd b/db/man/var_names_all.Rd new file mode 100644 index 00000000000..91bf847a53d --- /dev/null +++ b/db/man/var_names_all.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/query.dplyr.R +\name{var_names_all} +\alias{var_names_all} +\title{Get vector of variable names for a particular workflow and run ID} +\usage{ +var_names_all(bety, workflow_id, run_id) +} +\arguments{ +\item{bety}{BETYdb connection, as opened by `betyConnect()`} + +\item{workflow_id}{Workflow ID} + +\item{run_id}{Run ID} +} +\description{ +Get vector of variable names for a particular workflow and run ID +} diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 6672a607510..5c786736155 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -65,17 +65,6 @@ server <- shinyServer(function(input, output, session) { } return(globalDF) } - # Fetches variable names from DB - # @param workflow_id and run_id - # @return List of variable names - # var_names_all <- function(bety,workflow_id, run_id){ - # # Get variables for a particular workflow and run id - # var_names <- get_var_names(bety, workflow_id, run_id) - # # Remove variables which should not be shown to the user - # removeVarNames <- c('Year','FracJulianDay') - # var_names <- var_names[!var_names %in% removeVarNames] - # return(var_names) - # } # Update variable names observe({ req(input$all_run_id) @@ -87,64 +76,6 @@ server <- shinyServer(function(input, output, session) { } updateSelectizeInput(session, "variable_name", choices=var_name_list) }) - # # Load data for a single run of the model - # # @param workflow_id and run_id - # # @return Dataframe for one run - # # For a particular combination of workflow and run id, loads - # # all variables from all files. - load_data_single_run <- function(bety,workflow_id,run_id){ - globalDF <- data.frame() - workflow <- collect(workflow(bety, workflow_id)) - # Use the function 'var_names_all' to get all variables - var_names <- var_names_all(bety,workflow_id,run_id) - # Using earlier code, refactored - if(nrow(workflow) > 0) { - outputfolder <- file.path(workflow$folder, 'out', run_id) - files <- list.files(outputfolder, "*.nc$", full.names=TRUE) - for(file in files) { - nc <- nc_open(file) - for(var_name in var_names){ - dates <- NA - vals <- NA - title <- var_name - ylab <- "" - var <- ncdf4::ncatt_get(nc, var_name) - #sw <- if ('Swdown' %in% names(nc$var)) ncdf4::ncvar_get(nc, 'Swdown') else TRUE - # Snow water - sw <- TRUE - # Check required bcoz many files dont contain title - if(!is.null(var$long_name)){ - title <- var$long_name - } - # Check required bcoz many files dont contain units - if(!is.null(var$units)){ - ylab <- var$units - } - x <- ncdays2date(ncdf4::ncvar_get(nc, 'time'), ncdf4::ncatt_get(nc, 'time')) - y <- ncdf4::ncvar_get(nc, var_name) - b <- !is.na(x) & !is.na(y) & sw != 0 - dates <- if(is.na(dates)) x[b] else c(dates, x[b]) - dates <- as.Date(dates) - vals <- if(is.na(vals)) y[b] else c(vals, y[b]) - xlab <- "Time" - # Values of the data which we will plot - valuesDF <- data.frame(dates,vals) - # Meta information about the data - metaDF <- data.frame(workflow_id,run_id,title,xlab,ylab,var_name) - currentDF <- cbind(valuesDF,metaDF) - globalDF <- rbind(globalDF,currentDF) - } - ncdf4::nc_close(nc) - } - } - # Required to convert from factors to characters - # Otherwise error by ggplotly - globalDF$title <- as.character(globalDF$title) - globalDF$xlab <- as.character(globalDF$xlab) - globalDF$ylab <- as.character(globalDF$ylab) - globalDF$var_name <- as.character(globalDF$var_name) - return(globalDF) - } # Loads data for all workflow and run ids after the load button is pressed. # All information about a model is contained in 'all_run_id' string # Wrapper over 'load_data_single_run' From a3148ac588e29e965aa2c7c963d5dbb70b060ba8 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sat, 1 Jul 2017 21:22:50 -0500 Subject: [PATCH 063/771] Description error --- visualization/DESCRIPTION | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/visualization/DESCRIPTION b/visualization/DESCRIPTION index 1fec24918f3..aac8a5fee9f 100644 --- a/visualization/DESCRIPTION +++ b/visualization/DESCRIPTION @@ -35,8 +35,7 @@ Imports: ncdf4 (>= 1.15), plyr (>= 1.8.4), stringr(>= 1.1.0), - udunits2 (>= 0.11), - plotly(>=4.6.0) + udunits2 (>= 0.11) Suggests: testthat (>= 1.0.2), png, From 6564875cc272090809d5c54452faa2f8b853d775 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sun, 2 Jul 2017 16:31:24 -0500 Subject: [PATCH 064/771] Updating inheritParams for load_data_single_run --- db/R/query.dplyr.R | 1 + 1 file changed, 1 insertion(+) diff --git a/db/R/query.dplyr.R b/db/R/query.dplyr.R index 042cb4e3bb9..7fdcb5715b6 100644 --- a/db/R/query.dplyr.R +++ b/db/R/query.dplyr.R @@ -228,6 +228,7 @@ var_names_all <- function(bety, workflow_id, run_id) { #' Load data for a single run of the model #' @inheritParams var_names_all +#' @inheritParams workflow #' @param run_id Run ID #' @param workflow_id Workflow ID #' @export From 9dd65e9b37cdbee84ab3e9ce8331856dea46e002 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Mon, 3 Jul 2017 19:42:58 -0500 Subject: [PATCH 065/771] Allow toggle for chart type. observeEvent while loading variables. Commenting source helper.R --- shiny/workflowPlot/helper.R | 2 +- shiny/workflowPlot/server.R | 23 ++++++++++++++++------- shiny/workflowPlot/ui.R | 6 ++++-- 3 files changed, 21 insertions(+), 10 deletions(-) diff --git a/shiny/workflowPlot/helper.R b/shiny/workflowPlot/helper.R index 978e37e0a8a..0af0c05448f 100644 --- a/shiny/workflowPlot/helper.R +++ b/shiny/workflowPlot/helper.R @@ -9,4 +9,4 @@ checkAndDownload<-function(packageNames) { isInstalled <- function(mypkg){ is.element(mypkg, installed.packages()[,1]) } -checkAndDownload(c('plotly','scales','dplyr')) +# checkAndDownload(c('plotly','scales','dplyr')) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 5c786736155..6caec434719 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -4,7 +4,7 @@ library(shiny) library(ncdf4) library(ggplot2) # Helper allows to load functions and variables that could be shared both by server.R and ui.R -source('helper.R') +# source('helper.R') library(plotly) library(scales) library(dplyr) @@ -65,8 +65,8 @@ server <- shinyServer(function(input, output, session) { } return(globalDF) } - # Update variable names - observe({ + # Update variable names observeEvent on input$load + observeEvent(input$load,{ req(input$all_run_id) # All information about a model is contained in 'all_run_id' string ids_DF <- parse_ids_from_input_runID(input$all_run_id) @@ -95,7 +95,7 @@ server <- shinyServer(function(input, output, session) { validate( need(input$all_workflow_id, 'Select workflow id'), need(input$all_run_id, 'Select Run id'), - need(input$variable_name, 'Click the button to load data') + need(input$variable_name, 'Click the button to load data. Please allow some time') ) # Load data masterDF <- loadNewData() @@ -112,12 +112,21 @@ server <- shinyServer(function(input, output, session) { ylab <- unique(df$ylab) # ggplot function for now scatter plots. # TODO Shubham allow line plots as well - plt <- ggplot(df, aes(x=dates, y=vals, color=run_id)) + - geom_point() + + plt <- ggplot(df, aes(x=dates, y=vals, color=run_id)) + # Toggle chart type using switch + switch(input$plotType, + "scatterPlot" = { + plt <- plt + geom_point() + }, + "lineChart" = { + plt <- plt + geom_line() + } + ) + # geom_point() + # Earlier smoothing and y labels # geom_smooth(aes(fill = "Spline fit")) + # scale_y_continuous(labels=fancy_scientific) + - labs(title=title, x=xlab, y=ylab) + plt <- plt + labs(title=title, x=xlab, y=ylab) # Earlier color and fill values # scale_color_manual(name = "", values = "black") + # scale_fill_manual(name = "", values = "grey50") diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index a2c7673474a..2c00dfb8e20 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -1,5 +1,6 @@ library(shiny) -source('helper.R') +# Helper allows to load functions and variables that could be shared both by server.R and ui.R +# source('helper.R') # Define UI ui <- shinyUI(fluidPage( # Application title @@ -12,7 +13,8 @@ ui <- shinyUI(fluidPage( p("Please select the run IDs. You can select multiple IDs"), selectizeInput("all_run_id", "Mutliple Run IDs", c(),multiple=TRUE), actionButton("load", "Load Model outputs"), - selectInput("variable_name", "Variable Name", "") + selectInput("variable_name", "Variable Name", ""), + radioButtons("plotType", "Plot Type", c("Scatter Plot" = "scatterPlot", "Line Chart" = "lineChart"), selected="scatterPlot") ), mainPanel( plotlyOutput("outputPlot") From 4b8c656bd67c6c97325b5a966f72d22fc09200d2 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 5 Jul 2017 10:33:19 -0400 Subject: [PATCH 066/771] Check package dependencies in `make document` Resolves #1502. --- Makefile | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 325e7cbdd65..ea381f752b9 100644 --- a/Makefile +++ b/Makefile @@ -36,7 +36,7 @@ ALL_PKGS_D := $(BASE_D) $(MODELS_D) $(MODULES_D) .doc/models/template .PHONY: all install check test document -all: install +all: document install document: .doc/all install: .install/all @@ -85,6 +85,7 @@ clean: mkdir -p $(@D) echo `date` > $@ +depends_R_pkg = Rscript -e "devtools::install_dev_deps('$(strip $(1))', Ncpus = ${NCPUS});" install_R_pkg = Rscript -e "devtools::install('$(strip $(1))', Ncpus = ${NCPUS});" check_R_pkg = Rscript scripts/check_with_errors.R $(strip $(1)) test_R_pkg = Rscript -e "devtools::test('"$(strip $(1))"', reporter = 'stop')" @@ -94,6 +95,7 @@ $(ALL_PKGS_I) $(ALL_PKGS_C) $(ALL_PKGS_T) $(ALL_PKGS_D): .install/devtools .inst .SECONDEXPANSION: .doc/%: $$(wildcard %/**/*) $$(wildcard %/*) + $(call depends_R_pkg, $(subst .doc/,,$@)) $(call doc_R_pkg, $(subst .doc/,,$@)) mkdir -p $(@D) echo `date` > $@ From a7c0077c4eb591cd738e1b2a42a4eaf66780e4a8 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Wed, 5 Jul 2017 21:36:33 -0500 Subject: [PATCH 067/771] UI for loading external data --- shiny/workflowPlot/server.R | 11 +++++++++-- shiny/workflowPlot/ui.R | 22 ++++++++++++++++++++-- 2 files changed, 29 insertions(+), 4 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 6caec434719..081a505da81 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -4,7 +4,7 @@ library(shiny) library(ncdf4) library(ggplot2) # Helper allows to load functions and variables that could be shared both by server.R and ui.R -# source('helper.R') +source('helper.R') library(plotly) library(scales) library(dplyr) @@ -89,7 +89,14 @@ server <- shinyServer(function(input, output, session) { } return(globalDF) }) - # Renders the ggplotly + loadExternalData <-eventReactive(input$load_data,{ + inFile <- input$file1 + if (is.null(inFile)) + return(data.frame()) + read.csv(inFile$datapath, header=input$header, sep=input$sep, + quote=input$quote) + }) + # Renders ggplotly output$outputPlot <- renderPlotly({ # Error messages validate( diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 2c00dfb8e20..a1204eef7e6 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -1,6 +1,6 @@ library(shiny) # Helper allows to load functions and variables that could be shared both by server.R and ui.R -# source('helper.R') +source('helper.R') # Define UI ui <- shinyUI(fluidPage( # Application title @@ -14,7 +14,25 @@ ui <- shinyUI(fluidPage( selectizeInput("all_run_id", "Mutliple Run IDs", c(),multiple=TRUE), actionButton("load", "Load Model outputs"), selectInput("variable_name", "Variable Name", ""), - radioButtons("plotType", "Plot Type", c("Scatter Plot" = "scatterPlot", "Line Chart" = "lineChart"), selected="scatterPlot") + radioButtons("plotType", "Plot Type", c("Scatter Plot" = "scatterPlot", "Line Chart" = "lineChart"), selected="scatterPlot"), + tags$hr(), + tags$hr(), + fileInput('file1', 'Choose CSV File to upload data', + accept=c('text/csv', + 'text/comma-separated-values,text/plain', + '.csv')), + checkboxInput('header', 'Header', TRUE), + radioButtons('sep', 'Separator', + c(Comma=',', + Semicolon=';', + Tab='\t'), + ','), + radioButtons('quote', 'Quote', + c(None='', + 'Double Quote'='"', + 'Single Quote'="'"), + '"'), + actionButton("load_data", "Load External Data") ), mainPanel( plotlyOutput("outputPlot") From cb13cedcabc879638922a9fc63b34657d724b742 Mon Sep 17 00:00:00 2001 From: Betsy Cowdery Date: Fri, 7 Jul 2017 14:07:46 -0600 Subject: [PATCH 068/771] Changing plot.photo to plot_photo --- documentation/tutorials/MCMC/MCMC_Concepts.Rmd | 2 +- modules/photosynthesis/R/plots.R | 8 ++++---- modules/photosynthesis/code/test.fitA.R | 2 +- modules/photosynthesis/vignettes/ResponseCurves.Rmd | 6 +++--- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/documentation/tutorials/MCMC/MCMC_Concepts.Rmd b/documentation/tutorials/MCMC/MCMC_Concepts.Rmd index fb1e8205098..9be8bb07abc 100644 --- a/documentation/tutorials/MCMC/MCMC_Concepts.Rmd +++ b/documentation/tutorials/MCMC/MCMC_Concepts.Rmd @@ -173,7 +173,7 @@ In the final set of plots we look at the actual A-Ci and A-Q curves themselves. ```{r} ## Response curve -plot.photo(dat,fit) +plot_photo(dat,fit) ``` Note: on the last figure you will get warnings about "No ACi" and "No AQ" which can be ignored. These are occuring because the file that had the ACi curve didn't have an AQ curve, and the file that had the AQ curve didn't have an ACi curve. diff --git a/modules/photosynthesis/R/plots.R b/modules/photosynthesis/R/plots.R index d15e0a7d824..fb28a43fd81 100644 --- a/modules/photosynthesis/R/plots.R +++ b/modules/photosynthesis/R/plots.R @@ -7,11 +7,11 @@ ciEnvelope <- function(x, ylo, yhi, col = "lightgrey", ...) { col = col, border = NA, ...)) } # ciEnvelope -##' @name plot.photo -##' @title plot.photo +##' @name plot_photo +##' @title plot_photo ##' @author Mike Dietze ##' @export -plot.photo <- function(data, out, curve = c("ACi", "AQ"), tol = 0.05, byLeaf = TRUE) { +plot_photo <- function(data, out, curve = c("ACi", "AQ"), tol = 0.05, byLeaf = TRUE) { params <- as.matrix(out$params) predict <- as.matrix(out$predict) @@ -97,4 +97,4 @@ plot.photo <- function(data, out, curve = c("ACi", "AQ"), tol = 0.05, byLeaf = T } } ## end A-Q } ## end loop over curves -} # plot.photo +} # plot_photo diff --git a/modules/photosynthesis/code/test.fitA.R b/modules/photosynthesis/code/test.fitA.R index d1e471376d1..ead28d7753d 100644 --- a/modules/photosynthesis/code/test.fitA.R +++ b/modules/photosynthesis/code/test.fitA.R @@ -49,5 +49,5 @@ summary(fit$params) ## parameter estimates abline(0,1,col=2,lwd=2) -plot.photo(dat,fit) +plot_photo(dat,fit) \ No newline at end of file diff --git a/modules/photosynthesis/vignettes/ResponseCurves.Rmd b/modules/photosynthesis/vignettes/ResponseCurves.Rmd index 50686ba7418..a1a6d9717ef 100644 --- a/modules/photosynthesis/vignettes/ResponseCurves.Rmd +++ b/modules/photosynthesis/vignettes/ResponseCurves.Rmd @@ -159,7 +159,7 @@ plot(pmean, dat$Photo, pch = "+", xlab = "Predicted A", ylab = "Observed A") abline(0, 1, col = 2, lwd = 2) ## -plot.photo(dat, fit) +plot_photo(dat, fit) ``` @@ -199,7 +199,7 @@ plot(pmean, dat$Photo, pch = "+", xlab = "Predicted A", ylab = "Observed A") abline(0,1,col=2,lwd=2) ## -plot.photo(dat,fitI) +plot_photo(dat,fitI) ``` @@ -248,7 +248,7 @@ plot(pmean, dat$Photo, pch = "+", xlab = "Predicted A", ylab = "Observed A") abline(0,1,col=2,lwd=2) ## -plot.photo(dat, fitC) +plot_photo(dat, fitC) ``` From 69ae000c722aa4e533d4c41d5a5a3c2868520f96 Mon Sep 17 00:00:00 2001 From: Betsy Cowdery Date: Fri, 7 Jul 2017 14:11:59 -0600 Subject: [PATCH 069/771] Changin read.Licor to read_Licor --- documentation/tutorials/MCMC/MCMC_Concepts.Rmd | 2 +- modules/photosynthesis/R/fitA.R | 8 ++++---- modules/photosynthesis/code/test.fitA.R | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/documentation/tutorials/MCMC/MCMC_Concepts.Rmd b/documentation/tutorials/MCMC/MCMC_Concepts.Rmd index 9be8bb07abc..5036c41b8d6 100644 --- a/documentation/tutorials/MCMC/MCMC_Concepts.Rmd +++ b/documentation/tutorials/MCMC/MCMC_Concepts.Rmd @@ -73,7 +73,7 @@ library(PEcAn.photosynthesis) ### Load built in data filenames <- system.file("extdata", paste0("flux-course-3",c("aci","aq")), package = "PEcAn.photosynthesis") -dat<-do.call("rbind", lapply(filenames, read.Licor)) +dat<-do.call("rbind", lapply(filenames, read_Licor)) ## Simple plots aci = as.character(dat$fname) == basename(filenames[1]) diff --git a/modules/photosynthesis/R/fitA.R b/modules/photosynthesis/R/fitA.R index a93d58f5a26..35aee63f879 100644 --- a/modules/photosynthesis/R/fitA.R +++ b/modules/photosynthesis/R/fitA.R @@ -265,8 +265,8 @@ return(out) } # fitA -##' @name read.Licor -##' @title read.Licor +##' @name read_Licor +##' @title read_Licor ##' ##' @author Mike Dietze ##' @export @@ -274,7 +274,7 @@ return(out) ##' @param filename name of the file to read ##' @param sep file delimiter. defaults to tab ##' @param ... optional arguements forwarded to read.table -read.Licor <- function(filename, sep = "\t", ...) { +read_Licor <- function(filename, sep = "\t", ...) { fbase <- sub(".txt", "", tail(unlist(strsplit(filename, "/")), n = 1)) print(fbase) full <- readLines(filename) @@ -290,7 +290,7 @@ read.Licor <- function(filename, sep = "\t", ...) { fname <- rep(fbase, nrow(dat)) dat <- as.data.frame(cbind(fname, dat)) return(dat) -} # read.Licor +} # read_Licor mat2mcmc.list <- function(w) { diff --git a/modules/photosynthesis/code/test.fitA.R b/modules/photosynthesis/code/test.fitA.R index ead28d7753d..c08930b538a 100644 --- a/modules/photosynthesis/code/test.fitA.R +++ b/modules/photosynthesis/code/test.fitA.R @@ -9,7 +9,7 @@ ## Read Photosynthetic gas exchange data filenames <- list.files(in.folder,pattern=pattern, full.names=TRUE) - master = lapply(filenames, read.Licor) + master = lapply(filenames, read_Licor) save(master,file="master.RData") ## run QA/QC checks From 7bdf26959a696fe134217d1baa93bb70bbfb6fe4 Mon Sep 17 00:00:00 2001 From: Betsy Cowdery Date: Fri, 7 Jul 2017 14:13:47 -0600 Subject: [PATCH 070/771] Changing Licor.QC to Licor_QC --- modules/photosynthesis/R/Licor.QC.R | 8 ++++---- modules/photosynthesis/code/test.fitA.R | 2 +- modules/photosynthesis/vignettes/ResponseCurves.Rmd | 6 +++--- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/modules/photosynthesis/R/Licor.QC.R b/modules/photosynthesis/R/Licor.QC.R index 7f02374d41d..a81995729d5 100644 --- a/modules/photosynthesis/R/Licor.QC.R +++ b/modules/photosynthesis/R/Licor.QC.R @@ -1,11 +1,11 @@ -##' @name Licor.QC -##' @title Licor.QC +##' @name Licor_QC +##' @title Licor_QC ##' @author Mike Dietze ##' @export ##' @param dat data frame ##' @param curve Whether to do Quality Control by examining the 'ACi' curve, the 'AQ' curve, or both ##' @param tol Code automatically tries to separate ACi and AQ curves in the same dataset by detecting the 'reference' condition for light and CO2 respectively. This is the relative error around the mode in that detection. -Licor.QC <- function(dat, curve = c("ACi", "AQ"), tol = 0.05) { +Licor_QC <- function(dat, curve = c("ACi", "AQ"), tol = 0.05) { if (!("QC" %in% names(dat))) { dat$QC <- rep(0, nrow(dat)) @@ -112,7 +112,7 @@ Licor.QC <- function(dat, curve = c("ACi", "AQ"), tol = 0.05) { } } return(invisible(dat)) -} # Licor.QC +} # Licor_QC ##' @name estimate_mode ##' @title estimate_mode diff --git a/modules/photosynthesis/code/test.fitA.R b/modules/photosynthesis/code/test.fitA.R index c08930b538a..6b08f901b45 100644 --- a/modules/photosynthesis/code/test.fitA.R +++ b/modules/photosynthesis/code/test.fitA.R @@ -14,7 +14,7 @@ ## run QA/QC checks for(i in 1:length(master)){ - master[[i]] = Licor.QC(master[[i]]) + master[[i]] = Licor_QC(master[[i]]) save(master,file="master.RData") } diff --git a/modules/photosynthesis/vignettes/ResponseCurves.Rmd b/modules/photosynthesis/vignettes/ResponseCurves.Rmd index a1a6d9717ef..ee3d227c8d9 100644 --- a/modules/photosynthesis/vignettes/ResponseCurves.Rmd +++ b/modules/photosynthesis/vignettes/ResponseCurves.Rmd @@ -70,7 +70,7 @@ The code below performs a set of interactive QA/QC checks on the LI-COR data tha If you want to get a feel for how the code works you'll want to run it first on just one file, rather than looping over all the files ``` -master[[1]] <- Licor.QC(master[[1]]) +master[[1]] <- Licor_QC(master[[1]]) ``` On the first screen you will be shown an A-Ci curve. Click on points that are outliers that you want to remove. Be aware that these points will not change color in **THIS SCREEN**, but will be updated in the next. Also be aware that if your data set is not an A-Ci curve (or contains both A-Ci and A-Q curves) there are points that may look like outliers just because they are data from the other curve. When you are done selecting outliers, click **[esc]** to move to the next screen. @@ -81,7 +81,7 @@ The third and fourth screens are the equivalent plots for the A-Q (light respons Finally, this function returns a copy of the original data with a new column, "QC", added. This column will flag all passed values with 1, all unchecked values with 0, and all failed values with -1. -The function Licor.QC has an optional arguement, _curve_, which can be set to either "ACi" or "AQ" if you only want to perform one of these diagnostics rather than both (which is the default). +The function Licor_QC has an optional arguement, _curve_, which can be set to either "ACi" or "AQ" if you only want to perform one of these diagnostics rather than both (which is the default). Also, the QC code attempts to automatically separate which points are part of the ACi curve from which parts are part of the AQ curve, based on how close points are to the the variable which is supposed to be held constant. The optional variable "tol" controls the tolerance of this filter, and is expressed as a proportion of the fixed value. The default value, 0.05, corresponds to a 5% deviation. For example, in the ACi curve the light level should be held constant so the code filters the PARi variable to find the mode and then included any data that's within 5% of the mode in the ACi curve. @@ -89,7 +89,7 @@ Once you have a feel for the QA/QC function, you'll want to run it for all the d ``` for(i in 1:length(master)){ - master[[i]] = Licor.QC(master[[i]]) + master[[i]] = Licor_QC(master[[i]]) } ``` From 7f207a61facb55342e3e324af9cba3a318f4abd4 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Fri, 7 Jul 2017 16:14:47 -0400 Subject: [PATCH 071/771] First draft of 4 query and download utils for handling data from the dataONE federation --- modules/data.land/R/DataONE_doi_download.R | 114 +++++++++++++++++++++ 1 file changed, 114 insertions(+) create mode 100644 modules/data.land/R/DataONE_doi_download.R diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R new file mode 100644 index 00000000000..a6832cc39c9 --- /dev/null +++ b/modules/data.land/R/DataONE_doi_download.R @@ -0,0 +1,114 @@ +##' Functions to determine if data can be found by doi in R +##' Author: Liam Burke +##' Code draws heavily on dataone r package for communication with the dataONE federation + +#--------------------------------------------------------------------------------# +# 1. format.identifier -- convert doi or id into solrQuery format # +#--------------------------------------------------------------------------------# + +format.identifier = function(id){ + doi.template <- 'id:"_"' # solr format + doi1 <<- base::gsub("_", id, doi.template) # replace "_" with the doi or id and store in global environment + return(doi1) +} # end function + +#--------------------------------------------------------------------------------# +# 2. id.resolveable -- Is doi/ id available in dataONE? # +#--------------------------------------------------------------------------------# + +##' Arguments +#' id: doi or dataone id +#' CNode: usually "PROD" +#' return_result: boolean that returns or suppresses result of query + +id.resolveable = function(id, CNode, return_result){ + format.identifier(id) # reformat the id in solr format + + cn <- dataone::CNode("PROD") + queryParams <- list(q=doi1, rows="5") + result <- dataone::query(cn, solrQuery = queryParams, as = "data.frame") # return query results as a data.frame + + if(return_result == TRUE){ # option that displays data.frame of query + print(result) + + if(is.null(result[1,1])){ # if there is no data available, result[1,1] will return a NULL value + return("doi does not resolve in the DataOne federation and therefore cannot be retrieved by doi. + Either download this data locally and import using PEcAn's drag and drop feature, or search DataOne manually for another data identifier. Thank you for your patience.") + } else{ + return("data can be found in D1 federation") + } + } else{ # option that does not display data.frame of query (return_result == FALSE) + if(is.null(result[1,1])){ + return("doi does not resolve in the DataOne federation and therefore cannot be retrieved by doi. + Either download this data locally and import using PEcAn's drag and drop feature, or search DataOne manually for another data identifier (e.g. pid or resource_map) Thank you for your patience.") + } else{ + return("data can be found in D1 federation") + } + } + +} # end function + +#--------------------------------------------------------------------------------# +# Get resource_map from doi # +#--------------------------------------------------------------------------------# + +##' Arguments: +#' id: doi or dataone id +#' CNode: usually "PROD" + +get.resource.map = function(id, CNode){ + cn <- dataone::CNode("PROD") + locations <- dataone::resolve(cn, pid = id) + mnId <<- locations$data[1,"nodeIdentifier"] # store mnId in global environment + mn <<- dataone::getMNode(cn, mnId) # store mn in global environment + + format.identifier(id) # format the identifier in solr Query format + queryParamList <- list(q=doi1, fl="resourceMap") # custom query for the resourceMap + resource_map_df <- dataone::query(cn, solrQuery = queryParamList, as="data.frame") + resource_map <<- resource_map_df[1,1] # store resource map in global env. resource map is always in resource_map_df[1,1] + + if (is.null(resource_map_df[1,1])){ # inform user if id/ doi has a corresponding resource_map or if this needs to be found manually + print("doi does not resolve a resource_map. Please manually search for the resource_map in DataONE search: https://search.dataone.org/#data") + } else{ + print("Continue to next phase to complete download") + return(resource_map) + } +} # end function + +#--------------------------------------------------------------------------------# +# download package using resource_map # +#--------------------------------------------------------------------------------# + +### Arguments: +#' resource_map: can be entered manually or can be called from the get.resource.map fn result +#' CNode: usually "PROD" +#' download_format: format of download defaulted to "application/bagit-097" -- other possible formats unknown +#' overwrite_directory: boolean +#' directory: indicates the destination directory for the BagItFile + + + +download.package.rm = function(resource_map, CNode, download_format = "application/bagit-097", + overwrite_directory = TRUE, directory){ + # Finding the mnId (query) + cn <- dataone::CNode("PROD") + locations <- dataone::resolve(cn, pid = resource_map) + mnId <<- locations$data[1,"nodeIdentifier"] + + # download the bagitFile + mn <<- dataone::getMNode(cn, mnId) + bagitFile <<- dataone::getPackage(mn, id = resource_map, format = download_format) + bagitFile + + + zip_contents <<- utils::unzip(bagitFile, files = NULL, list = TRUE, overwrite = TRUE, # list files in bagitFile + junkpaths = FALSE, exdir = "downloads", unzip = "internal", + setTimes = FALSE) + + utils::unzip(bagitFile, files = NULL, list = FALSE, overwrite = overwrite_directory, # Unzip the bagitFile and store in directory specified under exdir + junkpaths = FALSE, exdir = directory, unzip = "internal", + setTimes = FALSE) + return(zip_contents) +} # end function + + From df489fa798232055594e81c2c640a9740838948f Mon Sep 17 00:00:00 2001 From: Betsy Cowdery Date: Fri, 7 Jul 2017 14:14:32 -0600 Subject: [PATCH 072/771] Updating Documentation --- modules/photosynthesis/NAMESPACE | 6 +++--- .../photosynthesis/man/{Licor.QC.Rd => Licor_QC.Rd} | 8 ++++---- modules/photosynthesis/man/plot.photo.Rd | 12 ------------ modules/photosynthesis/man/plot_photo.Rd | 11 +++++++++++ .../man/{read.Licor.Rd => read_Licor.Rd} | 8 ++++---- modules/photosynthesis/vignettes/ResponseCurves.Rmd | 2 +- 6 files changed, 23 insertions(+), 24 deletions(-) rename modules/photosynthesis/man/{Licor.QC.Rd => Licor_QC.Rd} (82%) delete mode 100644 modules/photosynthesis/man/plot.photo.Rd create mode 100644 modules/photosynthesis/man/plot_photo.Rd rename modules/photosynthesis/man/{read.Licor.Rd => read_Licor.Rd} (74%) diff --git a/modules/photosynthesis/NAMESPACE b/modules/photosynthesis/NAMESPACE index 705dd31e6fa..b9b3e4fc580 100644 --- a/modules/photosynthesis/NAMESPACE +++ b/modules/photosynthesis/NAMESPACE @@ -1,8 +1,8 @@ # Generated by roxygen2: do not edit by hand -S3method(plot,photo) -export(Licor.QC) +export(Licor_QC) export(ciEnvelope) export(estimate_mode) export(fitA) -export(read.Licor) +export(plot_photo) +export(read_Licor) diff --git a/modules/photosynthesis/man/Licor.QC.Rd b/modules/photosynthesis/man/Licor_QC.Rd similarity index 82% rename from modules/photosynthesis/man/Licor.QC.Rd rename to modules/photosynthesis/man/Licor_QC.Rd index c0c3ed702d8..ff09f0e9e2a 100644 --- a/modules/photosynthesis/man/Licor.QC.Rd +++ b/modules/photosynthesis/man/Licor_QC.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/Licor.QC.R -\name{Licor.QC} -\alias{Licor.QC} -\title{Licor.QC} +\name{Licor_QC} +\alias{Licor_QC} +\title{Licor_QC} \usage{ -Licor.QC(dat, curve = c("ACi", "AQ"), tol = 0.05) +Licor_QC(dat, curve = c("ACi", "AQ"), tol = 0.05) } \arguments{ \item{dat}{data frame} diff --git a/modules/photosynthesis/man/plot.photo.Rd b/modules/photosynthesis/man/plot.photo.Rd deleted file mode 100644 index 84b4257d2fd..00000000000 --- a/modules/photosynthesis/man/plot.photo.Rd +++ /dev/null @@ -1,12 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plots.R -\name{plot.photo} -\alias{plot.photo} -\title{plot.photo} -\usage{ -\method{plot}{photo}(data, out, curve = c("ACi", "AQ"), tol = 0.05, - byLeaf = TRUE) -} -\author{ -Mike Dietze -} diff --git a/modules/photosynthesis/man/plot_photo.Rd b/modules/photosynthesis/man/plot_photo.Rd new file mode 100644 index 00000000000..b9b8174680d --- /dev/null +++ b/modules/photosynthesis/man/plot_photo.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plots.R +\name{plot_photo} +\alias{plot_photo} +\title{plot_photo} +\usage{ +plot_photo(data, out, curve = c("ACi", "AQ"), tol = 0.05, byLeaf = TRUE) +} +\author{ +Mike Dietze +} diff --git a/modules/photosynthesis/man/read.Licor.Rd b/modules/photosynthesis/man/read_Licor.Rd similarity index 74% rename from modules/photosynthesis/man/read.Licor.Rd rename to modules/photosynthesis/man/read_Licor.Rd index 4f0644654e1..a08c89385d9 100644 --- a/modules/photosynthesis/man/read.Licor.Rd +++ b/modules/photosynthesis/man/read_Licor.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fitA.R -\name{read.Licor} -\alias{read.Licor} -\title{read.Licor} +\name{read_Licor} +\alias{read_Licor} +\title{read_Licor} \usage{ -read.Licor(filename, sep = "\\t", ...) +read_Licor(filename, sep = "\\t", ...) } \arguments{ \item{filename}{name of the file to read} diff --git a/modules/photosynthesis/vignettes/ResponseCurves.Rmd b/modules/photosynthesis/vignettes/ResponseCurves.Rmd index ee3d227c8d9..6f6b1e4a51f 100644 --- a/modules/photosynthesis/vignettes/ResponseCurves.Rmd +++ b/modules/photosynthesis/vignettes/ResponseCurves.Rmd @@ -59,7 +59,7 @@ library(PEcAn.photosynthesis) filenames <- system.file("extdata", paste0("flux-course-",rep(1:6,each=2),c("aci","aq")), package = "PEcAn.photosynthesis") ## Load files to a list -master = lapply(filenames, read.Licor) +master = lapply(filenames, read_Licor) ``` From 9b2816808273e45d99daa1fd527fc4ffe1988edd Mon Sep 17 00:00:00 2001 From: Andria Dawson Date: Fri, 7 Jul 2017 23:08:10 -0600 Subject: [PATCH 073/771] Generalizing allom.predict to accept a list --- modules/allometry/R/allom.predict.R | 62 +++++++++++++++++++++++------ 1 file changed, 49 insertions(+), 13 deletions(-) diff --git a/modules/allometry/R/allom.predict.R b/modules/allometry/R/allom.predict.R index 207f1856296..9ec003eb20d 100644 --- a/modules/allometry/R/allom.predict.R +++ b/modules/allometry/R/allom.predict.R @@ -82,6 +82,7 @@ allom.predict <- function(object, dbh, pft = NULL, component = NULL, n = NULL, u return(NA) } + ## build PFT x Component table and convert mcmclist objects to mcmc pftByComp <- matrix(NA, npft, ncomp) for (i in seq_len(npft)) { @@ -180,27 +181,62 @@ allom.predict <- function(object, dbh, pft = NULL, component = NULL, n = NULL, u names(params) <- names(object) ### perform actual allometric calculation - out <- matrix(NA, n, length(dbh)) + if (is(dbh, "list")) { + out <- list(length(dbh)) + } else { + out <- matrix(NA, n, length(dbh)) + } for (p in unique(pft)) { sel <- which(pft == p) - a <- params[[p]][, 1] - b <- params[[p]][, 2] + a <- params[[p]][,1] + b <- params[[p]][,2] if (ncol(params[[p]]) > 2) { - s <- sqrt(params[[p]][, 3]) ## sigma was originally calculated as a variance, so convert to std dev + s <- sqrt(params[[p]][,3]) ## sigma was originally calculated as a variance, so convert to std dev } else { s <- 0 } - for (i in sel) { - out[, i] <- exp(rnorm(n, a + b * log(dbh[i]), s)) - } - - # for a dbh time-series for a single tree, fix error for each draw - if (single.tree == TRUE) { - epsilon <- rnorm(n, 0, s) - for (i in seq_len(n)) { - out[i, ] <- exp(a[i] + b[i] * log(dbh) + epsilon[i]) + + if (is(dbh, "list")) { + for (j in 1:length(sel)) { + if ((is(dbh[[sel[j]]], "numeric")) & (all(is.na(dbh[[sel[j]]])))) { + out[[sel[j]]] <- array(NA, c(n,1,length(dbh[[sel[j]]]))) + out[[sel[j]]][,,] <- NA + next + } else if (is(dbh[[sel[j]]], "numeric")) { + ntrees <- 1 + nyears <- length(dbh[[sel[j]]]) + } else { + ntrees <- nrow(dbh[[sel[j]]]) + nyears <- ncol(dbh[[sel[j]]]) + } + + out[[sel[j]]] <- array(NA, c(n,ntrees,nyears)) + + for (k in 1:ntrees) { + epsilon <- rnorm(n, 0, s) # don't fix this for a single tree; fix for a single iteration for a single site across all trees + if (is(dbh[[sel[j]]], "numeric")) { + dbh_sel_k <- dbh[[sel[j]]] + } else { + dbh_sel_k <- dbh[[sel[j]]][k,] + } + + log_x <- sapply(dbh_sel_k, function(x) if(is.na(x)|(x<=0)){return(NA)}else{log(x)}) + out[[sel[j]]][,k,] <- sapply(log_x, function(x) if(is.na(x)){rep(NA, n)}else{exp(a+b*x + epsilon)}) + } + } + } else if (single.tree == TRUE) { + # for a dbh time-series for a single tree, fix error for each draw + epsilon = rnorm(n, 0, s) + for (i in 1:n) { + out[i,] <- exp(a[i]+b[i]*log(dbh) + epsilon[i]) + } + } else { + # for a dbh time-series for different trees, error not fixed across draws + for (i in sel) { + out[,i] <- exp(rnorm(n, a+b*log(dbh[i]),s)) } } + } return(out) From 951f43554cb60d38ad7f614c5bcaaf07d31797ab Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sun, 9 Jul 2017 14:28:10 +0530 Subject: [PATCH 074/771] Typo fixes --- Dockerfile | 2 +- docker/bin/my_init | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/Dockerfile b/Dockerfile index 28c7ece0548..d4829853229 100644 --- a/Dockerfile +++ b/Dockerfile @@ -17,7 +17,7 @@ RUN /build/system_services.sh # run update machine to update machine RUN /build/update_machine.sh -# run inatall packages to install required packages +# run install packages to install required packages RUN /build/install_packages.sh # run install R to install R packages diff --git a/docker/bin/my_init b/docker/bin/my_init index af87c28c78b..ccf79a7711b 100644 --- a/docker/bin/my_init +++ b/docker/bin/my_init @@ -1,4 +1,4 @@ -#! /bin/bash +#!/bin/bash export LC_ALL=C TERM="xterm" trap 'shutdown_runit_services' INT TERM @@ -88,7 +88,7 @@ run_startup_files() { } -# function to start corn jobs +# function to start cron jobs start_runit () { echo "Booting runit daemon..." /usr/bin/runsvdir -P /etc/service 'log:.........................................................................................................' & From 9696ce7648ce0883b34a880dc1613b4d892fc388 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sun, 9 Jul 2017 08:58:49 -0500 Subject: [PATCH 075/771] Experimenting with loading external data --- shiny/workflowPlot/helper.R | 5 ++++- shiny/workflowPlot/server.R | 19 +++++++++++++++++-- shiny/workflowPlot/ui.R | 6 ++++-- 3 files changed, 25 insertions(+), 5 deletions(-) diff --git a/shiny/workflowPlot/helper.R b/shiny/workflowPlot/helper.R index 0af0c05448f..5dfbdcd0b7f 100644 --- a/shiny/workflowPlot/helper.R +++ b/shiny/workflowPlot/helper.R @@ -9,4 +9,7 @@ checkAndDownload<-function(packageNames) { isInstalled <- function(mypkg){ is.element(mypkg, installed.packages()[,1]) } -# checkAndDownload(c('plotly','scales','dplyr')) +checkAndDownload(c('plotly','scales','dplyr')) + +# write.csv(globalDF,file='/home/carya/pecan/shiny/workflowPlot/sampleFile.csv', +# quote = FALSE,sep = ',',col.names = TRUE,row.names=FALSE) \ No newline at end of file diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 081a505da81..c823db298dd 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -93,9 +93,18 @@ server <- shinyServer(function(input, output, session) { inFile <- input$file1 if (is.null(inFile)) return(data.frame()) - read.csv(inFile$datapath, header=input$header, sep=input$sep, + output$info1 <- renderText({ + # paste0(nrow(externalData)) + paste0(inFile$datapath) + }) + externalData <- read.csv(inFile$datapath, header=input$header, sep=input$sep, quote=input$quote) + return(externalData) }) + output$info <- renderText({ + inFile <- input$file1 + paste0(inFile$datapath) + }) # Renders ggplotly output$outputPlot <- renderPlotly({ # Error messages @@ -105,7 +114,10 @@ server <- shinyServer(function(input, output, session) { need(input$variable_name, 'Click the button to load data. Please allow some time') ) # Load data - masterDF <- loadNewData() + externalData <- data.frame() + modelData <- loadNewData() + externalData <- loadExternalData() + masterDF <- rbind(modelData,externalData) # Convert from factor to character. For subsetting masterDF$var_name <- as.character(masterDF$var_name) # Convert to factor. Required for ggplot @@ -129,6 +141,9 @@ server <- shinyServer(function(input, output, session) { plt <- plt + geom_line() } ) + # if (!is.null(loaded_data)) { + # plt <- plt + geom_line(data = loaded_data, linetype = 'dashed') + # } # geom_point() + # Earlier smoothing and y labels # geom_smooth(aes(fill = "Spline fit")) + diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index a1204eef7e6..5d7b0bba267 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -31,11 +31,13 @@ ui <- shinyUI(fluidPage( c(None='', 'Double Quote'='"', 'Single Quote'="'"), - '"'), + ''), actionButton("load_data", "Load External Data") ), mainPanel( - plotlyOutput("outputPlot") + plotlyOutput("outputPlot"), + verbatimTextOutput("info1"), + verbatimTextOutput("info") ) ) )) From 9d6d7ab457489dc23f855c9b6adf4e4bc6a57124 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sun, 9 Jul 2017 10:34:37 -0500 Subject: [PATCH 076/771] Loading external data --- shiny/workflowPlot/server.R | 37 +++++++++++++++++++++++++------------ 1 file changed, 25 insertions(+), 12 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index c823db298dd..d2b7b132292 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -92,19 +92,23 @@ server <- shinyServer(function(input, output, session) { loadExternalData <-eventReactive(input$load_data,{ inFile <- input$file1 if (is.null(inFile)) - return(data.frame()) - output$info1 <- renderText({ - # paste0(nrow(externalData)) - paste0(inFile$datapath) - }) + return(NULL) externalData <- read.csv(inFile$datapath, header=input$header, sep=input$sep, quote=input$quote) + externalData$dates <- as.Date(externalData$dates) + externalData <- externalData %>% + dplyr::filter(var_name == input$variable_name) + # output$info1 <- renderText({ + # paste0(nrow(externalData)) + # # paste0(inFile$datapath) + # }) return(externalData) }) - output$info <- renderText({ - inFile <- input$file1 - paste0(inFile$datapath) - }) + # output$info <- renderText({ + # inFile <- input$file1 + # paste0(inFile$datapath) + # # paste0(input$load_data) + # }) # Renders ggplotly output$outputPlot <- renderPlotly({ # Error messages @@ -116,7 +120,9 @@ server <- shinyServer(function(input, output, session) { # Load data externalData <- data.frame() modelData <- loadNewData() - externalData <- loadExternalData() + if (input$load_data>0) { + externalData <- loadExternalData() + } masterDF <- rbind(modelData,externalData) # Convert from factor to character. For subsetting masterDF$var_name <- as.character(masterDF$var_name) @@ -141,14 +147,21 @@ server <- shinyServer(function(input, output, session) { plt <- plt + geom_line() } ) + plt <- plt + labs(title=title, x=xlab, y=ylab) + # if (!is.null(loaded_data)) { - # plt <- plt + geom_line(data = loaded_data, linetype = 'dashed') + # if (input$load_data>0) { + # loaded_data <- loadExternalData() + # output$info1 <- renderText({ + # paste0(nrow(loaded_data)) + # # paste0(inFile$datapath) + # }) + # plt <- plt + geom_line(data = loaded_data,aes(x=dates, y=vals), linetype = 'dashed') # } # geom_point() + # Earlier smoothing and y labels # geom_smooth(aes(fill = "Spline fit")) + # scale_y_continuous(labels=fancy_scientific) + - plt <- plt + labs(title=title, x=xlab, y=ylab) # Earlier color and fill values # scale_color_manual(name = "", values = "black") + # scale_fill_manual(name = "", values = "grey50") From 291ac99f636c6c991a3c3dd0e7eb7abd928ddaa2 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Mon, 10 Jul 2017 09:01:51 -0400 Subject: [PATCH 077/771] Some expanatory comments added by Margaret Evans, as well as the ability to specify an external state variable IC (z0) --- modules/data.land/R/InventoryGrowthFusion.R | 37 ++++++++++++--------- 1 file changed, 22 insertions(+), 15 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index 37f7d6ed5b3..64158cc5aa3 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -8,12 +8,14 @@ ##' @note Requires JAGS ##' @return an mcmc.list object ##' @export -InventoryGrowthFusion <- function(data, cov.data=NULL,time_data = NULL,n.iter=5000, random = NULL, fixed = NULL,time_varying=NULL, burnin_plot = FALSE,save.jags="IGF.txt") { +InventoryGrowthFusion <- function(data, cov.data=NULL,time_data = NULL,n.iter=5000, random = NULL, fixed = NULL,time_varying=NULL, burnin_plot = FALSE, save.jags = "IGF.txt", z0 = NULL) { library(rjags) - burnin.variables <- c("tau_add", "tau_dbh", "tau_inc", "mu") + # baseline variables to monitor + burnin.variables <- c("tau_add", "tau_dbh", "tau_inc", "mu") # process variability, dbh and tree-ring observation error, intercept out.variables <- c("x", "tau_add", "tau_dbh", "tau_inc", "mu") + # start text object that will be manipulated (to build different linear models, swap in/out covariates) TreeDataFusionMV <- " model{ @@ -41,17 +43,17 @@ model{ x[i,1] ~ dnorm(x_ic,tau_ic) } ## end loop over individuals -## RANDOM_EFFECTS + ## RANDOM_EFFECTS #### Priors tau_dbh ~ dgamma(a_dbh,r_dbh) tau_inc ~ dgamma(a_inc,r_inc) tau_add ~ dgamma(a_add,r_add) mu ~ dnorm(0.5,0.5) -## FIXED EFFECTS BETAS -## ENDOGENOUS BETAS -## TIME VARYING BETAS -## RANDOM EFFECT TAUS + ## FIXED EFFECTS BETAS + ## ENDOGENOUS BETAS + ## TIME VARYING BETAS + ## RANDOM EFFECT TAUS }" Pformula <- NULL @@ -103,8 +105,9 @@ model{ paste0("+ alpha_", r_var,"[",counter,index,"]")) ## create random effect for(j in seq_along(nr)){ - Reffects <- paste(Reffects,paste0("for(k in 1:",nr[j],"){\n"), - paste0(" alpha_",r_var[j],"[k] ~ dnorm(0,tau_",r_var[j],")\n}\n")) + Reffects <- paste(Reffects, + paste0("for(k in 1:",nr[j],"){\n"), + paste0(" alpha_",r_var[j],"[k] ~ dnorm(0,tau_",r_var[j],")\n}\n")) } ## create priors Rpriors <- paste(Rpriors,paste0("tau_",r_var," ~ dgamma(1,0.1)\n",collapse = " ")) @@ -120,7 +123,7 @@ model{ if(FALSE){ ## DEV TESTING FOR X, polynomial X, and X interactions - fixed <- "X + X^3 + X*bob + bob + dia + X*Tmin[t]" + fixed <- "X + X^3 + X*bob + bob + dia + X*Tmin[t]" ## faux model, just for testing jags code } ## Design matrix if (is.null(fixed)) { @@ -137,6 +140,7 @@ model{ fixed <- paste("~", fixed) } + ### BEGIN adding in tree size (endogenous variable X) ## First deal with endogenous terms (X and X*cov interactions) fixedX <- sub("~","",fixed, fixed=TRUE) lm.terms <- gsub("[[:space:]]", "", strsplit(fixedX,split = "+",fixed=TRUE)[[1]]) ## split on + and remove whitespace @@ -248,9 +252,10 @@ model{ if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at Xf",names(data))} - if(FALSE){ + if(FALSE){ # always false...just for development ## DEVEL TESTING FOR TIME VARYING - time_varying <- "TminJuly + PrecipDec + TminJuly*PrecipDec" + #time_varying <- "TminJuly + PrecipDec + TminJuly*PrecipDec" + time_varying <- "tmax_Jun + ppt_Dec + tmax_Jun*ppt_Dec" time_data <- list(TminJuly = matrix(0,4,4),PrecipDec = matrix(1,4,4)) } @@ -351,9 +356,11 @@ model{ } ## state variable initial condition - z0 <- t(apply(data$y, 1, function(y) { - -rev(cumsum(rev(y))) - })) + data$z[, ncol(data$z)] + if(is.null(z0)){ + z0 <- t(apply(data$y, 1, function(y) { + -rev(cumsum(rev(y))) + })) + data$z[, ncol(data$z)] + } ## JAGS initial conditions nchain <- 3 From 448276124d9a609b3e04097f844f2feaffce8d33 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Mon, 10 Jul 2017 13:29:57 -0400 Subject: [PATCH 078/771] InventoryGrowthFusion: * add deviance to tracked variables to allow post-hoc calculation of information metrics * fix bug in setting time-varying variables w/o interactions * naming consistency, dropped exta underscore in time interaction * namespace on ciEnvelope * add gelman diagnostics & traceplots on betas --- modules/data.land/R/InventoryGrowthFusion.R | 44 +++++++++++++------ .../R/InventoryGrowthFusionDiagnostics.R | 38 +++++++++++----- 2 files changed, 59 insertions(+), 23 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index 64158cc5aa3..09da5559c50 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -13,7 +13,7 @@ InventoryGrowthFusion <- function(data, cov.data=NULL,time_data = NULL,n.iter=50 # baseline variables to monitor burnin.variables <- c("tau_add", "tau_dbh", "tau_inc", "mu") # process variability, dbh and tree-ring observation error, intercept - out.variables <- c("x", "tau_add", "tau_dbh", "tau_inc", "mu") + out.variables <- c("deviance","x", "tau_add", "tau_dbh", "tau_inc", "mu") # start text object that will be manipulated (to build different linear models, swap in/out covariates) TreeDataFusionMV <- " @@ -57,7 +57,11 @@ model{ }" Pformula <- NULL - ## RANDOM EFFECTS + ######################################################################## + ### + ### RANDOM EFFECTS + ### + ######################################################################## if (!is.null(random)) { Rpriors <- NULL Reffects <- NULL @@ -121,6 +125,11 @@ model{ TreeDataFusionMV <- gsub(pattern = "## RANDOM_EFFECTS", Reffects, TreeDataFusionMV) } ### END RANDOM EFFECTS + ######################################################################## + ### + ### FIXED EFFECTS + ### + ######################################################################## if(FALSE){ ## DEV TESTING FOR X, polynomial X, and X interactions fixed <- "X + X^3 + X*bob + bob + dia + X*Tmin[t]" ## faux model, just for testing jags code @@ -252,6 +261,12 @@ model{ if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at Xf",names(data))} + ######################################################################## + ### + ### TIME-VARYING + ### + ######################################################################## + if(FALSE){ # always false...just for development ## DEVEL TESTING FOR TIME VARYING #time_varying <- "TminJuly + PrecipDec + TminJuly*PrecipDec" @@ -259,10 +274,9 @@ model{ time_data <- list(TminJuly = matrix(0,4,4),PrecipDec = matrix(1,4,4)) } - ## Time-varying covariates if(!is.null(time_varying)){ if (is.null(time_data)) { - print("time_varying formula provided but time_data is absent:", time_varying) + PEcAn.utils::logger.error("time_varying formula provided but time_data is absent:", time_varying) } Xt.priors <- "" @@ -270,19 +284,20 @@ model{ t_vars <- gsub(" ","",unlist(strsplit(time_varying,"+",fixed=TRUE))) ## split on +, remove whitespace ## check for interaction terms it_vars <- t_vars[grep(pattern = "*",x=t_vars,fixed = TRUE)] - t_vars <- t_vars[!(t_vars == it_vars)] - - ## need to deal with interactions with fixed variables - ## will get really nasty if interactions are with catagorical variables - ## need to create new data matrices on the fly + if(length(it_vars) > 0){ + t_vars <- t_vars[!(t_vars == it_vars)] + } + ## INTERACTIONS WITH TIME-VARYING VARS + ## TODO: deal with interactions with catagorical variables + ## need to create new data matrices on the fly for(i in seq_along(it_vars)){ ##is covariate fixed or time varying? covX <- strsplit(it_vars[i],"*",fixed=TRUE)[[1]] tvar <- length(grep("[t]",covX[1],fixed=TRUE)) > 0 tvar[2] <- length(grep("[t]",covX[2],fixed=TRUE)) > 0 - myBeta <- "beta_" + myBeta <- "beta" for(j in 1:2){ if(j == 2) myBeta <- paste0(myBeta,"_") if(tvar[j]){ @@ -377,9 +392,11 @@ model{ year = rep(0, data$nt)) } - ## compile JAGS model + + PEcAn.utils::logger.info("COMPILE JAGS MODEL") j.model <- jags.model(file = textConnection(TreeDataFusionMV), data = data, inits = init, n.chains = 3) - ## burn-in + + PEcAn.utils::logger.info("BURN IN") jags.out <- coda.samples(model = j.model, variable.names = burnin.variables, n.iter = min(n.iter, 2000)) @@ -387,7 +404,8 @@ model{ plot(jags.out) } - ## run MCMC + PEcAn.utils::logger.info("RUN MCMC") + load.module("dic") coda.samples(model = j.model, variable.names = out.variables, n.iter = n.iter) } # InventoryGrowthFusion diff --git a/modules/data.land/R/InventoryGrowthFusionDiagnostics.R b/modules/data.land/R/InventoryGrowthFusionDiagnostics.R index 54a5cfe5f1a..e0723733115 100644 --- a/modules/data.land/R/InventoryGrowthFusionDiagnostics.R +++ b/modules/data.land/R/InventoryGrowthFusionDiagnostics.R @@ -6,8 +6,6 @@ ##' @export InventoryGrowthFusionDiagnostics <- function(jags.out, combined) { - #### Diagnostic plots - ### DBH par(mfrow=c(3,2)) layout(matrix(1:8, 4, 2, byrow = TRUE)) out <- as.matrix(jags.out) @@ -22,7 +20,7 @@ InventoryGrowthFusionDiagnostics <- function(jags.out, combined) { plot(data$time, ci[2, sel], type = "n", ylim = range(rng), ylab = "DBH (cm)", main = i) - ciEnvelope(data$time, ci[1, sel], ci[3, sel], col = "lightBlue") + PEcAn.visualization::ciEnvelope(data$time, ci[1, sel], ci[3, sel], col = "lightBlue") points(data$time, data$z[i, ], pch = "+", cex = 1.5) # lines(data$time,z0[i,],lty=2) @@ -34,7 +32,7 @@ InventoryGrowthFusionDiagnostics <- function(jags.out, combined) { plot(data$time[-1], inc.ci[2, ], type = "n", ylim = range(inc.ci, na.rm = TRUE), ylab = "Ring Increment (mm)") - ciEnvelope(data$time[-1], inc.ci[1, ], inc.ci[3, ], col = "lightBlue") + PEcAn.visualization::ciEnvelope(data$time[-1], inc.ci[1, ], inc.ci[3, ], col = "lightBlue") points(data$time, data$y[i, ] * 5, pch = "+", cex = 1.5, type = "b", lty = 2) } @@ -47,26 +45,46 @@ InventoryGrowthFusionDiagnostics <- function(jags.out, combined) { } ## process model - vars <- (1:ncol(out))[-c(which(substr(colnames(out), 1, 1) == "x"), grep("tau", colnames(out)), - grep("year", colnames(out)), grep("ind", colnames(out)))] + vars <- (1:ncol(out))[-c(which(substr(colnames(out), 1, 1) == "x"), + grep("tau", colnames(out)), + grep("year", colnames(out)), + grep("ind", colnames(out)), + grep("alpha",colnames(out)), + grep("deviance",colnames(out)))] par(mfrow = c(1, 1)) for (i in vars) { hist(out[, i], main = colnames(out)[i]) + abline(v=0,lwd=3) } - if (length(vars) > 1) { + if (length(vars) > 1 & length(vars) < 10) { pairs(out[, vars]) } + + if("deviance" %in% colnames(out)){ + hist(out[,"deviance"]) + vars <- c(vars,which(colnames(out)=="deviance")) + } + + + ## rebuild coda for just vars + var.out <- as.mcmc.list(lapply(jags.out,function(x){ x[,vars]})) + + ## convergence + gelman.diag(var.out) + + #### Diagnostic plots + plot(var.out) ## Standard Deviations layout(matrix(c(1,2,3,3),2,2,byrow=TRUE)) par(mfrow = c(2, 3)) prec <- out[, grep("tau", colnames(out))] - for (i in seq_along(prec)) { + for (i in seq_along(colnames(prec))) { hist(1 / sqrt(prec[, i]), main = colnames(prec)[i]) } cor(prec) # pairs(prec) - + par(mfrow = c(1, 1)) ### YEAR year.cols <- grep("year", colnames(out)) @@ -74,7 +92,7 @@ InventoryGrowthFusionDiagnostics <- function(jags.out, combined) { ci.yr <- apply(out[, year.cols], 2, quantile, c(0.025, 0.5, 0.975)) plot(data$time, ci.yr[2, ], type = "n", ylim = range(ci.yr, na.rm = TRUE), ylab = "Year Effect") - ciEnvelope(data$time, ci.yr[1, ], ci.yr[3, ], col = "lightBlue") + PEcAn.visualization::ciEnvelope(data$time, ci.yr[1, ], ci.yr[3, ], col = "lightBlue") lines(data$time, ci.yr[2, ], lty = 1, lwd = 2) abline(h = 0, lty = 2) } From 93f6895c2b14f36f5b930fb9e0f4743517ef77ec Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Mon, 10 Jul 2017 14:49:32 -0400 Subject: [PATCH 079/771] tree-ring: visualization of arbitrary random effects --- .../data.land/R/InventoryGrowthFusionDiagnostics.R | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/modules/data.land/R/InventoryGrowthFusionDiagnostics.R b/modules/data.land/R/InventoryGrowthFusionDiagnostics.R index e0723733115..9f453808e69 100644 --- a/modules/data.land/R/InventoryGrowthFusionDiagnostics.R +++ b/modules/data.land/R/InventoryGrowthFusionDiagnostics.R @@ -86,6 +86,18 @@ InventoryGrowthFusionDiagnostics <- function(jags.out, combined) { par(mfrow = c(1, 1)) + ### alpha + alpha.cols <- grep("alpha", colnames(out)) + if (length(alpha.cols) > 0) { + alpha.ord <- 1:length(alpha.cols) + ci.alpha <- apply(out[, alpha.cols], 2, quantile, c(0.025, 0.5, 0.975)) + plot(alpha.ord, ci.alpha[2, ], type = "n", + ylim = range(ci.alpha, na.rm = TRUE), ylab = "Random Effects") + PEcAn.visualization::ciEnvelope(alpha.ord, ci.alpha[1, ], ci.alpha[3, ], col = "lightBlue") + lines(alpha.ord, ci.alpha[2, ], lty = 1, lwd = 2) + abline(h = 0, lty = 2) + } + ### YEAR year.cols <- grep("year", colnames(out)) if (length(year.cols > 0)) { From 096c8cadd3a00ea39888a77826fec9501126f512 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Mon, 10 Jul 2017 20:09:42 -0400 Subject: [PATCH 080/771] tree ring: time index fix on X*time-varying --- modules/data.land/R/InventoryGrowthFusion.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index 09da5559c50..cb94fb047ac 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -138,12 +138,14 @@ model{ if (is.null(fixed)) { Xf <- NULL } else { + ## check for covariate data (note: will falsely fail if only effect is X) if (is.null(cov.data)) { print("formula provided but covariate data is absent:", fixed) } else { cov.data <- as.data.frame(cov.data) } + ## check if there's a tilda in the formula if (length(grep("~", fixed)) == 0) { fixed <- paste("~", fixed) @@ -183,8 +185,7 @@ model{ } if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at covX",names(data))} -# covX <- paste0(covX,"[i,t-1]") - myIndex <- "[i,t-1]" + myIndex <- "[i,t]" } else { ## variable is fixed if(covX %in% colnames(cov.data)){ ## covariate present From f360a793b4879bfde92d6ecea348b4b6afe6e9e8 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 11 Jul 2017 16:15:32 -0400 Subject: [PATCH 081/771] first pass at dalec default param file --- models/dalec/inst/default_param.dalec | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 models/dalec/inst/default_param.dalec diff --git a/models/dalec/inst/default_param.dalec b/models/dalec/inst/default_param.dalec new file mode 100644 index 00000000000..112294d43be --- /dev/null +++ b/models/dalec/inst/default_param.dalec @@ -0,0 +1,16 @@ +cmdTag val +t1 4.41E-06 #Decomposition from litter to SOM +t2 0.473267 #% GPP lost to respiration +t3 0.314951 #% NPP sent to foliage +t4 0.434401 #% NPP sent to roots +t5 0.00266518 #rate of leaf loss +t6 2.06E-06 #rate of wood loss +t7 2.48E-03 #rate of root loss +t8 2.28E-02 #rate of respiration from litter +t9 2.65E-06 #rate of respiration from litter SOM +cf0 57.7049 #initial canopy foliar carbon (g/m2) +cw0 769.863 #initial pool of woody carbon (g/m2) +cr0 101.955 #initial pool of fine root carbon (g/m2) +cl0 40.4494 #initial pool of litter carbon (g/m2) +cs0 9896.7 #initial pool of soil organic matter and woody debris carbon (g/m2) +##taken from dalec_model.c \ No newline at end of file From 5ae4d4748abdb4a55693353f4e97c01b0f971f2e Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 11 Jul 2017 18:12:45 -0400 Subject: [PATCH 082/771] IC for write.configs.dalec in progress --- models/dalec/R/write.configs.dalec.R | 56 +++++++++++++++++++++++++++ models/dalec/inst/default_param.dalec | 2 +- 2 files changed, 57 insertions(+), 1 deletion(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 4cc8c2a0c51..b4d0f51e993 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -114,6 +114,62 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } } + ### INITIAL CONDITIONS + + default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC")) + IC.param <- data.frame() + if (!is.null(settings$run$inputs$poolinitcond$path)) { + IC.path <- settings$run$inputs$poolinitcond$path + IC.nc <- try(ncdf4::nc_open(IC.path)) + + if(class(IC.nc) != "try-error"){ + # cf0 initial canopy foliar carbon (g/m2) + leaf <- try(ncdf4::ncvar_get(IC.nc,"leaf_carbon_content"),silent = TRUE) + if (!is.na(leaf) && is.numeric(leaf)) { + param[["cf0"]] <- leaf + } + # cw0 initial pool of woody carbon (g/m2) + AbvGrndWood <- try(ncdf4::ncvar_get(IC.nc,"AbvGrndWood"),silent = TRUE) + if (!is.na(AbvGrndWood) && is.numeric(AbvGrndWood)) { + roots <- try(ncdf4::ncvar_get(IC.nc,"root_carbon_content"),silent = TRUE) + if(!is.na(roots) && is.numeric(roots)){ + #wood <- partitioned coarse roots + abvgroundwood + } + else{ + #wood <- (roots-default.fine) + abvgroundwood + } + param[["cw0"]] <- wood + } + # cr0 initial pool of fine root carbon (g/m2) + roots <- try(ncdf4::ncvar_get(IC.nc,"root_carbon_content"),silent = TRUE) + if (!is.na(roots) && is.numeric(roots)) { + #partition fine roots + param[["cr0"]] <- roots + } + # cl0 initial pool of litter carbon (g/m2) + litter <- try(ncdf4::ncvar_get(IC.nc,"litter_carbon_content"),silent = TRUE) + if (!is.na(litter) && is.numeric(litter)) { + param[["cl0"]] <- litter + } + # cs0 initial pool of soil organic matter and woody debris carbon (g/m2) + soil <- try(ncdf4::ncvar_get(IC.nc,"soil_organic_carbon_content"),silent = TRUE) + if(!is.numeric(soil)){ + soil <- try(ncdf4::ncvar_get(IC.nc,"soil_carbon_content"),silent = TRUE) + if(is.numeric(soil)){ + wood <- try(ncdf4::ncvar_get(IC.nc,"wood_debris_carbon_content"),silent = TRUE) + if(is.numeric(wood)){ + soil_and_wood <- soil + sum(wood) + param[["cs0"]] <- soil_and_wood + } + } + } + } + else{ + PEcAn.utils::logger.error("Bad initial conditions filepath; kept defaults") + } + } + + # find out where to write run/ouput rundir <- file.path(settings$host$rundir, as.character(run.id)) outdir <- file.path(settings$host$outdir, as.character(run.id)) diff --git a/models/dalec/inst/default_param.dalec b/models/dalec/inst/default_param.dalec index 112294d43be..38f238d4ac5 100644 --- a/models/dalec/inst/default_param.dalec +++ b/models/dalec/inst/default_param.dalec @@ -1,4 +1,4 @@ -cmdTag val +cmdFlag val t1 4.41E-06 #Decomposition from litter to SOM t2 0.473267 #% GPP lost to respiration t3 0.314951 #% NPP sent to foliage From 13176cdb02c66c827c386177eaa7f582810e7c11 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 12 Jul 2017 14:02:11 -0400 Subject: [PATCH 083/771] Add wood vars and reorder --- utils/data/standard_vars.csv | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/utils/data/standard_vars.csv b/utils/data/standard_vars.csv index 2186b5d33f3..7dbdcfb3790 100755 --- a/utils/data/standard_vars.csv +++ b/utils/data/standard_vars.csv @@ -26,20 +26,22 @@ "surface_litter_carbon_flux","surface_litter_carbon_flux","kg C m-2 s-1","Surface Litter Carbon Flux","Carbon Fluxes","real","lon","lat","time",NA,"Total carbon flux of surface litter" "subsurface_litter_carbon_flux","subsurface_litter_carbon_flux","kg C m-2 s-1","Subsurface Litter Carbon Flux","Carbon Fluxes","real","lon","lat","time","depth","Total carbon flux of subsurface litter" "leaf_litter_carbon_flux","leaf_litter_carbon_flux","kg C m-2 s-1","Leaf Litter Carbon Flux","Carbon Fluxes","real","lon","lat","time",NA,"Carbon flux of leaf litter" +"WoodyLitter","wood_litter_carbon_flux","kg C m-2 s-1","Wood Litter Carbon Flux","Deprecated","real","lon","lat","time",NA,"DALEC output; haven't yet resolved standard woody litter flux" "wood_debris_carbon_flux","wood_debris_carbon_flux","kg C m-2 s-1","Wood Debris Carbon Flux","Carbon Fluxes","real","lon","lat","time","wdsize","Total carbon flux of woody debris, including downed woody debris and standing deadwood; excludes litter; size class defined by wdsize dimension" +"GWBI",NA,"kg C m-2 month-1","Gross Woody Biomass Increment","Carbon Pools","real","lon","lat","time",NA,"Variable most analogous to tree-ring-derived change in stem biomass (before mortality/CWD flux)" +"CWDI",NA,"kg C m-2 month-1","Coarse Woody Debris Increment","Carbon Pools","real","lon","lat","time",NA,"Variable most analogous to flux of woody material material to the detrital pool resulting from mortality" "CO2CAS",NA,"ppmv","CO2CAS","Carbon Fluxes","real","lon","lat","time",NA,"CO2 in canopy air space; ED2 output variable" "CropYield",NA,"kg m-2","CropYield","Carbon Fluxes","real","lon","lat","time","pft","Crop yield; ED2 output variable" "poolname",NA,"(-)","Name of each Carbon Pool","Deprecated","character","nchar","npool",NA,NA,"Name of each carbon pool (i.e., wood or Coarse Woody Debris)" "CarbPools",NA,"kg C m-2","Size of each carbon pool","Deprecated","real","lon","lat","npool","time","Total size of each carbon pool vertically integrated over the entire soil column" "AbvGrndWood",NA,"kg C m-2","Above ground woody biomass","Carbon Pools","real","lon","lat","time",NA,"Total above ground wood biomass" "TotLivBiom",NA,"kg C m-2","Total living biomass","Carbon Pools","real","lon","lat","time",NA,"Total carbon content of the living biomass (leaves+roots+wood)" -"TotSoilCarb",NA,"kg C m-2","Total Soil Carbon","Carbon Pools","real","lon","lat","time",NA,"Total soil and litter carbon content vertically integrated over the enire soil column" -"LAI",NA,"m2 m-2","Leaf Area Index","Carbon Pools","real","lon","lat","time",NA,"Area of leaves per area ground" -"GWBI",NA,"kg C m-2 month-1","Gross Woody Biomass Increment","Carbon Pools","real","lon","lat","time",NA,"Variable most analogous to tree-ring-derived change in stem biomass (before mortality/CWD flux)" -"CWDI",NA,"kg C m-2 month-1","Coarse Woody Debris Increment","Carbon Pools","real","lon","lat","time",NA,"Variable most analogous to flux of woody material material to the detrital pool resulting from mortality" "AGB",NA,"kg C m-2","Total aboveground biomass","Carbon Pools","real","lon","lat","time",NA,"aboveground biomass" +"LAI",NA,"m2 m-2","Leaf Area Index","Carbon Pools","real","lon","lat","time",NA,"Area of leaves per area ground" "leaf_carbon_content","leaf_carbon_content","kg C m-2","Leaf Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Leaf carbon content" "root_carbon_content","root_carbon_content_of_size_class","kg C m-2","Root Carbon Content","Carbon Pools","real","lon","lat","time","rtsize","Root carbon content by size class" +"wood_carbon_content","wood_carbon_content","kg C m-2","Wood Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Wood carbon content including above (AbvGrndWood) and below ground (coarse roots, shared with root_carbon_content)" +"TotSoilCarb",NA,"kg C m-2","Total Soil Carbon","Carbon Pools","real","lon","lat","time",NA,"Total soil and litter carbon content vertically integrated over the enire soil column" "litter_carbon_content","litter_carbon_content","kg C m-2","Litter Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Total carbon content of litter pool, excluding coarse woody debris" "surface_litter_carbon_content","surface_litter_carbon_content","kg C m-2","Surface Litter Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Carbon content of surface litter pool" "subsurface_litter_carbon_content","subsurface_litter_carbon_content","kg C m-2","Subsurface Litter Carbon Content","Carbon Pools","real","lon","lat","time","depth","Carbon content of subsurface litter pool; depth dimension optional" From b07fc69e2be4334967d1dcb24332548486c0504a Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 12 Jul 2017 14:15:24 -0400 Subject: [PATCH 084/771] Rename DALEC output vars to standard names --- models/dalec/R/model2netcdf.DALEC.R | 38 ++++++++++++++--------------- 1 file changed, 18 insertions(+), 20 deletions(-) diff --git a/models/dalec/R/model2netcdf.DALEC.R b/models/dalec/R/model2netcdf.DALEC.R index 076e370c11c..30bf76dd896 100644 --- a/models/dalec/R/model2netcdf.DALEC.R +++ b/models/dalec/R/model2netcdf.DALEC.R @@ -48,25 +48,23 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { ## Setup outputs for netCDF file in appropriate units output <- list() - ## standard variables: Fluxes + ## Fluxes output[[1]] <- (sub.DALEC.output[, 1] * 0.001)/timestep.s # Autotrophic Respiration in kgC/m2/s output[[2]] <- (sub.DALEC.output[, 21] + sub.DALEC.output[, 23]) * 0.001 / timestep.s # Heterotrophic Resp kgC/m2/s output[[3]] <- (sub.DALEC.output[, 31] * 0.001)/timestep.s # GPP in kgC/m2/s output[[4]] <- (sub.DALEC.output[, 33] * 0.001)/timestep.s # NEE in kgC/m2/s output[[5]] <- (sub.DALEC.output[, 3] + sub.DALEC.output[, 5] + sub.DALEC.output[, 7]) * 0.001/timestep.s # NPP kgC/m2/s + output[[6]] <- (sub.DALEC.output[, 9] * 0.001) / timestep.s # Leaf Litter Flux, kgC/m2/s + output[[7]] <- (sub.DALEC.output[, 11] * 0.001) / timestep.s # Woody Litter Flux, kgC/m2/s + output[[8]] <- (sub.DALEC.output[, 13] * 0.001) / timestep.s # Root Litter Flux, kgC/m2/s - ## non-standard variables: Fluxes - output[[6]] <- (sub.DALEC.output[, 9] * 0.001) / timestep.s # Leaf Litter, kgC/m2/s - output[[7]] <- (sub.DALEC.output[, 11] * 0.001) / timestep.s # Woody Litter, kgC/m2/s - output[[8]] <- (sub.DALEC.output[, 13] * 0.001) / timestep.s # Root Litter, kgC/m2/s - - ## non-standard variables: Pools - output[[9]] <- (sub.DALEC.output[, 15] * 0.001) # Leaf Biomass, kgC/m2 - output[[10]] <- (sub.DALEC.output[, 17] * 0.001) # Wood Biomass, kgC/m2 - output[[11]] <- (sub.DALEC.output[, 19] * 0.001) # Root Biomass, kgC/m2 - output[[12]] <- (sub.DALEC.output[, 27] * 0.001) # Litter Biomass, kgC/m2 - output[[13]] <- (sub.DALEC.output[, 29] * 0.001) # Soil C, kgC/m2 + ## Pools + output[[9]] <- (sub.DALEC.output[, 15] * 0.001) # Leaf Carbon, kgC/m2 + output[[10]] <- (sub.DALEC.output[, 17] * 0.001) # Wood Carbon, kgC/m2 + output[[11]] <- (sub.DALEC.output[, 19] * 0.001) # Root Carbon, kgC/m2 + output[[12]] <- (sub.DALEC.output[, 27] * 0.001) # Litter Carbon, kgC/m2 + output[[13]] <- (sub.DALEC.output[, 29] * 0.001) # Soil Carbon, kgC/m2 ## standard composites output[[14]] <- output[[1]] + output[[2]] # Total Respiration @@ -93,14 +91,14 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { nc_var[[3]] <- mstmipvar("GPP", lat, lon, t, NA) nc_var[[4]] <- mstmipvar("NEE", lat, lon, t, NA) nc_var[[5]] <- mstmipvar("NPP", lat, lon, t, NA) - nc_var[[6]] <- ncvar_def("LeafLitter", "kgC/m2/s", list(lon, lat, t), -999) - nc_var[[7]] <- ncvar_def("WoodyLitter", "kgC/m2/s", list(lon, lat, t), -999) - nc_var[[8]] <- ncvar_def("RootLitter", "kgC/m2/s", list(lon, lat, t), -999) - nc_var[[9]] <- ncvar_def("LeafBiomass", "kgC/m2", list(lon, lat, t), -999) - nc_var[[10]] <- ncvar_def("WoodBiomass", "kgC/m2", list(lon, lat, t), -999) - nc_var[[11]] <- ncvar_def("RootBiomass", "kgC/m2", list(lon, lat, t), -999) - nc_var[[12]] <- ncvar_def("LitterBiomass", "kgC/m2", list(lon, lat, t), -999) - nc_var[[13]] <- ncvar_def("SoilC", "kgC/m2", list(lon, lat, t), -999) + nc_var[[6]] <- ncvar_def("leaf_litter_carbon_flux", "kgC/m2/s", list(lon, lat, t), -999) #was LeafLitter + nc_var[[7]] <- ncvar_def("WoodyLitter", "kgC/m2/s", list(lon, lat, t), -999) #need to resolve standard woody litter flux + nc_var[[8]] <- ncvar_def("subsurface_litter_carbon_flux", "kgC/m2/s", list(lon, lat, t), -999) #was RootLitter + nc_var[[9]] <- ncvar_def("leaf_carbon_content", "kgC/m2", list(lon, lat, t), -999) #was LeafBiomass + nc_var[[10]] <- ncvar_def("wood_carbon_content", "kgC/m2", list(lon, lat, t), -999) #was WoodBiomass + nc_var[[11]] <- ncvar_def("root_carbon_content", "kgC/m2", list(lon, lat, t,rtsize), -999) #was RootBiomass + nc_var[[12]] <- ncvar_def("litter_carbon_content", "kgC/m2", list(lon, lat, t), -999) #was LitterBiomass + nc_var[[13]] <- ncvar_def("soil_carbon_content", "kgC/m2", list(lon, lat, t), -999) #was SoilC; SOM pool technically includes woody debris (can't be represented by our standard) nc_var[[14]] <- mstmipvar("TotalResp", lat, lon, t, NA) nc_var[[15]] <- mstmipvar("TotLivBiom", lat, lon, t, NA) From c8ccb6b2cde3a395fc2c32000e6fea0d6880d0a7 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 12 Jul 2017 15:26:53 -0400 Subject: [PATCH 085/771] Fix categories --- utils/data/standard_vars.csv | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/utils/data/standard_vars.csv b/utils/data/standard_vars.csv index 7dbdcfb3790..d5f98969a27 100755 --- a/utils/data/standard_vars.csv +++ b/utils/data/standard_vars.csv @@ -28,8 +28,8 @@ "leaf_litter_carbon_flux","leaf_litter_carbon_flux","kg C m-2 s-1","Leaf Litter Carbon Flux","Carbon Fluxes","real","lon","lat","time",NA,"Carbon flux of leaf litter" "WoodyLitter","wood_litter_carbon_flux","kg C m-2 s-1","Wood Litter Carbon Flux","Deprecated","real","lon","lat","time",NA,"DALEC output; haven't yet resolved standard woody litter flux" "wood_debris_carbon_flux","wood_debris_carbon_flux","kg C m-2 s-1","Wood Debris Carbon Flux","Carbon Fluxes","real","lon","lat","time","wdsize","Total carbon flux of woody debris, including downed woody debris and standing deadwood; excludes litter; size class defined by wdsize dimension" -"GWBI",NA,"kg C m-2 month-1","Gross Woody Biomass Increment","Carbon Pools","real","lon","lat","time",NA,"Variable most analogous to tree-ring-derived change in stem biomass (before mortality/CWD flux)" -"CWDI",NA,"kg C m-2 month-1","Coarse Woody Debris Increment","Carbon Pools","real","lon","lat","time",NA,"Variable most analogous to flux of woody material material to the detrital pool resulting from mortality" +"GWBI",NA,"kg C m-2 month-1","Gross Woody Biomass Increment","Carbon Fluxes","real","lon","lat","time",NA,"Variable most analogous to tree-ring-derived change in stem biomass (before mortality/CWD flux)" +"CWDI",NA,"kg C m-2 month-1","Coarse Woody Debris Increment","Carbon Fluxes","real","lon","lat","time",NA,"Variable most analogous to flux of woody material material to the detrital pool resulting from mortality" "CO2CAS",NA,"ppmv","CO2CAS","Carbon Fluxes","real","lon","lat","time",NA,"CO2 in canopy air space; ED2 output variable" "CropYield",NA,"kg m-2","CropYield","Carbon Fluxes","real","lon","lat","time","pft","Crop yield; ED2 output variable" "poolname",NA,"(-)","Name of each Carbon Pool","Deprecated","character","nchar","npool",NA,NA,"Name of each carbon pool (i.e., wood or Coarse Woody Debris)" From 49a457e251415c4d78ee6ed4ec597380cc721d71 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 12 Jul 2017 15:34:24 -0400 Subject: [PATCH 086/771] Add fine/coarse root vars --- utils/data/standard_vars.csv | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/utils/data/standard_vars.csv b/utils/data/standard_vars.csv index d5f98969a27..3a650db0c03 100755 --- a/utils/data/standard_vars.csv +++ b/utils/data/standard_vars.csv @@ -40,6 +40,20 @@ "LAI",NA,"m2 m-2","Leaf Area Index","Carbon Pools","real","lon","lat","time",NA,"Area of leaves per area ground" "leaf_carbon_content","leaf_carbon_content","kg C m-2","Leaf Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Leaf carbon content" "root_carbon_content","root_carbon_content_of_size_class","kg C m-2","Root Carbon Content","Carbon Pools","real","lon","lat","time","rtsize","Root carbon content by size class" +"fine_root_carbon_content","fine_root_carbon_content","kg C m-2","Fine Root Carbon Content","Carbon Pools","real","lon","lat","time","depth","Carbon content of fine roots (2 mm and smaller); alternative to providing dimensions for root_carbon_content" +"coarse_root_carbon_content","coarse_root_carbon_content","kg C m-2","Coarse Root Carbon Content","Carbon Pools","real","lon","lat","time","depth","Carbon content of coarse roots (larger than 2 mm); alternative to providing dimensions for root_carbon_content" +"WoodyLitter","wood_litter_carbon_flux","kg C m-2 s-1","Wood Litter Carbon Flux","Deprecated","real","lon","lat","time",NA,"DALEC output; haven't yet resolved standard woody litter flux" +"wood_debris_carbon_flux","wood_debris_carbon_flux","kg C m-2 s-1","Wood Debris Carbon Flux","Carbon Fluxes","real","lon","lat","time","wdsize","Total carbon flux of woody debris, including downed woody debris and standing deadwood; excludes litter; size class defined by wdsize dimension" +"GWBI",NA,"kg C m-2 month-1","Gross Woody Biomass Increment","Carbon Fluxes","real","lon","lat","time",NA,"Variable most analogous to tree-ring-derived change in stem biomass (before mortality/CWD flux)" +"CWDI",NA,"kg C m-2 month-1","Coarse Woody Debris Increment","Carbon Fluxes","real","lon","lat","time",NA,"Variable most analogous to flux of woody material material to the detrital pool resulting from mortality" +"CO2CAS",NA,"ppmv","CO2CAS","Carbon Fluxes","real","lon","lat","time",NA,"CO2 in canopy air space; ED2 output variable" +"CropYield",NA,"kg m-2","CropYield","Carbon Fluxes","real","lon","lat","time","pft","Crop yield; ED2 output variable" +"poolname",NA,"(-)","Name of each Carbon Pool","Deprecated","character","nchar","npool",NA,NA,"Name of each carbon pool (i.e., wood or Coarse Woody Debris)" +"CarbPools",NA,"kg C m-2","Size of each carbon pool","Deprecated","real","lon","lat","npool","time","Total size of each carbon pool vertically integrated over the entire soil column" +"AbvGrndWood",NA,"kg C m-2","Above ground woody biomass","Carbon Pools","real","lon","lat","time",NA,"Total above ground wood biomass" +"TotLivBiom",NA,"kg C m-2","Total living biomass","Carbon Pools","real","lon","lat","time",NA,"Total carbon content of the living biomass (leaves+roots+wood)" +"AGB",NA,"kg C m-2","Total aboveground biomass","Carbon Pools","real","lon","lat","time",NA,"aboveground biomass" +"wood_carbon_content","wood_carbon_content","kg C m-2","Wood Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Wood carbon content including above (AbvGrndWood) and below ground (coarse roots, shared with root_carbon_content)" "wood_carbon_content","wood_carbon_content","kg C m-2","Wood Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Wood carbon content including above (AbvGrndWood) and below ground (coarse roots, shared with root_carbon_content)" "TotSoilCarb",NA,"kg C m-2","Total Soil Carbon","Carbon Pools","real","lon","lat","time",NA,"Total soil and litter carbon content vertically integrated over the enire soil column" "litter_carbon_content","litter_carbon_content","kg C m-2","Litter Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Total carbon content of litter pool, excluding coarse woody debris" From 6b9983f522d3ad644be1422bfb16b6a59ccbb1a6 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 12 Jul 2017 15:38:24 -0400 Subject: [PATCH 087/771] Revert "Add fine/coarse root vars" This reverts commit 49a457e251415c4d78ee6ed4ec597380cc721d71. --- utils/data/standard_vars.csv | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/utils/data/standard_vars.csv b/utils/data/standard_vars.csv index 3a650db0c03..d5f98969a27 100755 --- a/utils/data/standard_vars.csv +++ b/utils/data/standard_vars.csv @@ -40,20 +40,6 @@ "LAI",NA,"m2 m-2","Leaf Area Index","Carbon Pools","real","lon","lat","time",NA,"Area of leaves per area ground" "leaf_carbon_content","leaf_carbon_content","kg C m-2","Leaf Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Leaf carbon content" "root_carbon_content","root_carbon_content_of_size_class","kg C m-2","Root Carbon Content","Carbon Pools","real","lon","lat","time","rtsize","Root carbon content by size class" -"fine_root_carbon_content","fine_root_carbon_content","kg C m-2","Fine Root Carbon Content","Carbon Pools","real","lon","lat","time","depth","Carbon content of fine roots (2 mm and smaller); alternative to providing dimensions for root_carbon_content" -"coarse_root_carbon_content","coarse_root_carbon_content","kg C m-2","Coarse Root Carbon Content","Carbon Pools","real","lon","lat","time","depth","Carbon content of coarse roots (larger than 2 mm); alternative to providing dimensions for root_carbon_content" -"WoodyLitter","wood_litter_carbon_flux","kg C m-2 s-1","Wood Litter Carbon Flux","Deprecated","real","lon","lat","time",NA,"DALEC output; haven't yet resolved standard woody litter flux" -"wood_debris_carbon_flux","wood_debris_carbon_flux","kg C m-2 s-1","Wood Debris Carbon Flux","Carbon Fluxes","real","lon","lat","time","wdsize","Total carbon flux of woody debris, including downed woody debris and standing deadwood; excludes litter; size class defined by wdsize dimension" -"GWBI",NA,"kg C m-2 month-1","Gross Woody Biomass Increment","Carbon Fluxes","real","lon","lat","time",NA,"Variable most analogous to tree-ring-derived change in stem biomass (before mortality/CWD flux)" -"CWDI",NA,"kg C m-2 month-1","Coarse Woody Debris Increment","Carbon Fluxes","real","lon","lat","time",NA,"Variable most analogous to flux of woody material material to the detrital pool resulting from mortality" -"CO2CAS",NA,"ppmv","CO2CAS","Carbon Fluxes","real","lon","lat","time",NA,"CO2 in canopy air space; ED2 output variable" -"CropYield",NA,"kg m-2","CropYield","Carbon Fluxes","real","lon","lat","time","pft","Crop yield; ED2 output variable" -"poolname",NA,"(-)","Name of each Carbon Pool","Deprecated","character","nchar","npool",NA,NA,"Name of each carbon pool (i.e., wood or Coarse Woody Debris)" -"CarbPools",NA,"kg C m-2","Size of each carbon pool","Deprecated","real","lon","lat","npool","time","Total size of each carbon pool vertically integrated over the entire soil column" -"AbvGrndWood",NA,"kg C m-2","Above ground woody biomass","Carbon Pools","real","lon","lat","time",NA,"Total above ground wood biomass" -"TotLivBiom",NA,"kg C m-2","Total living biomass","Carbon Pools","real","lon","lat","time",NA,"Total carbon content of the living biomass (leaves+roots+wood)" -"AGB",NA,"kg C m-2","Total aboveground biomass","Carbon Pools","real","lon","lat","time",NA,"aboveground biomass" -"wood_carbon_content","wood_carbon_content","kg C m-2","Wood Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Wood carbon content including above (AbvGrndWood) and below ground (coarse roots, shared with root_carbon_content)" "wood_carbon_content","wood_carbon_content","kg C m-2","Wood Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Wood carbon content including above (AbvGrndWood) and below ground (coarse roots, shared with root_carbon_content)" "TotSoilCarb",NA,"kg C m-2","Total Soil Carbon","Carbon Pools","real","lon","lat","time",NA,"Total soil and litter carbon content vertically integrated over the enire soil column" "litter_carbon_content","litter_carbon_content","kg C m-2","Litter Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Total carbon content of litter pool, excluding coarse woody debris" From ffb141beedf3fe8e566e9f31ea37a15e6843d5d8 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 12 Jul 2017 15:41:04 -0400 Subject: [PATCH 088/771] Add fine/coarse root vars --- utils/data/standard_vars.csv | 2 ++ 1 file changed, 2 insertions(+) diff --git a/utils/data/standard_vars.csv b/utils/data/standard_vars.csv index d5f98969a27..2223697a88e 100755 --- a/utils/data/standard_vars.csv +++ b/utils/data/standard_vars.csv @@ -40,6 +40,8 @@ "LAI",NA,"m2 m-2","Leaf Area Index","Carbon Pools","real","lon","lat","time",NA,"Area of leaves per area ground" "leaf_carbon_content","leaf_carbon_content","kg C m-2","Leaf Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Leaf carbon content" "root_carbon_content","root_carbon_content_of_size_class","kg C m-2","Root Carbon Content","Carbon Pools","real","lon","lat","time","rtsize","Root carbon content by size class" +"fine_root_carbon_content","fine_root_carbon_content","kg C m-2","Fine Root Carbon Content","Carbon Pools","real","lon","lat","time","depth","Carbon content of fine roots (2 mm and smaller); alternative to providing dimensions for root_carbon_content" +"coarse_root_carbon_content","coarse_root_carbon_content","kg C m-2","Coarse Root Carbon Content","Carbon Pools","real","lon","lat","time","depth","Carbon content of coarse roots (larger than 2 mm); alternative to providing dimensions for root_carbon_content" "wood_carbon_content","wood_carbon_content","kg C m-2","Wood Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Wood carbon content including above (AbvGrndWood) and below ground (coarse roots, shared with root_carbon_content)" "TotSoilCarb",NA,"kg C m-2","Total Soil Carbon","Carbon Pools","real","lon","lat","time",NA,"Total soil and litter carbon content vertically integrated over the enire soil column" "litter_carbon_content","litter_carbon_content","kg C m-2","Litter Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Total carbon content of litter pool, excluding coarse woody debris" From 8c4ebc6787c01dc6dfb71ace35ca9562b12ab667 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 12 Jul 2017 16:08:09 -0400 Subject: [PATCH 089/771] Reorder fluxes and other edits --- utils/data/standard_vars.csv | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/utils/data/standard_vars.csv b/utils/data/standard_vars.csv index 2223697a88e..969648f4414 100755 --- a/utils/data/standard_vars.csv +++ b/utils/data/standard_vars.csv @@ -15,34 +15,34 @@ "cal_date_beg",NA,"yr, mon, day, hr, min, sec","Calender date beginning averaging period","Deprecated","integer","ncal","time",NA,NA,"calender date beginning of time ave period: year, month, day, hour, minute, second for UTC time zone" "cal_date_end",NA,"yr, mon, day, hr, min, sec","Calender date end averaging period","Deprecated","integer","ncal","time",NA,NA,"calender date end of time ave period: year, month, day, hour, minute, second for UTC time zone" "GPP",NA,"kg C m-2 s-1","Gross Primary Productivity","Carbon Fluxes","real","lon","lat","time",NA,"Rate of photosynthesis (always positive)" -"NPP",NA,"kg C m-2 s-1","Net Primary Productivity","Carbon Fluxes","real","lon","lat","time",NA,"Net Primary Productivity (NPP=GPP-AutoResp, positive into plants)" +"NEE",NA,"kg C m-2 s-1","Net Ecosystem Exchange","Carbon Fluxes","real","lon","lat","time",NA,"Net Ecosystem Exchange (NEE=HeteroResp+AutoResp-GPP, positive into atmosphere)" "TotalResp",NA,"kg C m-2 s-1","Total Respiration","Carbon Fluxes","real","lon","lat","time",NA,"Total respiration (TotalResp=AutoResp+heteroResp, always positive)" "AutoResp",NA,"kg C m-2 s-1","Autotrophic Respiration","Carbon Fluxes","real","lon","lat","time",NA,"Autotrophic respiration rate (always positive)" "HeteroResp",NA,"kg C m-2 s-1","Heterotrophic Respiration","Carbon Fluxes","real","lon","lat","time",NA,"Heterotrophic respiration rate (always positive)" "DOC_flux",NA,"kg C m-2 s-1","Dissolved Organic Carbon flux","Carbon Fluxes","real","lon","lat","time",NA,"Loss of organic carbon dissolved in ground water or rivers (positive out of grid cell)" "Fire_flux",NA,"kg C m-2 s-1","Fire emissions","Carbon Fluxes","real","lon","lat","time",NA,"Flux of carbon due to fires (always positive)" -"NEE",NA,"kg C m-2 s-1","Net Ecosystem Exchange","Carbon Fluxes","real","lon","lat","time",NA,"Net Ecosystem Exchange (NEE=HeteroResp+AutoResp-GPP, positive into atmosphere)" "litter_carbon_flux","litter_carbon_flux","kg C m-2 s-1","Litter Carbon Flux","Carbon Fluxes","real","lon","lat","time",NA,"Total carbon flux of litter, excluding coarse woody debris" "surface_litter_carbon_flux","surface_litter_carbon_flux","kg C m-2 s-1","Surface Litter Carbon Flux","Carbon Fluxes","real","lon","lat","time",NA,"Total carbon flux of surface litter" "subsurface_litter_carbon_flux","subsurface_litter_carbon_flux","kg C m-2 s-1","Subsurface Litter Carbon Flux","Carbon Fluxes","real","lon","lat","time","depth","Total carbon flux of subsurface litter" "leaf_litter_carbon_flux","leaf_litter_carbon_flux","kg C m-2 s-1","Leaf Litter Carbon Flux","Carbon Fluxes","real","lon","lat","time",NA,"Carbon flux of leaf litter" "WoodyLitter","wood_litter_carbon_flux","kg C m-2 s-1","Wood Litter Carbon Flux","Deprecated","real","lon","lat","time",NA,"DALEC output; haven't yet resolved standard woody litter flux" "wood_debris_carbon_flux","wood_debris_carbon_flux","kg C m-2 s-1","Wood Debris Carbon Flux","Carbon Fluxes","real","lon","lat","time","wdsize","Total carbon flux of woody debris, including downed woody debris and standing deadwood; excludes litter; size class defined by wdsize dimension" +"NPP",NA,"kg C m-2 s-1","Net Primary Productivity","Carbon Fluxes","real","lon","lat","time",NA,"Net Primary Productivity (NPP=GPP-AutoResp, positive into plants)" "GWBI",NA,"kg C m-2 month-1","Gross Woody Biomass Increment","Carbon Fluxes","real","lon","lat","time",NA,"Variable most analogous to tree-ring-derived change in stem biomass (before mortality/CWD flux)" "CWDI",NA,"kg C m-2 month-1","Coarse Woody Debris Increment","Carbon Fluxes","real","lon","lat","time",NA,"Variable most analogous to flux of woody material material to the detrital pool resulting from mortality" -"CO2CAS",NA,"ppmv","CO2CAS","Carbon Fluxes","real","lon","lat","time",NA,"CO2 in canopy air space; ED2 output variable" "CropYield",NA,"kg m-2","CropYield","Carbon Fluxes","real","lon","lat","time","pft","Crop yield; ED2 output variable" "poolname",NA,"(-)","Name of each Carbon Pool","Deprecated","character","nchar","npool",NA,NA,"Name of each carbon pool (i.e., wood or Coarse Woody Debris)" "CarbPools",NA,"kg C m-2","Size of each carbon pool","Deprecated","real","lon","lat","npool","time","Total size of each carbon pool vertically integrated over the entire soil column" -"AbvGrndWood",NA,"kg C m-2","Above ground woody biomass","Carbon Pools","real","lon","lat","time",NA,"Total above ground wood biomass" "TotLivBiom",NA,"kg C m-2","Total living biomass","Carbon Pools","real","lon","lat","time",NA,"Total carbon content of the living biomass (leaves+roots+wood)" "AGB",NA,"kg C m-2","Total aboveground biomass","Carbon Pools","real","lon","lat","time",NA,"aboveground biomass" "LAI",NA,"m2 m-2","Leaf Area Index","Carbon Pools","real","lon","lat","time",NA,"Area of leaves per area ground" "leaf_carbon_content","leaf_carbon_content","kg C m-2","Leaf Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Leaf carbon content" -"root_carbon_content","root_carbon_content_of_size_class","kg C m-2","Root Carbon Content","Carbon Pools","real","lon","lat","time","rtsize","Root carbon content by size class" +"root_carbon_content","root_carbon_content_of_size_class","kg C m-2","Root Carbon Content","Carbon Pools","real","lon","lat","time","rtsize"," +Root carbon content, optionally by size class; alternatively specify fine_ and coarse_root_carbon_content" "fine_root_carbon_content","fine_root_carbon_content","kg C m-2","Fine Root Carbon Content","Carbon Pools","real","lon","lat","time","depth","Carbon content of fine roots (2 mm and smaller); alternative to providing dimensions for root_carbon_content" "coarse_root_carbon_content","coarse_root_carbon_content","kg C m-2","Coarse Root Carbon Content","Carbon Pools","real","lon","lat","time","depth","Carbon content of coarse roots (larger than 2 mm); alternative to providing dimensions for root_carbon_content" "wood_carbon_content","wood_carbon_content","kg C m-2","Wood Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Wood carbon content including above (AbvGrndWood) and below ground (coarse roots, shared with root_carbon_content)" +"AbvGrndWood",NA,"kg C m-2","Above ground woody biomass","Carbon Pools","real","lon","lat","time",NA,"Total above ground wood biomass" "TotSoilCarb",NA,"kg C m-2","Total Soil Carbon","Carbon Pools","real","lon","lat","time",NA,"Total soil and litter carbon content vertically integrated over the enire soil column" "litter_carbon_content","litter_carbon_content","kg C m-2","Litter Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Total carbon content of litter pool, excluding coarse woody debris" "surface_litter_carbon_content","surface_litter_carbon_content","kg C m-2","Surface Litter Carbon Content","Carbon Pools","real","lon","lat","time",NA,"Carbon content of surface litter pool" @@ -86,6 +86,7 @@ "SWE",NA,"kg m-2","Snow Water Equivalent","Physical Variables","real","lon","lat","time",NA,"Total water mass of snow pack, including ice and liquid water" "SnowDen",NA,"kg m-3","Bulk Snow Density","Physical Variables","real","lon","lat","time",NA,"Overall bulk density of the snow pack, including ice and liquid water" "SnowDepth",NA,"m","Total snow depth","Physical Variables","real","lon","lat","time",NA,"Total snow depth" +"CO2CAS",NA,"ppmv","CO2CAS","Physical Variables","real","lon","lat","time",NA,"CO2 in canopy air space; ED2 output variable" "CO2air",NA,"micromol mol-1","Near surface CO2 concentration","Driver","real","lon","lat","time",NA,"Near surface dry air CO2 mole fraction" "LWdown","surface_downwelling_longwave_flux_in_air","W/m2","Surface incident longwave radiation","Driver","real","lon","lat","time",NA,"Surface incident longwave radiation" "Psurf","air_pressure","Pa","Surface pressure","Driver","real","lon","lat","time",NA,"Surface pressure" From cefe3b46b6ac4e9ff403fcf1b3caa62ee0e9bf28 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 12 Jul 2017 16:44:03 -0400 Subject: [PATCH 090/771] Change mstmip calls to to_ncvar --- models/dalec/R/model2netcdf.DALEC.R | 38 +++++++++++++++-------------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/models/dalec/R/model2netcdf.DALEC.R b/models/dalec/R/model2netcdf.DALEC.R index 30bf76dd896..56fc78735f5 100644 --- a/models/dalec/R/model2netcdf.DALEC.R +++ b/models/dalec/R/model2netcdf.DALEC.R @@ -19,7 +19,7 @@ ##' @param start_date Start time of the simulation ##' @param end_date End time of the simulation ##' @importFrom ncdf4 ncvar_def ncdim_def -##' @importFrom PEcAn.utils mstmipvar +##' @importFrom PEcAn.utils mstmipvar to_ncvar to_ncdim ##' @export ##' @author Shawn Serbin, Michael Dietze model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { @@ -77,7 +77,8 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { calendar = "standard", unlim = TRUE) lat <- ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") lon <- ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") - + + dims <- list(time = t, lon = lon, lat = lat) ## ***** Need to dynamically update the UTC offset here ***** for (i in seq_along(output)) { @@ -85,24 +86,25 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { output[[i]] <- rep(-999, length(t$vals)) } + nc_var <- list() - nc_var[[1]] <- mstmipvar("AutoResp", lat, lon, t, NA) - nc_var[[2]] <- mstmipvar("HeteroResp", lat, lon, t, NA) - nc_var[[3]] <- mstmipvar("GPP", lat, lon, t, NA) - nc_var[[4]] <- mstmipvar("NEE", lat, lon, t, NA) - nc_var[[5]] <- mstmipvar("NPP", lat, lon, t, NA) - nc_var[[6]] <- ncvar_def("leaf_litter_carbon_flux", "kgC/m2/s", list(lon, lat, t), -999) #was LeafLitter - nc_var[[7]] <- ncvar_def("WoodyLitter", "kgC/m2/s", list(lon, lat, t), -999) #need to resolve standard woody litter flux - nc_var[[8]] <- ncvar_def("subsurface_litter_carbon_flux", "kgC/m2/s", list(lon, lat, t), -999) #was RootLitter - nc_var[[9]] <- ncvar_def("leaf_carbon_content", "kgC/m2", list(lon, lat, t), -999) #was LeafBiomass - nc_var[[10]] <- ncvar_def("wood_carbon_content", "kgC/m2", list(lon, lat, t), -999) #was WoodBiomass - nc_var[[11]] <- ncvar_def("root_carbon_content", "kgC/m2", list(lon, lat, t,rtsize), -999) #was RootBiomass - nc_var[[12]] <- ncvar_def("litter_carbon_content", "kgC/m2", list(lon, lat, t), -999) #was LitterBiomass - nc_var[[13]] <- ncvar_def("soil_carbon_content", "kgC/m2", list(lon, lat, t), -999) #was SoilC; SOM pool technically includes woody debris (can't be represented by our standard) + nc_var[[1]] <- to_ncvar("AutoResp", dims) + nc_var[[2]] <- to_ncvar("HeteroResp", dims) + nc_var[[3]] <- to_ncvar("GPP", dims) + nc_var[[4]] <- to_ncvar("NEE", dims) + nc_var[[5]] <- to_ncvar("NPP", dims) + nc_var[[6]] <- to_ncvar("leaf_litter_carbon_flux", dims) #was LeafLitter + nc_var[[7]] <- to_ncvar("WoodyLitter", dims) #need to resolve standard woody litter flux + nc_var[[8]] <- to_ncvar("subsurface_litter_carbon_flux", dims) #was RootLitter + nc_var[[9]] <- to_ncvar("leaf_carbon_content", dims) #was LeafBiomass + nc_var[[10]] <- to_ncvar("wood_carbon_content", dims) #was WoodBiomass + nc_var[[11]] <- to_ncvar("root_carbon_content", dims) #was RootBiomass + nc_var[[12]] <- to_ncvar("litter_carbon_content", dims) #was LitterBiomass + nc_var[[13]] <- to_ncvar("soil_carbon_content", dims) #was SoilC; SOM pool technically includes woody debris (can't be represented by our standard) - nc_var[[14]] <- mstmipvar("TotalResp", lat, lon, t, NA) - nc_var[[15]] <- mstmipvar("TotLivBiom", lat, lon, t, NA) - nc_var[[16]] <- mstmipvar("TotSoilCarb", lat, lon, t, NA) + nc_var[[14]] <- to_ncvar("TotalResp", dims) + nc_var[[15]] <- to_ncvar("TotLivBiom", dims) + nc_var[[16]] <- to_ncvar("TotSoilCarb", dims) # ******************** Declar netCDF variables ********************# From d9a8e083c6b06915c971e848a4e34f696bc64cb7 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 13 Jul 2017 11:29:59 -0400 Subject: [PATCH 091/771] Root partitioning and IC readin redesign --- models/dalec/R/write.configs.dalec.R | 59 +++++++++++++++++++++++++--- 1 file changed, 53 insertions(+), 6 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index b4d0f51e993..621f21e8cf2 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -115,6 +115,9 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } ### INITIAL CONDITIONS + is.loaded <- function(var){ + return(all(!is.na(var) && is.numeric(var))) #check that ncvar was present (numeric) and a value was given it (not NA) + } default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC")) IC.param <- data.frame() @@ -123,16 +126,60 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { IC.nc <- try(ncdf4::nc_open(IC.path)) if(class(IC.nc) != "try-error"){ - # cf0 initial canopy foliar carbon (g/m2) + #check/load biomass netcdf variables + totBiom <- try(ncdf4::ncvar_get(IC.nc,"TotLivBiom"),silent = TRUE) leaf <- try(ncdf4::ncvar_get(IC.nc,"leaf_carbon_content"),silent = TRUE) - if (!is.na(leaf) && is.numeric(leaf)) { + AbvGrndWood <- try(ncdf4::ncvar_get(IC.nc,"AbvGrndWood"),silent = TRUE) + roots <- try(ncdf4::ncvar_get(IC.nc,"root_carbon_content"),silent = TRUE) + fine.roots <- try(ncdf4::ncvar_get(IC.nc,"fine_root_carbon_content"),silent = TRUE) + coarse.roots <- try(ncdf4::ncvar_get(IC.nc,"coarse_root_carbon_content"),silent = TRUE) + + + #check if total roots are partitioned + if(is.loaded(roots) && !is.loaded(fine.roots) || !is.loaded(coarse.roots)){ + if("rtsize" %in% names(IC.nc$dim)){ + rtsize = IC.nc$dim$rtsize$vals + if(length(rtsize) > 1 && length(rtsize) == length(roots)){ + threshold = .002 + epsilon <- .0005 + rtsize_thresh_idx = which.min(sapply(rtsize-threshold,abs)) + rtsize_thresh = rtsize[rtsize_thresh_idx] + if(abs(rtsize_thresh-threshold) > epsilon){ + PEcAn.utils::logger.error(paste("Closest rtsize to fine root threshold of", threshold, "m (", rtsize_thresh, + ") is greater than", epsilon, + "m off; fine roots can't be partitioned. Please improve rtsize dimensions or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.")) + } + else{ + fine.roots.temp <- sum(roots[1:rtsize_thresh_idx-1]) + coarse.roots.temp <- sum(roots) - fine.roots + if(fine.roots.temp > 0 && coarse.roots.temp > 0){ + fine.roots <- fine.roots.temp + coarse.roots <- coarse.roots.temp + } else{ + PEcAn.utils::logger.error("Roots could not be partitioned (fine or coarse is less than 0); please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + } + } + } else { + PEcAn.utils::logger.error("Not enough levels of rtsize to partition roots; please provide finer resolution for root_carbon_content or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + } + } else{ + PEcAn.utils::logger.error("Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + } + } + + + # cf0 initial canopy foliar carbon (g/m2) + if (is.loaded(leaf)) { param[["cf0"]] <- leaf } + else if(is.loaded(totBiom) && is.loaded(AbvGrndWood) && + is.loaded(fine.roots) && is.loaded(coarse.roots)){ + leaf <- totBiom - AbvGrndWood - fine.roots - coarse.roots + } + } # cw0 initial pool of woody carbon (g/m2) - AbvGrndWood <- try(ncdf4::ncvar_get(IC.nc,"AbvGrndWood"),silent = TRUE) - if (!is.na(AbvGrndWood) && is.numeric(AbvGrndWood)) { - roots <- try(ncdf4::ncvar_get(IC.nc,"root_carbon_content"),silent = TRUE) - if(!is.na(roots) && is.numeric(roots)){ + if (is.loaded(AbvGrndWood)) { + if(is.loaded(fine.roots) && is.loaded(coarse.roots)){ #wood <- partitioned coarse roots + abvgroundwood } else{ From 8d0e35e7ba167a62e857762c62c28909eedf608c Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 13 Jul 2017 12:43:12 -0400 Subject: [PATCH 092/771] First complete draft of IC readin --- models/dalec/R/write.configs.dalec.R | 119 ++++++++++++++++----------- 1 file changed, 73 insertions(+), 46 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 621f21e8cf2..05cfe1d1659 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -115,19 +115,19 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } ### INITIAL CONDITIONS - is.loaded <- function(var){ - return(all(!is.na(var) && is.numeric(var))) #check that ncvar was present (numeric) and a value was given it (not NA) + is.valid <- function(var){ + return(all(!is.na(var) && is.numeric(var) && var >= 0)) #check that ncvar was present (numeric) and a valid value was given it (not NA or negative) } default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC")) IC.param <- data.frame() - if (!is.null(settings$run$inputs$poolinitcond$path)) { + if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path IC.nc <- try(ncdf4::nc_open(IC.path)) if(class(IC.nc) != "try-error"){ #check/load biomass netcdf variables - totBiom <- try(ncdf4::ncvar_get(IC.nc,"TotLivBiom"),silent = TRUE) + TotLivBiom <- try(ncdf4::ncvar_get(IC.nc,"TotLivBiom"),silent = TRUE) leaf <- try(ncdf4::ncvar_get(IC.nc,"leaf_carbon_content"),silent = TRUE) AbvGrndWood <- try(ncdf4::ncvar_get(IC.nc,"AbvGrndWood"),silent = TRUE) roots <- try(ncdf4::ncvar_get(IC.nc,"root_carbon_content"),silent = TRUE) @@ -135,15 +135,16 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { coarse.roots <- try(ncdf4::ncvar_get(IC.nc,"coarse_root_carbon_content"),silent = TRUE) - #check if total roots are partitioned - if(is.loaded(roots) && !is.loaded(fine.roots) || !is.loaded(coarse.roots)){ + #check if total roots are partitioned (pull out as a function for readability) + #note: if fine and coarse roots are both loaded, they will override root_carbon_content + if(is.valid(roots) && (!is.valid(fine.roots) || !is.valid(coarse.roots)){ if("rtsize" %in% names(IC.nc$dim)){ - rtsize = IC.nc$dim$rtsize$vals + rtsize <- IC.nc$dim$rtsize$vals if(length(rtsize) > 1 && length(rtsize) == length(roots)){ - threshold = .002 + threshold <- .002 epsilon <- .0005 - rtsize_thresh_idx = which.min(sapply(rtsize-threshold,abs)) - rtsize_thresh = rtsize[rtsize_thresh_idx] + rtsize_thresh_idx <- which.min(sapply(rtsize-threshold,abs)) + rtsize_thresh <- rtsize[rtsize_thresh_idx] if(abs(rtsize_thresh-threshold) > epsilon){ PEcAn.utils::logger.error(paste("Closest rtsize to fine root threshold of", threshold, "m (", rtsize_thresh, ") is greater than", epsilon, @@ -152,9 +153,10 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { else{ fine.roots.temp <- sum(roots[1:rtsize_thresh_idx-1]) coarse.roots.temp <- sum(roots) - fine.roots - if(fine.roots.temp > 0 && coarse.roots.temp > 0){ + if(fine.roots.temp >= 0 && coarse.roots.temp >= 0){ fine.roots <- fine.roots.temp coarse.roots <- coarse.roots.temp + PEcAn.utils::logger.info("Using partitioned root values", fine.roots, "for fine and", coarse.roots, "for coarse.") } else{ PEcAn.utils::logger.error("Roots could not be partitioned (fine or coarse is less than 0); please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") } @@ -167,51 +169,76 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } } - + ###write initial conditions from netcdf # cf0 initial canopy foliar carbon (g/m2) - if (is.loaded(leaf)) { - param[["cf0"]] <- leaf - } - else if(is.loaded(totBiom) && is.loaded(AbvGrndWood) && - is.loaded(fine.roots) && is.loaded(coarse.roots)){ - leaf <- totBiom - AbvGrndWood - fine.roots - coarse.roots - } + if (is.valid(leaf)) { + param[["cf0"]] <- leaf * 1000 #standard kg C m-2 + } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && + is.valid(fine.roots) && is.valid(coarse.roots)){ + leaf <- (TotLivBiom - AbvGrndWood - fine.roots - coarse.roots) * 1000 #standard kg C m-2 + if(leaf >= 0){ + param[["cf0"]] <- leaf + } else{ + PEcAn.utils::logger.error("TotLivBiom is less than sum of AbvGrndWood and roots; using default for leaf biomass") + } } + # cw0 initial pool of woody carbon (g/m2) - if (is.loaded(AbvGrndWood)) { - if(is.loaded(fine.roots) && is.loaded(coarse.roots)){ - #wood <- partitioned coarse roots + abvgroundwood + if (is.valid(AbvGrndWood)) { + if(is.valid(coarse.roots)){ + param[["cw0"]] <- (AbvGrndWood + coarse.roots) * 1000 #standard kg C m-2 } - else{ - #wood <- (roots-default.fine) + abvgroundwood + else if (is.valid(TotLivBiom) && is.valid(leaf) && is.valid(fine.roots)){ + wood <- (TotLivBiom - leaf - fine.roots) * 1000 #standard kg C m-2 + if (wood >= 0){ + param[["cw0"]] <- wood + } else{ + PEcAn.utils::logger.error("TotLivBiom is less than sum of leaf and fine roots; using default for woody biomass") + } + } else{ + PEcAn.utils::logger.error("write.configs.DALEC IC can't calculate total woody biomass with only AbvGrndWood; using defaults. Please provide coarse_root_carbon_content OR root_carbon_content with rtsize dimensions OR leaf_carbon_content, fine_root_carbon_content, and TotLivBiom in netcdf") + } + } else if (is.valid(TotLivBiom) && is.valid(leaf) && is.valid(fine.roots)){ + wood <- (TotLivBiom - leaf - fine.roots) * 1000 #standard kg C m-2 + if (wood >= 0){ + param[["cw0"]] <- wood + }else{ + PEcAn.utils::logger.error("TotLivBiom is less than sum of leaf and fine roots; using default for woody biomass") } - param[["cw0"]] <- wood + } else{ + #use default wood } + # cr0 initial pool of fine root carbon (g/m2) - roots <- try(ncdf4::ncvar_get(IC.nc,"root_carbon_content"),silent = TRUE) - if (!is.na(roots) && is.numeric(roots)) { - #partition fine roots - param[["cr0"]] <- roots - } + if (is.valid(fine.roots)) { + param[["cr0"]] <- fine.roots * 1000 #standard kg C m-2 + } + # cl0 initial pool of litter carbon (g/m2) - litter <- try(ncdf4::ncvar_get(IC.nc,"litter_carbon_content"),silent = TRUE) - if (!is.na(litter) && is.numeric(litter)) { - param[["cl0"]] <- litter - } + litter <- try(ncdf4::ncvar_get(IC.nc,"litter_carbon_content"),silent = TRUE) + if (is.valid(litter)) { + param[["cl0"]] <- litter * 1000 #standard kg C m-2 + } + # cs0 initial pool of soil organic matter and woody debris carbon (g/m2) - soil <- try(ncdf4::ncvar_get(IC.nc,"soil_organic_carbon_content"),silent = TRUE) - if(!is.numeric(soil)){ - soil <- try(ncdf4::ncvar_get(IC.nc,"soil_carbon_content"),silent = TRUE) - if(is.numeric(soil)){ - wood <- try(ncdf4::ncvar_get(IC.nc,"wood_debris_carbon_content"),silent = TRUE) - if(is.numeric(wood)){ - soil_and_wood <- soil + sum(wood) - param[["cs0"]] <- soil_and_wood - } - } + soil <- try(ncdf4::ncvar_get(IC.nc,"soil_organic_carbon_content"),silent = TRUE) + wood.debris <- try(ncdf4::ncvar_get(IC.nc,"wood_debris_carbon_content"),silent = TRUE) + if(is.valid(soil) && is.valid(wood.debris)){ + param[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #standard kg C m-2 + } else if(!is.valid(soil) && is.valid(wood.debris)){ + soil <- try(ncdf4::ncvar_get(IC.nc,"soil_carbon_content"),silent = TRUE) + if(is.valid(soil)){ + param[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #standard kg C m-2 + } else{ + PEcAn.utils::logger.error("write.configs.DALEC IC can't calculate soil matter pool without soil carbon; using default. Please provide soil_organic_carbon_content in netcdf.") } - } - else{ + } else if(is.valid(soil) && !is.valid(wood.debris)){ + PEcAn.utils::logger.error("write.configs.DALEC IC can't calculate soil matter pool without wood debris; using default. Please provide wood_debris_carbon_content in netcdf.") + } else{ + #use default soil pool + } + + } else{ PEcAn.utils::logger.error("Bad initial conditions filepath; kept defaults") } } From 7001fb3ae56b1291219b5ce077beb90780a7b7ba Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 13 Jul 2017 12:55:18 -0400 Subject: [PATCH 093/771] Change some names --- models/dalec/R/write.configs.dalec.R | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 05cfe1d1659..b2a5dbea03e 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -120,7 +120,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC")) - IC.param <- data.frame() + IC.params <- data.frame() if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path IC.nc <- try(ncdf4::nc_open(IC.path)) @@ -172,12 +172,12 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { ###write initial conditions from netcdf # cf0 initial canopy foliar carbon (g/m2) if (is.valid(leaf)) { - param[["cf0"]] <- leaf * 1000 #standard kg C m-2 + IC.params[["cf0"]] <- leaf * 1000 #standard kg C m-2 } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && is.valid(fine.roots) && is.valid(coarse.roots)){ leaf <- (TotLivBiom - AbvGrndWood - fine.roots - coarse.roots) * 1000 #standard kg C m-2 if(leaf >= 0){ - param[["cf0"]] <- leaf + IC.params[["cf0"]] <- leaf } else{ PEcAn.utils::logger.error("TotLivBiom is less than sum of AbvGrndWood and roots; using default for leaf biomass") } @@ -186,12 +186,12 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { # cw0 initial pool of woody carbon (g/m2) if (is.valid(AbvGrndWood)) { if(is.valid(coarse.roots)){ - param[["cw0"]] <- (AbvGrndWood + coarse.roots) * 1000 #standard kg C m-2 + IC.params[["cw0"]] <- (AbvGrndWood + coarse.roots) * 1000 #standard kg C m-2 } else if (is.valid(TotLivBiom) && is.valid(leaf) && is.valid(fine.roots)){ wood <- (TotLivBiom - leaf - fine.roots) * 1000 #standard kg C m-2 if (wood >= 0){ - param[["cw0"]] <- wood + IC.params[["cw0"]] <- wood } else{ PEcAn.utils::logger.error("TotLivBiom is less than sum of leaf and fine roots; using default for woody biomass") } @@ -201,7 +201,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } else if (is.valid(TotLivBiom) && is.valid(leaf) && is.valid(fine.roots)){ wood <- (TotLivBiom - leaf - fine.roots) * 1000 #standard kg C m-2 if (wood >= 0){ - param[["cw0"]] <- wood + IC.params[["cw0"]] <- wood }else{ PEcAn.utils::logger.error("TotLivBiom is less than sum of leaf and fine roots; using default for woody biomass") } @@ -211,24 +211,24 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { # cr0 initial pool of fine root carbon (g/m2) if (is.valid(fine.roots)) { - param[["cr0"]] <- fine.roots * 1000 #standard kg C m-2 + IC.params[["cr0"]] <- fine.roots * 1000 #standard kg C m-2 } # cl0 initial pool of litter carbon (g/m2) litter <- try(ncdf4::ncvar_get(IC.nc,"litter_carbon_content"),silent = TRUE) if (is.valid(litter)) { - param[["cl0"]] <- litter * 1000 #standard kg C m-2 + IC.params[["cl0"]] <- litter * 1000 #standard kg C m-2 } # cs0 initial pool of soil organic matter and woody debris carbon (g/m2) soil <- try(ncdf4::ncvar_get(IC.nc,"soil_organic_carbon_content"),silent = TRUE) wood.debris <- try(ncdf4::ncvar_get(IC.nc,"wood_debris_carbon_content"),silent = TRUE) if(is.valid(soil) && is.valid(wood.debris)){ - param[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #standard kg C m-2 + IC.params[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #standard kg C m-2 } else if(!is.valid(soil) && is.valid(wood.debris)){ soil <- try(ncdf4::ncvar_get(IC.nc,"soil_carbon_content"),silent = TRUE) if(is.valid(soil)){ - param[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #standard kg C m-2 + IC.params[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #standard kg C m-2 } else{ PEcAn.utils::logger.error("write.configs.DALEC IC can't calculate soil matter pool without soil carbon; using default. Please provide soil_organic_carbon_content in netcdf.") } @@ -238,6 +238,12 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { #use default soil pool } + ###Write to command line file + PEcAn.utils::logger.info(names(paste("Adding IC tags to file:", IC.params)) + for (i in seq_along(IC.params)) { + cmdFlags <- paste0(cmdFlags, " -", names(IC.params)[i], " ", IC.params[[i]]) + } + } else{ PEcAn.utils::logger.error("Bad initial conditions filepath; kept defaults") } From a0ee25483196ee010a852d81e1c3bf0aa6b1f4af Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 13 Jul 2017 13:00:27 -0400 Subject: [PATCH 094/771] Have partitioned roots override fine/coarse --- models/dalec/R/write.configs.dalec.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index b2a5dbea03e..7c153c23635 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -136,8 +136,8 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { #check if total roots are partitioned (pull out as a function for readability) - #note: if fine and coarse roots are both loaded, they will override root_carbon_content - if(is.valid(roots) && (!is.valid(fine.roots) || !is.valid(coarse.roots)){ + #note: if roots are patritionable, they will override fine_ and/or coarse_root_carbon_content if loaded + if(is.valid(roots)){ if("rtsize" %in% names(IC.nc$dim)){ rtsize <- IC.nc$dim$rtsize$vals if(length(rtsize) > 1 && length(rtsize) == length(roots)){ From 8aaa7d0eb78a9519d401e787788fad7c682168bb Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 13 Jul 2017 13:38:26 -0400 Subject: [PATCH 095/771] Make partition_roots a function --- models/dalec/R/write.configs.dalec.R | 86 +++++++++++++++------------- 1 file changed, 46 insertions(+), 40 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 7c153c23635..0838d006605 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -71,17 +71,40 @@ convert.samples.DALEC <- function(trait.samples) { names(trait.samples)[which(names(trait.samples) == "som_respiration_rate")] <- "t9" } - ### INITIAL CONDITIONS - - # cf0 initial canopy foliar carbon (g/m2) - # cw0 initial pool of woody carbon (g/m2) - # cr0 initial pool of fine root carbon (g/m2) - # cl0 initial pool of litter carbon (g/m2) - # cs0 initial pool of soil organic matter and woody debris carbon (g/m2) - return(trait.samples) } # convert.samples.DALEC +####function to split root_carbon_content into fine and coarse roots by rtsize dimension at the .002 m threshold +partition_roots <- function(roots, rtsize){ + if(length(rtsize) > 1 && length(rtsize) == length(roots)){ + threshold <- .002 + epsilon <- .0005 + rtsize_thresh_idx <- which.min(sapply(rtsize-threshold,abs)) + rtsize_thresh <- rtsize[rtsize_thresh_idx] + if(abs(rtsize_thresh-threshold) > epsilon){ + PEcAn.utils::logger.error(paste("Closest rtsize to fine root threshold of", threshold, "m (", rtsize_thresh, + ") is greater than", epsilon, + "m off; fine roots can't be partitioned. Please improve rtsize dimensions or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.")) + return(NULL) + } else{ + fine.roots.temp <- sum(roots[1:rtsize_thresh_idx-1]) + coarse.roots.temp <- sum(roots) - fine.roots.temp + if(fine.roots.temp >= 0 && coarse.roots.temp >= 0){ + fine.roots <- fine.roots.temp + coarse.roots <- coarse.roots.temp + PEcAn.utils::logger.info("Using partitioned root values", fine.roots, "for fine and", coarse.roots, "for coarse.") + return(list(fine.roots = fine.roots, coarse.roots = coarse.roots)) + } else{ + PEcAn.utils::logger.error("Roots could not be partitioned (fine or coarse is less than 0); please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + return(NULL) + } + } + } else { + PEcAn.utils::logger.error("Not enough levels of rtsize associated with root_carbon_content to partition roots; please provide finer resolution for root_carbon_content or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + return(NULL) + } +} + #--------------------------------------------------------------------------------------------------# ##' Writes a configuration files for your model #--------------------------------------------------------------------------------------------------# @@ -115,11 +138,13 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } ### INITIAL CONDITIONS + + #function to check that ncvar was present (numeric) and a valid value was given it (not NA or negative) is.valid <- function(var){ - return(all(!is.na(var) && is.numeric(var) && var >= 0)) #check that ncvar was present (numeric) and a valid value was given it (not NA or negative) + return(all(is.numeric(var) && !is.na(var) && var >= 0)) } - default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC")) + #default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC")) IC.params <- data.frame() if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path @@ -140,36 +165,21 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { if(is.valid(roots)){ if("rtsize" %in% names(IC.nc$dim)){ rtsize <- IC.nc$dim$rtsize$vals - if(length(rtsize) > 1 && length(rtsize) == length(roots)){ - threshold <- .002 - epsilon <- .0005 - rtsize_thresh_idx <- which.min(sapply(rtsize-threshold,abs)) - rtsize_thresh <- rtsize[rtsize_thresh_idx] - if(abs(rtsize_thresh-threshold) > epsilon){ - PEcAn.utils::logger.error(paste("Closest rtsize to fine root threshold of", threshold, "m (", rtsize_thresh, - ") is greater than", epsilon, - "m off; fine roots can't be partitioned. Please improve rtsize dimensions or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.")) - } - else{ - fine.roots.temp <- sum(roots[1:rtsize_thresh_idx-1]) - coarse.roots.temp <- sum(roots) - fine.roots - if(fine.roots.temp >= 0 && coarse.roots.temp >= 0){ - fine.roots <- fine.roots.temp - coarse.roots <- coarse.roots.temp - PEcAn.utils::logger.info("Using partitioned root values", fine.roots, "for fine and", coarse.roots, "for coarse.") - } else{ - PEcAn.utils::logger.error("Roots could not be partitioned (fine or coarse is less than 0); please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") - } - } - } else { - PEcAn.utils::logger.error("Not enough levels of rtsize to partition roots; please provide finer resolution for root_carbon_content or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + part_roots <- partition_roots(roots, rtsize) + if(!is.null(part_roots)){ + fine.roots <- part_roots$fine.roots + coarse.roots <- part_roots$coarse.roots + } else{ + #couldn't partition roots; error messages handled by function } } else{ PEcAn.utils::logger.error("Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") } + } else{ + #proceed without error message } - ###write initial conditions from netcdf + ###write initial conditions from netcdf (wherever valid input isn't available, DALEC default remains) # cf0 initial canopy foliar carbon (g/m2) if (is.valid(leaf)) { IC.params[["cf0"]] <- leaf * 1000 #standard kg C m-2 @@ -205,9 +215,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { }else{ PEcAn.utils::logger.error("TotLivBiom is less than sum of leaf and fine roots; using default for woody biomass") } - } else{ - #use default wood - } + } # cr0 initial pool of fine root carbon (g/m2) if (is.valid(fine.roots)) { @@ -234,9 +242,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } } else if(is.valid(soil) && !is.valid(wood.debris)){ PEcAn.utils::logger.error("write.configs.DALEC IC can't calculate soil matter pool without wood debris; using default. Please provide wood_debris_carbon_content in netcdf.") - } else{ - #use default soil pool - } + } ###Write to command line file PEcAn.utils::logger.info(names(paste("Adding IC tags to file:", IC.params)) From d9f2b19e7d6d73c51652556c9776aceebf19be93 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 13 Jul 2017 14:24:30 -0400 Subject: [PATCH 096/771] Add some notes --- models/dalec/R/write.configs.dalec.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 0838d006605..82eef085852 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -159,8 +159,11 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { fine.roots <- try(ncdf4::ncvar_get(IC.nc,"fine_root_carbon_content"),silent = TRUE) coarse.roots <- try(ncdf4::ncvar_get(IC.nc,"coarse_root_carbon_content"),silent = TRUE) + if(!all(sapply(c(TotLivBiom,leaf,AbvGrndWood,roots,fine.roots,coarse.roots),is.numeric))){ + PEcAn.utils::logger.info("Any missing vars will be calculated from those provided or replaced by DALEC's defaults") + } - #check if total roots are partitioned (pull out as a function for readability) + #check if total roots are partitionable #note: if roots are patritionable, they will override fine_ and/or coarse_root_carbon_content if loaded if(is.valid(roots)){ if("rtsize" %in% names(IC.nc$dim)){ @@ -179,7 +182,8 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { #proceed without error message } - ###write initial conditions from netcdf (wherever valid input isn't available, DALEC default remains) + ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) + # cf0 initial canopy foliar carbon (g/m2) if (is.valid(leaf)) { IC.params[["cf0"]] <- leaf * 1000 #standard kg C m-2 From 10a9b0707d800ef00ef4a076c5b73b3f387210a8 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 13 Jul 2017 14:41:49 -0400 Subject: [PATCH 097/771] Cleanup --- models/dalec/R/write.configs.dalec.R | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 82eef085852..feebd699148 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -145,7 +145,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } #default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC")) - IC.params <- data.frame() + IC.params <- list() if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path IC.nc <- try(ncdf4::nc_open(IC.path)) @@ -160,13 +160,14 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { coarse.roots <- try(ncdf4::ncvar_get(IC.nc,"coarse_root_carbon_content"),silent = TRUE) if(!all(sapply(c(TotLivBiom,leaf,AbvGrndWood,roots,fine.roots,coarse.roots),is.numeric))){ - PEcAn.utils::logger.info("Any missing vars will be calculated from those provided or replaced by DALEC's defaults") + PEcAn.utils::logger.info("DALEC IC: Any missing vars will be calculated from those provided or replaced by DALEC's defaults") } #check if total roots are partitionable #note: if roots are patritionable, they will override fine_ and/or coarse_root_carbon_content if loaded if(is.valid(roots)){ if("rtsize" %in% names(IC.nc$dim)){ + PEcAn.utils::logger.info("DALEC IC: Attempting to partition root_carbon_content") rtsize <- IC.nc$dim$rtsize$vals part_roots <- partition_roots(roots, rtsize) if(!is.null(part_roots)){ @@ -176,7 +177,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { #couldn't partition roots; error messages handled by function } } else{ - PEcAn.utils::logger.error("Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + PEcAn.utils::logger.error("DALEC IC: Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") } } else{ #proceed without error message @@ -224,8 +225,17 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { # cr0 initial pool of fine root carbon (g/m2) if (is.valid(fine.roots)) { IC.params[["cr0"]] <- fine.roots * 1000 #standard kg C m-2 + } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && + is.valid(leaf) && is.valid(coarse.roots)){ + fine.roots <- (TotLivBiom - AbvGrndWood - leaf - coarse.roots) * 1000 #standard kg C m-2 + if(leaf >= 0){ + IC.params[["cr0"]] <- fine.roots + } else{ + PEcAn.utils::logger.error("TotLivBiom is less than sum of AbvGrndWood, coarse roots, and leaf; using default for fine.roots biomass") + } } + ###non-living variables # cl0 initial pool of litter carbon (g/m2) litter <- try(ncdf4::ncvar_get(IC.nc,"litter_carbon_content"),silent = TRUE) if (is.valid(litter)) { From e9979386b63699070f4f2b8906db7006756b13a8 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 13 Jul 2017 16:34:07 -0400 Subject: [PATCH 098/771] More cleanup --- models/dalec/R/write.configs.dalec.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index feebd699148..258ceb0b7c8 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -259,10 +259,10 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } ###Write to command line file - PEcAn.utils::logger.info(names(paste("Adding IC tags to file:", IC.params)) for (i in seq_along(IC.params)) { cmdFlags <- paste0(cmdFlags, " -", names(IC.params)[i], " ", IC.params[[i]]) } + PEcAn.utils::logger.info(paste("All command flags:",cmdFlags)) } else{ PEcAn.utils::logger.error("Bad initial conditions filepath; kept defaults") From 8342eab228594189b49450f6b00411a5aed24d69 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 13 Jul 2017 16:43:02 -0400 Subject: [PATCH 099/771] Change list2netcdf dim check --- modules/data.land/R/pool_ic_list2netcdf.R | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/modules/data.land/R/pool_ic_list2netcdf.R b/modules/data.land/R/pool_ic_list2netcdf.R index 1650167e242..9539e4f231e 100644 --- a/modules/data.land/R/pool_ic_list2netcdf.R +++ b/modules/data.land/R/pool_ic_list2netcdf.R @@ -9,13 +9,17 @@ ##' @author Anne Thomas pool_ic_list2netcdf <- function(input, outdir, siteid){ - if(is.null(input$dims) || length(input$dims) == 0){ - PEcAn.utils::logger.severe("Please provide non-empty 'dims' list in input") - } if(is.null(input$vals) || length(input$vals) == 0){ PEcAn.utils::logger.severe("Please provide 'vals' list in input with variable names assigned to values") } + if(is.null(input$dims) || length(input$dims) == 0){ + if (any(sapply(input$vals,length) > 1)){ + PEcAn.utils::logger.severe("A variable has length > 1; please provide non-empty 'dims' list in input") + } + } + #to do: check + dims <- list() for(dimname in names(input$dims)){ vals <- input$dims[[which(names(input$dims) == dimname)]] From 4e37a9b2cc5ab77e3c90abff047a4e402f254f11 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Fri, 14 Jul 2017 06:53:10 -0400 Subject: [PATCH 100/771] Biocro check cleanup (#1540) * RNCEP no longer used (#1309) * Remove demo See vignettes/ for a more complete equivalent --- models/biocro/BioCro_demo.Rmd | 25 ------------------------- models/biocro/DESCRIPTION | 3 +-- 2 files changed, 1 insertion(+), 27 deletions(-) delete mode 100644 models/biocro/BioCro_demo.Rmd diff --git a/models/biocro/BioCro_demo.Rmd b/models/biocro/BioCro_demo.Rmd deleted file mode 100644 index 47b64b94b90..00000000000 --- a/models/biocro/BioCro_demo.Rmd +++ /dev/null @@ -1,25 +0,0 @@ - - -```{r} -library(PEcAn.all) -logger.setQuitOnSevere(FALSE) - -settings <- read.settings("models/biocro/inst/extdata/misp.xml") - -#---------------- Run PEcAn workflow. -------------------------------------------------------------# -# Query the trait database for data and priors -settings$pfts <- get.trait.data(settings$pfts, settings$model$type, settings$run$dbfiles, settings$database$bety, settings$meta.analysis$update) - -# Run the PEcAn meta.analysis -run.meta.analysis(settings$pfts, settings$meta.analysis$iter, settings$meta.analysis$threshold, settings$run$dbfiles, settings$database$bety) - -run.write.configs(settings = settings, write = FALSE) # Calls model specific write.configs e.g. write.config.ed.R -## load met data -start.model.runs(settings = settings, write = FALSE) # Start ecosystem model runs - -get.results(settings) # Get results of model runs - -run.sensitivity.analysis() # Run sensitivity analysis and variance decomposition on model output - -run.ensemble.analysis() # Run ensemble analysis on model output. -``` diff --git a/models/biocro/DESCRIPTION b/models/biocro/DESCRIPTION index a6fd881a75d..93d8aef5dc6 100644 --- a/models/biocro/DESCRIPTION +++ b/models/biocro/DESCRIPTION @@ -20,8 +20,7 @@ Imports: Suggests: BioCro, testthat (>= 1.0.2), - RPostgreSQL, - RNCEP + RPostgreSQL Remotes: github::ebimodeling/biocro License: FreeBSD + file LICENSE From 32243d71bae46bb1bf29295078474440abe48d01 Mon Sep 17 00:00:00 2001 From: annethomas Date: Fri, 14 Jul 2017 10:17:10 -0400 Subject: [PATCH 101/771] Tiny notes changes --- models/dalec/R/write.configs.dalec.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 258ceb0b7c8..141355ddf4c 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -74,7 +74,7 @@ convert.samples.DALEC <- function(trait.samples) { return(trait.samples) } # convert.samples.DALEC -####function to split root_carbon_content into fine and coarse roots by rtsize dimension at the .002 m threshold +####partition_roots: function to split root_carbon_content into fine and coarse roots by rtsize dimension at the .002 m threshold partition_roots <- function(roots, rtsize){ if(length(rtsize) > 1 && length(rtsize) == length(roots)){ threshold <- .002 @@ -139,7 +139,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { ### INITIAL CONDITIONS - #function to check that ncvar was present (numeric) and a valid value was given it (not NA or negative) + #function to check that ncvar was loaded (numeric) and has a valid value (not NA or negative) is.valid <- function(var){ return(all(is.numeric(var) && !is.na(var) && var >= 0)) } From a1cbc1c6a1d4485560899db65df2e478284ec9bf Mon Sep 17 00:00:00 2001 From: annethomas Date: Fri, 14 Jul 2017 16:56:49 -0400 Subject: [PATCH 102/771] Add LAI calcuations --- models/dalec/R/write.configs.dalec.R | 24 +++++++++++++++++++----- models/dalec/inst/default_param.dalec | 1 + 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 141355ddf4c..768257aa52a 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -15,13 +15,13 @@ PREFIX_XML <- "\n" convert.samples.DALEC <- function(trait.samples) { DEFAULT.LEAF.C <- 0.48 - ## convert SLA from m2 / kg leaf to m2 / kg C + ## convert SLA from m2 / kg leaf to m2 / g C if ("SLA" %in% names(trait.samples)) { trait.samples[["SLA"]] <- trait.samples[["SLA"]]/DEFAULT.LEAF.C/1000 } - # t1 rate variable controling decomposition from litter to soil organinc matter [day-1, ref T + # t1 rate variable controlling decomposition from litter to soil organinc matter [day-1, ref T # 10C] if ("litter_decomposition_to_SOM" %in% names(trait.samples)) { names(trait.samples)[which(names(trait.samples) == "litter_decomposition_to_SOM")] <- "t1" @@ -144,9 +144,10 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { return(all(is.numeric(var) && !is.na(var) && var >= 0)) } - #default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC")) + default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC"), header = TRUE) IC.params <- list() - if (!is.null(settings$run$inputs$poolinitcond$path)) { + + if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path IC.nc <- try(ncdf4::nc_open(IC.path)) @@ -154,12 +155,13 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { #check/load biomass netcdf variables TotLivBiom <- try(ncdf4::ncvar_get(IC.nc,"TotLivBiom"),silent = TRUE) leaf <- try(ncdf4::ncvar_get(IC.nc,"leaf_carbon_content"),silent = TRUE) + LAI <- try(ncdf4::ncvar_get(IC.nc,"LAI"),silent = TRUE) AbvGrndWood <- try(ncdf4::ncvar_get(IC.nc,"AbvGrndWood"),silent = TRUE) roots <- try(ncdf4::ncvar_get(IC.nc,"root_carbon_content"),silent = TRUE) fine.roots <- try(ncdf4::ncvar_get(IC.nc,"fine_root_carbon_content"),silent = TRUE) coarse.roots <- try(ncdf4::ncvar_get(IC.nc,"coarse_root_carbon_content"),silent = TRUE) - if(!all(sapply(c(TotLivBiom,leaf,AbvGrndWood,roots,fine.roots,coarse.roots),is.numeric))){ + if(!all(sapply(c(TotLivBiom,leaf,LAI,AbvGrndWood,roots,fine.roots,coarse.roots),is.numeric))){ PEcAn.utils::logger.info("DALEC IC: Any missing vars will be calculated from those provided or replaced by DALEC's defaults") } @@ -183,11 +185,23 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { #proceed without error message } + ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) # cf0 initial canopy foliar carbon (g/m2) if (is.valid(leaf)) { IC.params[["cf0"]] <- leaf * 1000 #standard kg C m-2 + } else if(is.valid(LAI)){ + if("SLA" %in% names(params)){ + LMA <- 1/params[1,"SLA"] #SLA converted to m2 kgC-1 in convert.samples + leaf <- LAI * LMA + IC.params[["cf0"]] <- leaf + } else{ + SLA = default.param[which(default.param$cmdFlag == "SLA"),"val"] + LMA <- 1/SLA + leaf <- LAI * LMA + IC.params[["cf0"]] <- leaf + } } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && is.valid(fine.roots) && is.valid(coarse.roots)){ leaf <- (TotLivBiom - AbvGrndWood - fine.roots - coarse.roots) * 1000 #standard kg C m-2 diff --git a/models/dalec/inst/default_param.dalec b/models/dalec/inst/default_param.dalec index 38f238d4ac5..fd5be66a333 100644 --- a/models/dalec/inst/default_param.dalec +++ b/models/dalec/inst/default_param.dalec @@ -8,6 +8,7 @@ t6 2.06E-06 #rate of wood loss t7 2.48E-03 #rate of root loss t8 2.28E-02 #rate of respiration from litter t9 2.65E-06 #rate of respiration from litter SOM +SLA 9.01E-03 #specific leaf area 1.0/111.0 cf0 57.7049 #initial canopy foliar carbon (g/m2) cw0 769.863 #initial pool of woody carbon (g/m2) cr0 101.955 #initial pool of fine root carbon (g/m2) From d1bc58de6e86155df78c8ff061a2b95ced56a883 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 17:04:21 +0530 Subject: [PATCH 103/771] Added files to display the input files for the variables in the config.php --- web/setups/core.php | 45 +++++++++++++++++++++++++++++++++++++++++++++ web/setups/edit.php | 42 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 87 insertions(+) create mode 100644 web/setups/core.php create mode 100644 web/setups/edit.php diff --git a/web/setups/core.php b/web/setups/core.php new file mode 100644 index 00000000000..07bd74b3d24 --- /dev/null +++ b/web/setups/core.php @@ -0,0 +1,45 @@ + diff --git a/web/setups/edit.php b/web/setups/edit.php new file mode 100644 index 00000000000..b5734e28fbe --- /dev/null +++ b/web/setups/edit.php @@ -0,0 +1,42 @@ + +
"> +

Configuration details

+"; + if(preg_match($pattern,$line)){ + //spliting variable and values so can used variable as the input field names + $temp = preg_split('/=/',$line); + $inputname = preg_split('/\$/',$temp[0]); + //var_dump($inputname); + // HTML input code for field input; + ?> + + +
+ "; + } +} +?> + +
+
+ From dcf539289760f3c72a70df10ae142f12f91cd4a4 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 17:09:40 +0530 Subject: [PATCH 104/771] Added a simple template to be used in all the config pages --- web/setups/page.template.php | 58 ++++++++++++++++++++++++++++++ web/setups/pagefooter.template.php | 19 ++++++++++ 2 files changed, 77 insertions(+) create mode 100644 web/setups/page.template.php create mode 100644 web/setups/pagefooter.template.php diff --git a/web/setups/page.template.php b/web/setups/page.template.php new file mode 100644 index 00000000000..e0b390ce76e --- /dev/null +++ b/web/setups/page.template.php @@ -0,0 +1,58 @@ + + + + +PEcAn + + + + + + + + +
+
+
+
+
+

Introduction

+

On this page you will find the required fields to setup the particular configurations or edit it.

+ +
+
+

+ Documentation +
+ Chat Room +
+ Bug Report +

+
+
diff --git a/web/setups/pagefooter.template.php b/web/setups/pagefooter.template.php new file mode 100644 index 00000000000..ff5a4559465 --- /dev/null +++ b/web/setups/pagefooter.template.php @@ -0,0 +1,19 @@ + + +
+ +
+ + From 2cb6dd24d223e873050c346dc3b826d3c5d7c404 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 17:12:47 +0530 Subject: [PATCH 105/771] redirection added if the config.php doesn't exist --- web/01-introduction.php | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/web/01-introduction.php b/web/01-introduction.php index c0e54835140..6b2d6002627 100644 --- a/web/01-introduction.php +++ b/web/01-introduction.php @@ -2,12 +2,18 @@ /** * Copyright (c) 2012 University of Illinois, NCSA. * All rights reserved. This program and the accompanying materials - * are made available under the terms of the + * are made available under the terms of the * University of Illinois/NCSA Open Source License * which accompanies this distribution, and is available at * http://opensource.ncsa.illinois.edu/license.html */ +// Check for config.php if doesn't exits then redirect to the setup page +if (!file_exists('config.php')) +{ + header('/setups/edit.php?key=all'); +} + // Check login require("common.php"); @@ -40,7 +46,7 @@ function validate() { $("#error").html(""); } - + function prevStep() { $("#formprev").submit(); } @@ -71,10 +77,10 @@ function nextStep() {   - +
- +

Documentation
@@ -89,7 +95,7 @@ function nextStep() { PEcAn worklflow. You will be able to always go back to a previous step to change inputs. However once the model is running it will continue to run until it finishes. You will - be able to use the history button to jump to existing + be able to use the history button to jump to existing executions of PEcAn.

The following webpages will help to setup the PEcAn workflow. You will be asked the following questions:

@@ -104,7 +110,7 @@ function nextStep() { PEcAn will execute the workflow.
  • Results After execution of the PEcAn workflow you will be presented with a page showing the results of the - PEcAn workflow.
  • + PEcAn workflow. From 44807d4050648393b45e21cbcae82fcb8bbc9e3b Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 19:46:38 +0530 Subject: [PATCH 106/771] Updated Documentation for Dockers --- .../basic_users_guide/Getting-started.Rmd | 38 +++++++++++++------ web/common.php | 17 +++++++-- 2 files changed, 40 insertions(+), 15 deletions(-) diff --git a/book_source/basic_users_guide/Getting-started.Rmd b/book_source/basic_users_guide/Getting-started.Rmd index a587dd4a465..ffe866509da 100644 --- a/book_source/basic_users_guide/Getting-started.Rmd +++ b/book_source/basic_users_guide/Getting-started.Rmd @@ -12,13 +12,13 @@ There are two ways of using PEcAn, via the web interface and directly within R. ### Working with the PEcAn VM -1. PEcAn consists of a set of scripts and code that is compiled within a Linux operating system and saved in a “virtual machine (VM)”. Virtual machines allow for running consistent set-ups without worrying about differences between operating systems, library dependencies, compiling the code, etc. +1. PEcAn consists of a set of scripts and code that is compiled within a Linux operating system and saved in a “virtual machine (VM)”. Virtual machines allow for running consistent set-ups without worrying about differences between operating systems, library dependencies, compiling the code, etc. -2. To run the PEcAn VM you will need to install VirtualBox, the program that runs the virtual machine [http://www.virtualbox.org](http://www.virtualbox.org). On Windows you may see a warning about Logo testing, it is okay to ignore the warning. +2. To run the PEcAn VM you will need to install VirtualBox, the program that runs the virtual machine [http://www.virtualbox.org](http://www.virtualbox.org). On Windows you may see a warning about Logo testing, it is okay to ignore the warning. 3. After you have Virtual Box installed you’ll need to download the PEcAn virtual machine: [http://opensource.ncsa.illinois.edu/projects/artifacts.php?key=PECAN](http://opensource.ncsa.illinois.edu/projects/artifacts.php?key=PECAN). The virtual machine is available under the "**Files**" header. Click the 32 or 64 bit ".ova" file and note that the download is ~5 GB so will take from several minutes to hours depending on the connection speed. -4. To open up the virtual machine you'll first want to open up VirtualBox. +4. To open up the virtual machine you'll first want to open up VirtualBox. 5. The first time you use the VM you'll want to use File → Import Appliance in VirtualBox in order to import the VM. This will create a virtual machine from the disk image. When asked about the Appliance Import Settings make sure you select "Reinitialize the MAC address of all network cards". This is not selected by default and can result in networking issues since multiple machines might claim to have the same network MAC Address. That said, users who have experienced network connection difficulties within the VM have sometimes had better luck after reinstalling without reinitializing. @@ -46,21 +46,21 @@ Login to [Amazon Web Services (AWS)](http://console.aws.amazon.com/) and select + Type “pecan” into the search window + Click on the toggle button on the left next to PEcAn1.4.6 + Click on the “Launch” button at the top -2. Choose an Instance Type +2. Choose an Instance Type + Select what type of machine you want to run. For this demo the default, t2.micro, will be adequate. Be aware that different machine types incur very different costs, from 1.3 cents/hour to over $5/hr https://aws.amazon.com/ec2/pricing/ + Select t2.micro, then click “Next: Configure Instance Details” -3. Configure Instance Details +3. Configure Instance Details + The defaults are OK. Click “Next: Add Storage” -4. Add Storage +4. Add Storage + The defaults are OK. Click “Next: Tag Instance” -5. Tag Instance +5. Tag Instance + You can name your instance if you want. Click “Next: Configure Security Group” 6. Configure Security Group + You will need to add two new rules: + Click “Add Rule” then select “HTTP” from the pull down menu. This rule allows you to access the webserver on PEcAn. + Click “Add Rule”, leave the pull down on “Custom TCP Rule”, and then change the Port Range from 0 to 8787. Set “Source” to Anywhere. This rule allows you to access RStudio Server on PEcAn. - + Click “Review and Launch” . You will then see this pop-up: - + + Click “Review and Launch” . You will then see this pop-up: + ```{r, echo=FALSE,fig.align='center'} knitr::include_graphics(rep("figures/pic2.jpg")) ``` @@ -69,7 +69,7 @@ Select the default drive volume type and click Next 7. Review and Launch + Review the settings and then click “Launch”, which will pop up a select/create Key Pair window. -8. Key Pair +8. Key Pair + Select “Create a new key pair” and give it a name. You won’t actually need this key unless you need to SSH into your PEcAn server, but AWS requires you to create one. Click on “Download Key Pair” then on “Launch Instances”. Next click on “View Instances” at the bottom of the following page. @@ -77,7 +77,7 @@ Select the default drive volume type and click Next knitr::include_graphics(rep("../figures/pic3.jpg")) ``` -9. Instances +9. Instances + You will see the status of your PEcAn VM, which will take a minute to boot up. Wait until the Instance State reads “running”. The most important piece of information here is the Public IP, which is the URL you will need in order to access your PEcAn instance from within your web browser (see Demo 1 below). + Be aware that it often takes ~1 hr for AWS instances to become fully operational, so if you get an error when you put the Public IP in you web browser, most of the time you just need to wait a bit longer. Congratulations! You just started a PEcAn server in the “cloud”! @@ -87,4 +87,20 @@ Select the default drive volume type and click Next + To TERMINATE the instance (which will DELETE your PEcAn machine), select your instance and click Actions > Instance state > Terminate. Terminated instances will not incur costs. In most cases you will also want to go to the Volumes menu and delete the storage associated with your PEcAn VM.Remember, AWS is free for one year, but will automatically charge a fee in second year if account is not cancelled. +### Working with the PEcAn Containers (Docker) + +Following are the steps to setup a Docker instance of the PEcAn. + +1. Make sure that the machine on which have docker and docker-compose installed. For instruction on how to install docker and docker-compose please visit the [official documentations](https://docs.docker.com/engine/installation/). + +2. Visit the PEcAn Project on [github](https://github.com/PecanProject/pecan/tree/develop) and clone the repository to your machine. + +3. cd to root of the repository and run `docker-compose up -d` here -d makes it run in detached mode so it won't show the log on the terminal + The above command pull the respective docker images and also create the required images. + + To access the web interface can visit :8080 + If using localmachine then can use localhost:8080 + +Only SIPNET model is included as the default package in it. + [pecan-wikipedia]: https://en.wikipedia.org/wiki/Pecan diff --git a/web/common.php b/web/common.php index 956d02e9757..c04e3c6000c 100644 --- a/web/common.php +++ b/web/common.php @@ -10,7 +10,7 @@ function get_footer() { return "The PEcAn project is supported by the National Science Foundation - (ABI #1062547, ABI #1458021, DIBBS #1261582, ARC #1023477, EF #1318164, EF #1241894, EF #1241891), NASA + (ABI #1062547, ABI #1458021, DIBBS #1261582, ARC #1023477, EF #1318164, EF #1241894, EF #1241891), NASA Terrestrial Ecosystems, the Energy Biosciences Institute, and an Amazon AWS in Education Grant. PEcAn Version 1.4.10.1"; } @@ -38,7 +38,7 @@ function passvars($ignore) { echo ""; } } - } + } } # ---------------------------------------------------------------------- # CONVERT STRING TO XML @@ -59,7 +59,16 @@ function open_database() { global $db_bety_type; global $pdo; - $pdo = new PDO("${db_bety_type}:host=${db_bety_hostname};dbname=${db_bety_database}", $db_bety_username, $db_bety_password); + try { + $pdo = new PDO("${db_bety_type}:host=${db_bety_hostname};dbname=${db_bety_database}", $db_bety_username, $db_bety_password); + $pdo->setAttribute(PDO::ATTR_ERRMODE, PDO::ERRMODE_EXCEPTION); + } catch (PDOException $e) { + // handler to input database configurations manually + echo "Something wrong :(
    Connection failed: " . $e->getMessage()."

    You can use the reset button to reset the settings and try agin."; + die(); + } + +// $pdo = new PDO("${db_bety_type}:host=${db_bety_hostname};dbname=${db_bety_database}", $db_bety_username, $db_bety_password); } function close_database() { @@ -121,7 +130,7 @@ function encrypt_password($password, $salt) { for($i=0; $i<$REST_AUTH_DIGEST_STRETCHES; $i++) { $digest=sha1($digest . "--" . $salt . "--" . $password . "--" . $REST_AUTH_SITE_KEY); } - return $digest; + return $digest; } function logout() { From 8e2fbb47df5f8169432677164f286efb6f5bc0db Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 19:47:34 +0530 Subject: [PATCH 107/771] Typo fix --- book_source/basic_users_guide/Getting-started.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/book_source/basic_users_guide/Getting-started.Rmd b/book_source/basic_users_guide/Getting-started.Rmd index ffe866509da..72c0dfabef9 100644 --- a/book_source/basic_users_guide/Getting-started.Rmd +++ b/book_source/basic_users_guide/Getting-started.Rmd @@ -101,6 +101,6 @@ Following are the steps to setup a Docker instance of the PEcAn. To access the web interface can visit :8080 If using localmachine then can use localhost:8080 -Only SIPNET model is included as the default package in it. +Only SIPNET model is included as the default model in it. [pecan-wikipedia]: https://en.wikipedia.org/wiki/Pecan From faeb7ea5cda96123436f283183eadabfd1e2e6b6 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sat, 15 Jul 2017 09:22:33 -0500 Subject: [PATCH 108/771] Adding geom smooth --- shiny/workflowPlot/server.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index d2b7b132292..52e0a791515 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -147,7 +147,7 @@ server <- shinyServer(function(input, output, session) { plt <- plt + geom_line() } ) - plt <- plt + labs(title=title, x=xlab, y=ylab) + plt <- plt + labs(title=title, x=xlab, y=ylab) + geom_smooth() # if (!is.null(loaded_data)) { # if (input$load_data>0) { From cb2cefa066e70cda4dda606d747e6037b5abec93 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 21:09:45 +0530 Subject: [PATCH 109/771] Added a script to update the requested configuration in config.php --- web/setups/add.php | 54 +++++++++++++++++++++++++++++++++++++++++++++ web/setups/core.php | 2 +- 2 files changed, 55 insertions(+), 1 deletion(-) create mode 100644 web/setups/add.php diff --git a/web/setups/add.php b/web/setups/add.php new file mode 100644 index 00000000000..c857b335bf7 --- /dev/null +++ b/web/setups/add.php @@ -0,0 +1,54 @@ +"; + if(preg_match($pattern,$line)){ + //spliting variable and values so can used variable as the input field names + $temp = preg_split('/=/',$line); + $inputname = preg_split('/\$/',$temp[0]); + + // get the new value from the post request + $newvalue = $_POST[$inputname[1]]; + + //$newline = preg_replace('/'.$temp[0].'/',$temp[0].'="'.$newvalue.'";',$line); + //echo $temp[0].'="'.$newvalue.'";'; + //var_dump($newvalue); + fwrite($file, $temp[0].'="'.$newvalue.'";'); + //var_dump($inputname); + //var_dump($temp); + //echo "match found
    "; + } + else { + // if no change in the line write as it is + fwrite($file, $line); + } +} +fclose($file); + +// copy the temprory file to config.php and remove it +rename('../config.php.temp', '../config.php'); +unlink('../config.php.temp'); + +include 'page.template.php'; +?> +

    Configuration details

    +

    Configuration Sucessfully updated

    + diff --git a/web/setups/core.php b/web/setups/core.php index 07bd74b3d24..49f64e758c6 100644 --- a/web/setups/core.php +++ b/web/setups/core.php @@ -32,7 +32,7 @@ } // read content of file - $file = fopen('../config.php', "c+") or die('Cannot open file: Check whether file exist and it have correct permissions'); + //$file = fopen('../config.php', "c+") or die('Cannot open file: Check whether file exist and it have correct permissions'); $file_contents = file('../config.php'); From f9478ae7b68e9e56325b57976dc74945e7712fd5 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 21:21:30 +0530 Subject: [PATCH 110/771] New line problem fiexd in the config.php --- web/setups/add.php | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/web/setups/add.php b/web/setups/add.php index c857b335bf7..1d3853d5234 100644 --- a/web/setups/add.php +++ b/web/setups/add.php @@ -29,7 +29,7 @@ //$newline = preg_replace('/'.$temp[0].'/',$temp[0].'="'.$newvalue.'";',$line); //echo $temp[0].'="'.$newvalue.'";'; //var_dump($newvalue); - fwrite($file, $temp[0].'="'.$newvalue.'";'); + fwrite($file, $temp[0].'="'.$newvalue.'";'."\n"); //var_dump($inputname); //var_dump($temp); //echo "match found
    "; From 2e2a0c50e72346f0a30b9dc97660c0cf5b3da265 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 22:32:22 +0530 Subject: [PATCH 111/771] Added a list of avaliable configuration in the web page --- web/setups/core.php | 4 ++-- web/setups/edit.php | 2 +- web/setups/page.template.php | 7 +++++++ 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/web/setups/core.php b/web/setups/core.php index 49f64e758c6..ab71593f90b 100644 --- a/web/setups/core.php +++ b/web/setups/core.php @@ -13,7 +13,7 @@ */ // If file doesn't exist then create a new file - if (file_exists ("config.php") == false){ + if (file_exists ("../config.php") == false){ copy ('../config.example.php', '../config.php'); } @@ -24,7 +24,7 @@ // set the pattern to match with the input switch ($key) { - case 'all': $pattern = '/^\$/i'; break; + case 'all': $pattern = '/^\$/i'; break; // not working properly case 'browndog': $pattern = '/\$browndog*/i'; break; case 'database': $pattern = '/\$db_bety_*/i'; break; case 'fiadb': $pattern = '/\$db_fia_*/i'; break; diff --git a/web/setups/edit.php b/web/setups/edit.php index b5734e28fbe..b3f12a3cb27 100644 --- a/web/setups/edit.php +++ b/web/setups/edit.php @@ -13,7 +13,7 @@ include 'core.php'; include 'page.template.php'; ?> -
    "> + ">

    Configuration details

    +

    +

    List of available configurations

    + Database
    + Browndog
    + FIA Database
    + Google MapKey
    +

    Documentation
    From dd09ffd19e009403299e4a85d3a8a869dc8c9cff Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 22:37:57 +0530 Subject: [PATCH 112/771] minor url fix in 01-introduction.php --- web/01-introduction.php | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/web/01-introduction.php b/web/01-introduction.php index 54184ccea0d..051e55d9db6 100644 --- a/web/01-introduction.php +++ b/web/01-introduction.php @@ -9,9 +9,9 @@ */ // Check for config.php if doesn't exits then redirect to the setup page -if (!file_exists('config.php')) +if (file_exists('config.php') == false) { - header('/setups/edit.php?key=all'); + header('setups/edit.php?key=all'); } // Check login From b737321808a35592fb8b8814bc16ab27dee32e6e Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 22:40:58 +0530 Subject: [PATCH 113/771] redirect in common.php if config.php doesn't exist --- web/common.php | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/web/common.php b/web/common.php index c04e3c6000c..8ab07107b6e 100644 --- a/web/common.php +++ b/web/common.php @@ -1,5 +1,10 @@ Date: Sat, 15 Jul 2017 22:48:13 +0530 Subject: [PATCH 114/771] Added a temporary rediect to setup pages if config.php doesn't exist --- web/01-introduction.php | 5 ++++- web/common.php | 5 ++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/web/01-introduction.php b/web/01-introduction.php index 051e55d9db6..0b7587370fc 100644 --- a/web/01-introduction.php +++ b/web/01-introduction.php @@ -11,7 +11,10 @@ // Check for config.php if doesn't exits then redirect to the setup page if (file_exists('config.php') == false) { - header('setups/edit.php?key=all'); + $host = $_SERVER['HTTP_HOST']; + $uri = rtrim(dirname($_SERVER['PHP_SELF']), '/\\'); + header("Location: http://$host$uri/edit.php?key=all",TRUE,307); + exit; } // Check login diff --git a/web/common.php b/web/common.php index 8ab07107b6e..8541c5e627e 100644 --- a/web/common.php +++ b/web/common.php @@ -2,7 +2,10 @@ if (file_exists('config.php') == false) { - header('setups/edit.php?key=all'); + $host = $_SERVER['HTTP_HOST']; + $uri = rtrim(dirname($_SERVER['PHP_SELF']), '/\\'); + header("Location: http://$host$uri/edit.php?key=all",TRUE,307); + exit; } require("config.php"); From 2b8dbc6e7b312b535b80d51cff4f0e10096a2987 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 22:51:03 +0530 Subject: [PATCH 115/771] Removed the redirect to setup page from 01-introduction.php --- web/01-introduction.php | 9 --------- web/common.php | 2 +- 2 files changed, 1 insertion(+), 10 deletions(-) diff --git a/web/01-introduction.php b/web/01-introduction.php index 0b7587370fc..81c4cec32dd 100644 --- a/web/01-introduction.php +++ b/web/01-introduction.php @@ -8,15 +8,6 @@ * http://opensource.ncsa.illinois.edu/license.html */ -// Check for config.php if doesn't exits then redirect to the setup page -if (file_exists('config.php') == false) -{ - $host = $_SERVER['HTTP_HOST']; - $uri = rtrim(dirname($_SERVER['PHP_SELF']), '/\\'); - header("Location: http://$host$uri/edit.php?key=all",TRUE,307); - exit; -} - // Check login require("common.php"); diff --git a/web/common.php b/web/common.php index 8541c5e627e..1dd232f63be 100644 --- a/web/common.php +++ b/web/common.php @@ -4,7 +4,7 @@ { $host = $_SERVER['HTTP_HOST']; $uri = rtrim(dirname($_SERVER['PHP_SELF']), '/\\'); - header("Location: http://$host$uri/edit.php?key=all",TRUE,307); + header("Location: http://$host$uri/setups/edit.php?key=all",TRUE,307); exit; } From e0184395bb22d9227484bb514663a92236ea5280 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 23:03:42 +0530 Subject: [PATCH 116/771] Added handler if copying of config files fails --- web/setups/core.php | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/web/setups/core.php b/web/setups/core.php index ab71593f90b..d2625c1f7f9 100644 --- a/web/setups/core.php +++ b/web/setups/core.php @@ -14,7 +14,11 @@ // If file doesn't exist then create a new file if (file_exists ("../config.php") == false){ - copy ('../config.example.php', '../config.php'); + if (!copy ('../config.example.php', '../config.php')){ + $error = error_get_last(); + echo "error:$error"; + die(); + } } // key defines the attribute or the group of attributes which are needed to modify @@ -24,7 +28,7 @@ // set the pattern to match with the input switch ($key) { - case 'all': $pattern = '/^\$/i'; break; // not working properly + case 'all': $pattern = '/^\$/i'; break; // not working properly case 'browndog': $pattern = '/\$browndog*/i'; break; case 'database': $pattern = '/\$db_bety_*/i'; break; case 'fiadb': $pattern = '/\$db_fia_*/i'; break; From 199197bfb13e3ebdc7378a91cc1b626ff06a809e Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 23:09:34 +0530 Subject: [PATCH 117/771] Exception handler for the reading config.php contents --- web/setups/core.php | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/web/setups/core.php b/web/setups/core.php index d2625c1f7f9..c8c4e5f6415 100644 --- a/web/setups/core.php +++ b/web/setups/core.php @@ -16,7 +16,7 @@ if (file_exists ("../config.php") == false){ if (!copy ('../config.example.php', '../config.php')){ $error = error_get_last(); - echo "error:$error"; + echo "error:$error"; die(); } } @@ -38,7 +38,7 @@ // read content of file //$file = fopen('../config.php', "c+") or die('Cannot open file: Check whether file exist and it have correct permissions'); - $file_contents = file('../config.php'); + $file_contents = file('../config.php') or die('Cannot open file: Check whether file exist and it have correct permissions'); //var_dump($file_contents); //var_dump($pattern); From cab18a0f7584ec524ef0df9675048f3bbe2b007b Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 15 Jul 2017 23:38:54 +0530 Subject: [PATCH 118/771] fixed the redirect loop problem Added temporary redriect code 307 when redirecting the to config page Added footer in pagefooter.template.php --- web/common.php | 3 +-- web/setups/core.php | 3 +-- web/setups/page.template.php | 2 -- web/setups/pagefooter.template.php | 5 ++++- 4 files changed, 6 insertions(+), 7 deletions(-) diff --git a/web/common.php b/web/common.php index 1dd232f63be..42542491087 100644 --- a/web/common.php +++ b/web/common.php @@ -3,8 +3,7 @@ if (file_exists('config.php') == false) { $host = $_SERVER['HTTP_HOST']; - $uri = rtrim(dirname($_SERVER['PHP_SELF']), '/\\'); - header("Location: http://$host$uri/setups/edit.php?key=all",TRUE,307); + header("Location: http://$host/setups/edit.php?key=all",TRUE,307); exit; } diff --git a/web/setups/core.php b/web/setups/core.php index c8c4e5f6415..f13637d50c4 100644 --- a/web/setups/core.php +++ b/web/setups/core.php @@ -15,8 +15,7 @@ // If file doesn't exist then create a new file if (file_exists ("../config.php") == false){ if (!copy ('../config.example.php', '../config.php')){ - $error = error_get_last(); - echo "error:$error"; + echo "error: permissions denined"; die(); } } diff --git a/web/setups/page.template.php b/web/setups/page.template.php index b3668efefba..0d3302a7c69 100644 --- a/web/setups/page.template.php +++ b/web/setups/page.template.php @@ -8,8 +8,6 @@ * http://opensource.ncsa.illinois.edu/license.html */ -require("../common.php"); - // This page is designed to act as the template page for all the configurations setups ?> diff --git a/web/setups/pagefooter.template.php b/web/setups/pagefooter.template.php index ff5a4559465..1fbe2f7e6c6 100644 --- a/web/setups/pagefooter.template.php +++ b/web/setups/pagefooter.template.php @@ -13,7 +13,10 @@ ?> -

    + From 2d212c97f49b56ab16df6aba36cf1ed6f6e68ee2 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sun, 16 Jul 2017 00:31:46 +0530 Subject: [PATCH 119/771] removed all unwanted codes header redirect set to the index.php --- web/common.php | 4 ++-- web/setups/add.php | 9 --------- web/setups/core.php | 5 ----- web/setups/edit.php | 6 +----- web/setups/index.php | 20 ++++++++++++++++++++ web/setups/page.template.php | 19 ++----------------- web/setups/pagefooter.template.php | 15 +++++++++++++++ 7 files changed, 40 insertions(+), 38 deletions(-) create mode 100644 web/setups/index.php diff --git a/web/common.php b/web/common.php index 42542491087..35c8ca133b1 100644 --- a/web/common.php +++ b/web/common.php @@ -3,7 +3,7 @@ if (file_exists('config.php') == false) { $host = $_SERVER['HTTP_HOST']; - header("Location: http://$host/setups/edit.php?key=all",TRUE,307); + header("Location: http://$host/setups/",TRUE,307); exit; } @@ -71,7 +71,7 @@ function open_database() { $pdo->setAttribute(PDO::ATTR_ERRMODE, PDO::ERRMODE_EXCEPTION); } catch (PDOException $e) { // handler to input database configurations manually - echo "Something wrong :(
    Connection failed: " . $e->getMessage()."

    You can use the reset button to reset the settings and try agin."; + echo "Something wrong :(
    Connection failed: " . $e->getMessage(); die(); } diff --git a/web/setups/add.php b/web/setups/add.php index 1d3853d5234..35c3d4bbe71 100644 --- a/web/setups/add.php +++ b/web/setups/add.php @@ -14,10 +14,7 @@ // open a new temprory file to write data to it $file = fopen('../config.php.temp', "w+") or die('Cannot open file: Check whether file exist and it have correct permissions'); -//fwrite($file, '"; if(preg_match($pattern,$line)){ //spliting variable and values so can used variable as the input field names $temp = preg_split('/=/',$line); @@ -26,13 +23,7 @@ // get the new value from the post request $newvalue = $_POST[$inputname[1]]; - //$newline = preg_replace('/'.$temp[0].'/',$temp[0].'="'.$newvalue.'";',$line); - //echo $temp[0].'="'.$newvalue.'";'; - //var_dump($newvalue); fwrite($file, $temp[0].'="'.$newvalue.'";'."\n"); - //var_dump($inputname); - //var_dump($temp); - //echo "match found
    "; } else { // if no change in the line write as it is diff --git a/web/setups/core.php b/web/setups/core.php index f13637d50c4..20950d1a225 100644 --- a/web/setups/core.php +++ b/web/setups/core.php @@ -35,13 +35,8 @@ } // read content of file - //$file = fopen('../config.php', "c+") or die('Cannot open file: Check whether file exist and it have correct permissions'); - $file_contents = file('../config.php') or die('Cannot open file: Check whether file exist and it have correct permissions'); - //var_dump($file_contents); - //var_dump($pattern); - // including the config.php so that the previous values can be used in the files inputs include '../config.php'; diff --git a/web/setups/edit.php b/web/setups/edit.php index b3f12a3cb27..4ad69e5be8f 100644 --- a/web/setups/edit.php +++ b/web/setups/edit.php @@ -17,20 +17,16 @@

    Configuration details

    "; if(preg_match($pattern,$line)){ //spliting variable and values so can used variable as the input field names $temp = preg_split('/=/',$line); $inputname = preg_split('/\$/',$temp[0]); - //var_dump($inputname); // HTML input code for field input; ?>
    "; } } ?> @@ -39,4 +35,4 @@ +?> diff --git a/web/setups/index.php b/web/setups/index.php new file mode 100644 index 00000000000..635a394bc6f --- /dev/null +++ b/web/setups/index.php @@ -0,0 +1,20 @@ + +

    Introduction

    +

    Welcome to the Configuration page.

    +

    Side panal consist of all the available configuarations.

    + diff --git a/web/setups/page.template.php b/web/setups/page.template.php index 0d3302a7c69..78a65295a09 100644 --- a/web/setups/page.template.php +++ b/web/setups/page.template.php @@ -11,28 +11,13 @@ // This page is designed to act as the template page for all the configurations setups ?> - + -PEcAn +PEcAn Configurations - -
    diff --git a/web/setups/pagefooter.template.php b/web/setups/pagefooter.template.php index 1fbe2f7e6c6..4046d6ca7e8 100644 --- a/web/setups/pagefooter.template.php +++ b/web/setups/pagefooter.template.php @@ -18,5 +18,20 @@ Terrestrial Ecosystems, the Energy Biosciences Institute, and an Amazon AWS in Education Grant. PEcAn Version 1.4.10.1" ?>
    + + From 8494a47fa5494f202a2d9bb2d5ebf7eec31ba0df Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sun, 16 Jul 2017 00:37:39 +0530 Subject: [PATCH 120/771] updated CHANGELOG --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index ad3211a8b8f..831683f625d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,6 +11,8 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Updated downloadAmeriflux and downloadNARR to make use of PEcAn.utils::download.file() - Added -w flag to load.bety.sh script to specify the URL to fetch the data from - add new table sites_cultivars to betydb sync scripts (dump and load) +- added docker container scrips (.yml) to create docker container for PEcAn +- added the configuration edit page to allow easy modification of config via web interface ### Changed - upscale_met now accepts ~any valid CF file (not just full years), retains correct time units, and respects the previously ignored `overwrite` parameter From 0c3ecb5cbe2e0775d28d52c8cfe7c698bcad4985 Mon Sep 17 00:00:00 2001 From: PEcAn Demo User Date: Sat, 15 Jul 2017 18:03:29 -0500 Subject: [PATCH 121/771] removing verbatimTextOutput --- shiny/workflowPlot/ui.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 5d7b0bba267..84736c63cb8 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -36,8 +36,8 @@ ui <- shinyUI(fluidPage( ), mainPanel( plotlyOutput("outputPlot"), - verbatimTextOutput("info1"), - verbatimTextOutput("info") + verbatimTextOutput("info1") + # verbatimTextOutput("info") ) ) )) From bcc0189458768808154d3a1799c9da63691669ef Mon Sep 17 00:00:00 2001 From: PEcAn Demo User Date: Sat, 15 Jul 2017 21:32:46 -0500 Subject: [PATCH 122/771] Framework to upload data --- shiny/workflowPlot/server.R | 95 ++++++++++++++++++++++++++++--------- shiny/workflowPlot/ui.R | 7 +-- 2 files changed, 76 insertions(+), 26 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 52e0a791515..a8f07511b26 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -1,5 +1,7 @@ library(PEcAn.visualization) library(PEcAn.DB) +library(PEcAn.settings) +library(PEcAn.benchmark) library(shiny) library(ncdf4) library(ggplot2) @@ -7,7 +9,10 @@ library(ggplot2) source('helper.R') library(plotly) library(scales) +library(lubridate) library(dplyr) +# Maximum size of file allowed to be uploaded +options(shiny.maxRequestSize=100*1024^2) # Define server logic server <- shinyServer(function(input, output, session) { bety <- betyConnect() @@ -89,26 +94,38 @@ server <- shinyServer(function(input, output, session) { } return(globalDF) }) - loadExternalData <-eventReactive(input$load_data,{ - inFile <- input$file1 - if (is.null(inFile)) - return(NULL) - externalData <- read.csv(inFile$datapath, header=input$header, sep=input$sep, - quote=input$quote) - externalData$dates <- as.Date(externalData$dates) - externalData <- externalData %>% - dplyr::filter(var_name == input$variable_name) - # output$info1 <- renderText({ - # paste0(nrow(externalData)) - # # paste0(inFile$datapath) - # }) - return(externalData) - }) - # output$info <- renderText({ - # inFile <- input$file1 - # paste0(inFile$datapath) - # # paste0(input$load_data) - # }) + # loadExternalData <-eventReactive(input$load_data,{ + # inFile <- input$fileUploaded + # if (is.null(inFile)) + # return(NULL) + # externalData <- read.csv(inFile$datapath, header=input$header, sep=input$sep, + # quote=input$quote) + # externalData$dates <- as.Date(externalData$dates) + # externalData <- externalData %>% + # dplyr::filter(var_name == input$variable_name) + # # output$info1 <- renderText({ + # # paste0(nrow(externalData)) + # # # paste0(inFile$datapath) + # # }) + # return(externalData) + # }) + loadObservationData <- function(bety,settings,File_path,File_format){ + start.year<-as.numeric(lubridate::year(settings$run$start.date)) + end.year<-as.numeric(lubridate::year(settings$run$end.date)) + site.id<-settings$run$site$id + site<-PEcAn.DB::query.site(site.id,bety$con) + observations<-PEcAn.benchmark::load_data(data.path = File_path, format= File_format, time.row = File_format$time.row, site = site, start_year = start.year, end_year = end.year) + return(observations) + } + getFileFormat <- function(bety,input.id){ + File_format <- PEcAn.DB::query.format.vars(bety = bety, input.id = input.id) + return(File_format) + } + getSettings <- function(workflowID){ + configPath <- paste0("~/output/PEcAn_",workflowID,"/pecan.CONFIGS.xml") + settings<-PEcAn.settings::read.settings(configPath) + return(settings) + } # Renders ggplotly output$outputPlot <- renderPlotly({ # Error messages @@ -117,12 +134,19 @@ server <- shinyServer(function(input, output, session) { need(input$all_run_id, 'Select Run id'), need(input$variable_name, 'Click the button to load data. Please allow some time') ) + # output$info <- renderText({ + # # inFile <- input$fileUploaded + # # paste0(inFile$datapath) + # # # paste0(input$load_data) + # # paste0(File_format$mimetype) + # ids_DF <- parse_ids_from_input_runID(input$all_run_id) + # settings <- getSettings(ids_DF$wID[1]) + # paste0(settings$run$site$id) + # }) # Load data externalData <- data.frame() modelData <- loadNewData() - if (input$load_data>0) { - externalData <- loadExternalData() - } + masterDF <- rbind(modelData,externalData) # Convert from factor to character. For subsetting masterDF$var_name <- as.character(masterDF$var_name) @@ -149,6 +173,31 @@ server <- shinyServer(function(input, output, session) { ) plt <- plt + labs(title=title, x=xlab, y=ylab) + geom_smooth() + if (input$load_data>0) { + File_format <- getFileFormat(bety,input$inputRecordID) + ids_DF <- parse_ids_from_input_runID(input$all_run_id) + # output$info <- renderText({ + # paste0(ids_DF$wID[1]) + # }) + settings <- getSettings(ids_DF$wID[1]) + # start.year<-as.numeric(lubridate::year(settings$run$start.date)) + # end.year<-as.numeric(lubridate::year(settings$run$end.date)) + # site.id<-settings$run$site$id + # site<-PEcAn.DB::query.site(site.id,bety$con) + inFile <- input$fileUploaded + externalData <- loadObservationData(bety,settings,inFile$datapath,File_format) + # output$info <- renderText({ + # # # inFile <- input$fileUploaded + # # # paste0(inFile$datapath) + # # # # paste0(input$load_data) + # # # paste0(File_format$mimetype) + # # ids_DF <- parse_ids_from_input_runID(input$all_run_id) + # # paste0(settings$run$site$id) + # # paste0(site) + # paste0(nrow(externalData)) + # }) + # externalData <- loadExternalData() + } # if (!is.null(loaded_data)) { # if (input$load_data>0) { # loaded_data <- loadExternalData() diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 84736c63cb8..6d02a693350 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -17,7 +17,7 @@ ui <- shinyUI(fluidPage( radioButtons("plotType", "Plot Type", c("Scatter Plot" = "scatterPlot", "Line Chart" = "lineChart"), selected="scatterPlot"), tags$hr(), tags$hr(), - fileInput('file1', 'Choose CSV File to upload data', + fileInput('fileUploaded', 'Choose CSV File to upload data', accept=c('text/csv', 'text/comma-separated-values,text/plain', '.csv')), @@ -32,12 +32,13 @@ ui <- shinyUI(fluidPage( 'Double Quote'='"', 'Single Quote'="'"), ''), + textInput("inputRecordID", "Input Record ID for CSV file", "1000011260"), actionButton("load_data", "Load External Data") ), mainPanel( plotlyOutput("outputPlot"), - verbatimTextOutput("info1") - # verbatimTextOutput("info") + verbatimTextOutput("info1"), + verbatimTextOutput("info") ) ) )) From 2c42157c1b2ecd040276291568973c8dced8a95f Mon Sep 17 00:00:00 2001 From: PEcAn Demo User Date: Sat, 15 Jul 2017 22:14:39 -0500 Subject: [PATCH 123/771] Addin gplot type for server.R --- shiny/workflowPlot/server.R | 35 ++++++++++++++++------------------- 1 file changed, 16 insertions(+), 19 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index a8f07511b26..40545bfd6a8 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -176,35 +176,32 @@ server <- shinyServer(function(input, output, session) { if (input$load_data>0) { File_format <- getFileFormat(bety,input$inputRecordID) ids_DF <- parse_ids_from_input_runID(input$all_run_id) - # output$info <- renderText({ - # paste0(ids_DF$wID[1]) - # }) settings <- getSettings(ids_DF$wID[1]) - # start.year<-as.numeric(lubridate::year(settings$run$start.date)) - # end.year<-as.numeric(lubridate::year(settings$run$end.date)) - # site.id<-settings$run$site$id - # site<-PEcAn.DB::query.site(site.id,bety$con) inFile <- input$fileUploaded externalData <- loadObservationData(bety,settings,inFile$datapath,File_format) - # output$info <- renderText({ - # # # inFile <- input$fileUploaded - # # # paste0(inFile$datapath) - # # # # paste0(input$load_data) - # # # paste0(File_format$mimetype) - # # ids_DF <- parse_ids_from_input_runID(input$all_run_id) - # # paste0(settings$run$site$id) - # # paste0(site) - # paste0(nrow(externalData)) - # }) + externalData <- externalData %>% dplyr::select(posix,input$variable_name) + if(nrow(externalData)>0){ + names(externalData) <- c("dates","vals") + externalData$dates <- as.Date(externalData$dates) + output$info <- renderText({ + # # inFile <- input$fileUploaded + # # paste0(inFile$datapath) + # # # paste0(input$load_data) + # # paste0(File_format$mimetype) + # ids_DF <- parse_ids_from_input_runID(input$all_run_id) + # paste0(settings$run$site$id) + # paste0(site) + paste0(names(externalData)) + }) + plt <- plt + geom_line(data = externalData,aes(x=dates, y=vals), linetype = 'dashed') + } # externalData <- loadExternalData() } # if (!is.null(loaded_data)) { - # if (input$load_data>0) { # loaded_data <- loadExternalData() # output$info1 <- renderText({ # paste0(nrow(loaded_data)) # # paste0(inFile$datapath) - # }) # plt <- plt + geom_line(data = loaded_data,aes(x=dates, y=vals), linetype = 'dashed') # } # geom_point() + From 8f9d9e8cc4e8fa8ff313e30cef80539dddbe0b13 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sun, 16 Jul 2017 14:42:47 +0530 Subject: [PATCH 124/771] Added script to update the user password via web interface --- web/setups/chpasswd.php | 91 +++++++++++++++++++++++++++++++++++++++++ web/setups/chpasswd.sh | 12 ++++++ 2 files changed, 103 insertions(+) create mode 100644 web/setups/chpasswd.php create mode 100644 web/setups/chpasswd.sh diff --git a/web/setups/chpasswd.php b/web/setups/chpasswd.php new file mode 100644 index 00000000000..bf7e9d09ae3 --- /dev/null +++ b/web/setups/chpasswd.php @@ -0,0 +1,91 @@ +".$output; + } +}else { +?> +
    +
    +

    Password Change

    +
    +
    + +
    + +
    +
    + +
    + +
    + +
    +
    + +
    + +
    + +
    +
    + +
    + +
    + +
    +
    + +
    +
    + +
    +
    +
    +
    +
    + + diff --git a/web/setups/chpasswd.sh b/web/setups/chpasswd.sh new file mode 100644 index 00000000000..2403b8a453b --- /dev/null +++ b/web/setups/chpasswd.sh @@ -0,0 +1,12 @@ +#!/bin/sh +# This script use expect +# It can be installed using apt-get expect +exec expect -f "$0" ${1+"$@"} +set password [lindex $argv 1] +spawn passwd [lindex $argv 0] +sleep 1 +expect "assword:" +send "$password\r" +expect "assword:" +send "$password\r" +expect eof From ee087b1d22c0705c6ff5fdbce2d7cfa057d099c8 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sun, 16 Jul 2017 14:43:32 +0530 Subject: [PATCH 125/771] Improved the UI added bootstrap framework to make it responsive --- web/setups/page.template.php | 59 ++++++++++++++++++------------ web/setups/pagefooter.template.php | 6 ++- 2 files changed, 41 insertions(+), 24 deletions(-) diff --git a/web/setups/page.template.php b/web/setups/page.template.php index 78a65295a09..874d78b79db 100644 --- a/web/setups/page.template.php +++ b/web/setups/page.template.php @@ -14,35 +14,48 @@ PEcAn Configurations - + + + + + + + + +
    -
    -
    -
    -

    Introduction

    -

    On this page you will find the required fields to setup the particular configurations or edit it.

    - -
    -
    -

    -

    List of available configurations

    - Database
    - Browndog
    - FIA Database
    - Google MapKey
    -

    -

    - Documentation -
    - Chat Room -
    - Bug Report -

    +

    Introduction

    +

    This is the Admin Pages. +

    List of available configurations

    + Database
    + Browndog
    + FIA Database
    + Google MapKey
    +

    +
    +

    Automatic Sync

    +
    +

    +

    + Documentation +
    + Chat Room +
    + Bug Report +

    diff --git a/web/setups/pagefooter.template.php b/web/setups/pagefooter.template.php index 4046d6ca7e8..877db6cd5bd 100644 --- a/web/setups/pagefooter.template.php +++ b/web/setups/pagefooter.template.php @@ -11,13 +11,17 @@ // This page is designed to act as the template page for all the configurations setups // This page only have footer part. ?> -
    + + + + + From 480cd4a7c8db5e80136fea8a562b88250b9e0d7b Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sun, 23 Jul 2017 23:04:00 +0530 Subject: [PATCH 171/771] Removed redirect from common.php --- web/common.php | 8 -------- 1 file changed, 8 deletions(-) diff --git a/web/common.php b/web/common.php index 37d96bb1931..4757bbc2469 100644 --- a/web/common.php +++ b/web/common.php @@ -1,12 +1,5 @@ Connection failed: " . $e->getMessage(); die(); } - // $pdo = new PDO("${db_bety_type}:host=${db_bety_hostname};dbname=${db_bety_database}", $db_bety_username, $db_bety_password); } From 4dfffd1e299a443761f5d4db07bab87a3210f00b Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Mon, 24 Jul 2017 19:59:42 -0400 Subject: [PATCH 172/771] Added Roxygen2 Format --- modules/data.land/R/DataONE_doi_download.R | 108 +++++++++++---------- 1 file changed, 58 insertions(+), 50 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index a6832cc39c9..250cea1dbbd 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -1,46 +1,54 @@ ##' Functions to determine if data can be found by doi in R ##' Author: Liam Burke -##' Code draws heavily on dataone r package for communication with the dataONE federation - -#--------------------------------------------------------------------------------# -# 1. format.identifier -- convert doi or id into solrQuery format # -#--------------------------------------------------------------------------------# - +##' Code draws heavily on dataoneR package for communication with the DataONE federation + +#' format.identifier +#' +#' @param id the doi or other identifier linked to the package in DataONE +#' +#' @return returns the id in the proper format for querying the DataONE Federation (using solrQuery syntax) +#' @export +#' +#' @author Liam P Burke, \email{lpburke@bu.edu} +#' +#' @examples format.identifier = function(id){ doi.template <- 'id:"_"' # solr format doi1 <<- base::gsub("_", id, doi.template) # replace "_" with the doi or id and store in global environment return(doi1) } # end function -#--------------------------------------------------------------------------------# -# 2. id.resolveable -- Is doi/ id available in dataONE? # -#--------------------------------------------------------------------------------# - -##' Arguments -#' id: doi or dataone id -#' CNode: usually "PROD" -#' return_result: boolean that returns or suppresses result of query +#' id.resolveable +#' +#' @param id the doi or other identifier linked to the package in DataONE +#' @param CNode usually "PROD" +#' @param return_result boolean that returns or suppresses result of query +#' +#' @return returns message indicating wether or not the id resolves to data in the DataONE federation +#' @export +#' +#' @examples id.resolveable = function(id, CNode, return_result){ format.identifier(id) # reformat the id in solr format - cn <- dataone::CNode("PROD") + cn <- DataONE::CNode("PROD") queryParams <- list(q=doi1, rows="5") - result <- dataone::query(cn, solrQuery = queryParams, as = "data.frame") # return query results as a data.frame + result <- DataONE::query(cn, solrQuery = queryParams, as = "data.frame") # return query results as a data.frame if(return_result == TRUE){ # option that displays data.frame of query print(result) if(is.null(result[1,1])){ # if there is no data available, result[1,1] will return a NULL value - return("doi does not resolve in the DataOne federation and therefore cannot be retrieved by doi. - Either download this data locally and import using PEcAn's drag and drop feature, or search DataOne manually for another data identifier. Thank you for your patience.") + return("doi does not resolve in the DataONE federation and therefore cannot be retrieved by doi. + Either download this data locally and import using PEcAn's drag and drop feature, or search DataONE manually for another data identifier. Thank you for your patience.") } else{ return("data can be found in D1 federation") } } else{ # option that does not display data.frame of query (return_result == FALSE) if(is.null(result[1,1])){ - return("doi does not resolve in the DataOne federation and therefore cannot be retrieved by doi. - Either download this data locally and import using PEcAn's drag and drop feature, or search DataOne manually for another data identifier (e.g. pid or resource_map) Thank you for your patience.") + return("doi does not resolve in the DataONE federation and therefore cannot be retrieved by doi. + Either download this data locally and import using PEcAn's drag and drop feature, or search DataONE manually for another data identifier (e.g. pid or resource_map) Thank you for your patience.") } else{ return("data can be found in D1 federation") } @@ -48,56 +56,56 @@ id.resolveable = function(id, CNode, return_result){ } # end function -#--------------------------------------------------------------------------------# -# Get resource_map from doi # -#--------------------------------------------------------------------------------# - -##' Arguments: -#' id: doi or dataone id -#' CNode: usually "PROD" - +#' get.resource.map +#' +#' @param id the doi or other identifier linked to the package in DataONE +#' @param CNode usually "PROD" +#' +#' @return return the resource_map or a message indicating that there is no corresponding resource_map for the given id +#' @export +#' +#' @examples get.resource.map = function(id, CNode){ - cn <- dataone::CNode("PROD") - locations <- dataone::resolve(cn, pid = id) + cn <- DataONE::CNode("PROD") + locations <- DataONE::resolve(cn, pid = id) mnId <<- locations$data[1,"nodeIdentifier"] # store mnId in global environment - mn <<- dataone::getMNode(cn, mnId) # store mn in global environment + mn <<- DataONE::getMNode(cn, mnId) # store mn in global environment format.identifier(id) # format the identifier in solr Query format queryParamList <- list(q=doi1, fl="resourceMap") # custom query for the resourceMap - resource_map_df <- dataone::query(cn, solrQuery = queryParamList, as="data.frame") + resource_map_df <- DataONE::query(cn, solrQuery = queryParamList, as="data.frame") resource_map <<- resource_map_df[1,1] # store resource map in global env. resource map is always in resource_map_df[1,1] if (is.null(resource_map_df[1,1])){ # inform user if id/ doi has a corresponding resource_map or if this needs to be found manually - print("doi does not resolve a resource_map. Please manually search for the resource_map in DataONE search: https://search.dataone.org/#data") + print("doi does not resolve a resource_map. Please manually search for the resource_map in DataONE search: https://search.DataONE.org/#data") } else{ print("Continue to next phase to complete download") return(resource_map) } } # end function -#--------------------------------------------------------------------------------# -# download package using resource_map # -#--------------------------------------------------------------------------------# - -### Arguments: -#' resource_map: can be entered manually or can be called from the get.resource.map fn result -#' CNode: usually "PROD" -#' download_format: format of download defaulted to "application/bagit-097" -- other possible formats unknown -#' overwrite_directory: boolean -#' directory: indicates the destination directory for the BagItFile - - - +#' download.packages +#' +#' @param resource_map the resource map that corresponds to the given data package +#' @param CNode typically "PROD" +#' @param download_format typically "application/bagit-097". Other possible formats currently unknown. +#' @param overwrite_directory boolean that indicates whether or not the function should overwrite the directory +#' @param directory location that download.packages places the data +#' +#' @return results of download +#' @export +#' +#' @examples download.package.rm = function(resource_map, CNode, download_format = "application/bagit-097", overwrite_directory = TRUE, directory){ # Finding the mnId (query) - cn <- dataone::CNode("PROD") - locations <- dataone::resolve(cn, pid = resource_map) + cn <- DataONE::CNode("PROD") + locations <- DataONE::resolve(cn, pid = resource_map) mnId <<- locations$data[1,"nodeIdentifier"] # download the bagitFile - mn <<- dataone::getMNode(cn, mnId) - bagitFile <<- dataone::getPackage(mn, id = resource_map, format = download_format) + mn <<- DataONE::getMNode(cn, mnId) + bagitFile <<- DataONE::getPackage(mn, id = resource_map, format = download_format) bagitFile From 007970af009a88dc8b5e2fb5d8679e505951e932 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Mon, 24 Jul 2017 20:05:31 -0400 Subject: [PATCH 173/771] Added defaults into and cleaned up id.resolveable --- modules/data.land/R/DataONE_doi_download.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 250cea1dbbd..393423333cd 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -22,17 +22,17 @@ format.identifier = function(id){ #' id.resolveable #' #' @param id the doi or other identifier linked to the package in DataONE -#' @param CNode usually "PROD" +#' @param CNode CNode="PROD" #' @param return_result boolean that returns or suppresses result of query #' #' @return returns message indicating wether or not the id resolves to data in the DataONE federation #' @export #' #' @examples -id.resolveable = function(id, CNode, return_result){ +id.resolveable = function(id, return_result, CNode="PROD"){ format.identifier(id) # reformat the id in solr format - cn <- DataONE::CNode("PROD") + cn <- DataONE::CNode(CNode) queryParams <- list(q=doi1, rows="5") result <- DataONE::query(cn, solrQuery = queryParams, as = "data.frame") # return query results as a data.frame From 3c6f90de64e68496a26bfa5f2223546ea8e40a85 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Mon, 24 Jul 2017 20:07:28 -0400 Subject: [PATCH 174/771] added defaults to get.resource.map --- modules/data.land/R/DataONE_doi_download.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 393423333cd..2eaf8f11338 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -59,14 +59,14 @@ id.resolveable = function(id, return_result, CNode="PROD"){ #' get.resource.map #' #' @param id the doi or other identifier linked to the package in DataONE -#' @param CNode usually "PROD" +#' @param CNode default is "PROD" #' #' @return return the resource_map or a message indicating that there is no corresponding resource_map for the given id #' @export #' #' @examples -get.resource.map = function(id, CNode){ - cn <- DataONE::CNode("PROD") +get.resource.map = function(id, CNode="PROD"){ + cn <- DataONE::CNode(CNode) locations <- DataONE::resolve(cn, pid = id) mnId <<- locations$data[1,"nodeIdentifier"] # store mnId in global environment mn <<- DataONE::getMNode(cn, mnId) # store mn in global environment From fd42c1be43a27959880a03515866284aa4ca93b9 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Mon, 24 Jul 2017 20:11:24 -0400 Subject: [PATCH 175/771] Added dividers between functions and added defaults to download.package.rm --- modules/data.land/R/DataONE_doi_download.R | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 2eaf8f11338..7c0796ef08c 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -18,6 +18,7 @@ format.identifier = function(id){ return(doi1) } # end function +# ----------------------------------------------------------------------------------------------------------------------------------------------------------------- #' id.resolveable #' @@ -29,7 +30,7 @@ format.identifier = function(id){ #' @export #' #' @examples -id.resolveable = function(id, return_result, CNode="PROD"){ +id.resolveable = function(id, return_result, CNode = "PROD"){ format.identifier(id) # reformat the id in solr format cn <- DataONE::CNode(CNode) @@ -56,6 +57,8 @@ id.resolveable = function(id, return_result, CNode="PROD"){ } # end function +# ----------------------------------------------------------------------------------------------------------------------------------------------------------------- + #' get.resource.map #' #' @param id the doi or other identifier linked to the package in DataONE @@ -65,7 +68,7 @@ id.resolveable = function(id, return_result, CNode="PROD"){ #' @export #' #' @examples -get.resource.map = function(id, CNode="PROD"){ +get.resource.map = function(id, CNode = "PROD"){ cn <- DataONE::CNode(CNode) locations <- DataONE::resolve(cn, pid = id) mnId <<- locations$data[1,"nodeIdentifier"] # store mnId in global environment @@ -84,10 +87,12 @@ get.resource.map = function(id, CNode="PROD"){ } } # end function +# ----------------------------------------------------------------------------------------------------------------------------------------------------------------- + #' download.packages #' #' @param resource_map the resource map that corresponds to the given data package -#' @param CNode typically "PROD" +#' @param CNode defaults to "PROD" #' @param download_format typically "application/bagit-097". Other possible formats currently unknown. #' @param overwrite_directory boolean that indicates whether or not the function should overwrite the directory #' @param directory location that download.packages places the data @@ -96,10 +101,10 @@ get.resource.map = function(id, CNode="PROD"){ #' @export #' #' @examples -download.package.rm = function(resource_map, CNode, download_format = "application/bagit-097", - overwrite_directory = TRUE, directory){ +download.package.rm = function(resource_map, directory, CNode = "PROD", download_format = "application/bagit-097", + overwrite_directory = TRUE){ # Finding the mnId (query) - cn <- DataONE::CNode("PROD") + cn <- DataONE::CNode(CNode) locations <- DataONE::resolve(cn, pid = resource_map) mnId <<- locations$data[1,"nodeIdentifier"] From 7317e99f3dcb1816dc49ac2d520008e5d34d5ed7 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Mon, 24 Jul 2017 20:11:58 -0400 Subject: [PATCH 176/771] edited title of download.packages.rm --- modules/data.land/R/DataONE_doi_download.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 7c0796ef08c..24d02df1425 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -89,7 +89,7 @@ get.resource.map = function(id, CNode = "PROD"){ # ----------------------------------------------------------------------------------------------------------------------------------------------------------------- -#' download.packages +#' download.packages.rm #' #' @param resource_map the resource map that corresponds to the given data package #' @param CNode defaults to "PROD" From fdfd899d34ffe885fc76683941e0d7960ab0e473 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Tue, 25 Jul 2017 18:23:48 +0530 Subject: [PATCH 177/771] Added get_footer function in setups/pagefooter.template.php --- web/setups/pagefooter.template.php | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/web/setups/pagefooter.template.php b/web/setups/pagefooter.template.php index f69552cf39e..1771c1a1c82 100644 --- a/web/setups/pagefooter.template.php +++ b/web/setups/pagefooter.template.php @@ -10,12 +10,10 @@ // This page is designed to act as the template page for all the configurations setups // This page only have footer part. + ?> - + From 314b5236e952de197ad204625a62ee3fba019717 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Tue, 25 Jul 2017 18:25:44 +0530 Subject: [PATCH 178/771] Removed the code to update the footer of setup page from scripts/updateVersion.sh as the get_footer function is used in the footer of pagefooter.template.php --- scripts/updateVersion.sh | 6 ------ 1 file changed, 6 deletions(-) diff --git a/scripts/updateVersion.sh b/scripts/updateVersion.sh index 6f7bd6b8501..8b5991ed17b 100755 --- a/scripts/updateVersion.sh +++ b/scripts/updateVersion.sh @@ -46,9 +46,3 @@ if [ $# -eq 0 ]; then echo "Modifying : web/common.php" sed -i.bak -e "s/PEcAn Version [0-9\.]*/PEcAn Version ${VERSION}/" web/common.php fi - -# update pecan version in web page setup/pagefooter.template.php -if [ $# -eq 0 ]; then - echo "Modifying : web/pagefooter.template.php" - sed -i.bak -e "s/PEcAn Version [0-9\.]*/PEcAn Version ${VERSION}/" web/setups/pagefooter.template.php -fi From 39b10a940ec7329fd15cb61e446a4bdd78293c67 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 25 Jul 2017 12:12:14 -0400 Subject: [PATCH 179/771] set a default return_result option for id.resolveable --- modules/data.land/R/DataONE_doi_download.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 24d02df1425..90a2eda02be 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -24,13 +24,13 @@ format.identifier = function(id){ #' #' @param id the doi or other identifier linked to the package in DataONE #' @param CNode CNode="PROD" -#' @param return_result boolean that returns or suppresses result of query +#' @param return_result boolean that returns or suppresses result of query. defaults to TRUE. #' #' @return returns message indicating wether or not the id resolves to data in the DataONE federation #' @export #' #' @examples -id.resolveable = function(id, return_result, CNode = "PROD"){ +id.resolveable = function(id, return_result = TRUE, CNode = "PROD"){ format.identifier(id) # reformat the id in solr format cn <- DataONE::CNode(CNode) @@ -89,7 +89,7 @@ get.resource.map = function(id, CNode = "PROD"){ # ----------------------------------------------------------------------------------------------------------------------------------------------------------------- -#' download.packages.rm +#' download.packages #' #' @param resource_map the resource map that corresponds to the given data package #' @param CNode defaults to "PROD" From 5816f4c74e1574387638618e1a412662ee616c6f Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 25 Jul 2017 12:30:37 -0400 Subject: [PATCH 180/771] Simplified if statement in is.resolveable --- modules/data.land/R/DataONE_doi_download.R | 22 +++++++--------------- 1 file changed, 7 insertions(+), 15 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 90a2eda02be..8b5420d29e3 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -38,23 +38,15 @@ id.resolveable = function(id, return_result = TRUE, CNode = "PROD"){ result <- DataONE::query(cn, solrQuery = queryParams, as = "data.frame") # return query results as a data.frame if(return_result == TRUE){ # option that displays data.frame of query - print(result) - - if(is.null(result[1,1])){ # if there is no data available, result[1,1] will return a NULL value - return("doi does not resolve in the DataONE federation and therefore cannot be retrieved by doi. - Either download this data locally and import using PEcAn's drag and drop feature, or search DataONE manually for another data identifier. Thank you for your patience.") - } else{ - return("data can be found in D1 federation") - } - } else{ # option that does not display data.frame of query (return_result == FALSE) - if(is.null(result[1,1])){ - return("doi does not resolve in the DataONE federation and therefore cannot be retrieved by doi. - Either download this data locally and import using PEcAn's drag and drop feature, or search DataONE manually for another data identifier (e.g. pid or resource_map) Thank you for your patience.") - } else{ - return("data can be found in D1 federation") - } + print(result) } + if(is.null(result[1,1])){ # if there is no data available, result[1,1] will return a NULL value + return("doi does not resolve in the DataOne federation and therefore cannot be retrieved by doi. + Either download this data locally and import using PEcAn's drag and drop feature, or search DataOne manually for another data identifier. Thank you for your patience.") + } else{ + return("data can be found in D1 federation") + e } # end function # ----------------------------------------------------------------------------------------------------------------------------------------------------------------- From 39faa363c4899fdd3e8a2947c2e90ee2a7955071 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 25 Jul 2017 18:38:44 -0400 Subject: [PATCH 181/771] move partition_roots to data.land and adjust error messages --- models/dalec/R/write.configs.dalec.R | 34 ++---------------------- modules/data.land/R/partition_roots.R | 38 +++++++++++++++++++++++++++ 2 files changed, 40 insertions(+), 32 deletions(-) create mode 100644 modules/data.land/R/partition_roots.R diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 143302788d6..d6a00c358e2 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -74,36 +74,6 @@ convert.samples.DALEC <- function(trait.samples) { return(trait.samples) } # convert.samples.DALEC -####partition_roots: function to split root_carbon_content into fine and coarse roots by rtsize dimension at the .002 m threshold -partition_roots <- function(roots, rtsize){ - if(length(rtsize) > 1 && length(rtsize) == length(roots)){ - threshold <- .002 - epsilon <- .0005 - rtsize_thresh_idx <- which.min(sapply(rtsize-threshold,abs)) - rtsize_thresh <- rtsize[rtsize_thresh_idx] - if(abs(rtsize_thresh-threshold) > epsilon){ - PEcAn.utils::logger.error(paste("Closest rtsize to fine root threshold of", threshold, "m (", rtsize_thresh, - ") is greater than", epsilon, - "m off; fine roots can't be partitioned. Please improve rtsize dimensions or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.")) - return(NULL) - } else{ - fine.roots.temp <- sum(roots[1:rtsize_thresh_idx-1]) - coarse.roots.temp <- sum(roots) - fine.roots.temp - if(fine.roots.temp >= 0 && coarse.roots.temp >= 0){ - fine.roots <- fine.roots.temp - coarse.roots <- coarse.roots.temp - PEcAn.utils::logger.info("Using partitioned root values", fine.roots, "for fine and", coarse.roots, "for coarse.") - return(list(fine.roots = fine.roots, coarse.roots = coarse.roots)) - } else{ - PEcAn.utils::logger.error("Roots could not be partitioned (fine or coarse is less than 0); please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") - return(NULL) - } - } - } else { - PEcAn.utils::logger.error("Not enough levels of rtsize associated with root_carbon_content to partition roots; please provide finer resolution for root_carbon_content or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") - return(NULL) - } -} #--------------------------------------------------------------------------------------------------# ##' Writes a configuration files for your model @@ -171,12 +141,12 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { if("rtsize" %in% names(IC.nc$dim)){ PEcAn.utils::logger.info("DALEC IC: Attempting to partition root_carbon_content") rtsize <- IC.nc$dim$rtsize$vals - part_roots <- partition_roots(roots, rtsize) + part_roots <- PEcAn.data.land::partition_roots(roots, rtsize) if(!is.null(part_roots)){ fine.roots <- part_roots$fine.roots coarse.roots <- part_roots$coarse.roots } else{ - #couldn't partition roots; error messages handled by function + PEcAn.utils::logger.error("DALEC IC: could not partition roots; please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") } } else{ PEcAn.utils::logger.error("DALEC IC: Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") diff --git a/modules/data.land/R/partition_roots.R b/modules/data.land/R/partition_roots.R new file mode 100644 index 00000000000..d01966aa6bc --- /dev/null +++ b/modules/data.land/R/partition_roots.R @@ -0,0 +1,38 @@ +##' @name partition_roots +##' @title partition_roots +##' @description Given a vector of root size thresholds (lower bound of each) and a vector of corresponding root carbon values, partition_roots checks if the input can be partitioned along the .002 m threshold between fine and coarse roots and returns a list containing the summed values for fine and coarse. If there are fewer than two thresholds or none within .0005 m of .002 m, returns NULL. Meant to be used in conjunction with standard variable root_carbon_content with rtsize dimension, extracted from netcdf. +##' @export +##' +##' @param roots vector of root carbon values in kg C m-2 +##' @param rtsize vector of lower bounds of root size class thresholds in m, length greater than one and equal to roots. Must contain threshold within .0005 m of .002 m +##' @return list containing summed fine root and coarse root carbon (2 values) +##' @author Anne Thomas +##' +##' partition_roots: function to split root_carbon_content into fine and coarse roots by rtsize dimension at the .002 m threshold +partition_roots <- function(roots, rtsize){ + if(length(rtsize) > 1 && length(rtsize) == length(roots)){ + threshold <- .002 + epsilon <- .0005 + rtsize_thresh_idx <- which.min(sapply(rtsize-threshold,abs)) + rtsize_thresh <- rtsize[rtsize_thresh_idx] + if(abs(rtsize_thresh-threshold) > epsilon){ + PEcAn.utils::logger.error(paste("Closest rtsize to fine root threshold of", threshold, "m (", rtsize_thresh, + ") is greater than", epsilon, + "m off; fine roots can't be partitioned. Please improve rtsize dimensions.")) + return(NULL) + } else{ + fine.roots <- sum(roots[1:rtsize_thresh_idx-1]) + coarse.roots <- sum(roots) - fine.roots + if(fine.roots >= 0 && coarse.roots >= 0){ + PEcAn.utils::logger.info("Using partitioned root values", fine.roots, "for fine and", coarse.roots, "for coarse.") + return(list(fine.roots = fine.roots, coarse.roots = coarse.roots)) + } else{ + PEcAn.utils::logger.error("Roots could not be partitioned (fine or coarse is less than 0).") + return(NULL) + } + } + } else { + PEcAn.utils::logger.error("Inadequate or incorrect number of levels of rtsize associated with roots; please ensure roots and rtsize lengths match and are greater than 1.") + return(NULL) + } +} \ No newline at end of file From f2c464b127d14a0edd04fd7ee7f1079f868eb1e1 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 25 Jul 2017 19:02:25 -0400 Subject: [PATCH 182/771] partition_roots documentation --- modules/data.land/NAMESPACE | 1 + modules/data.land/man/partition_roots.Rd | 24 ++++++++++++++++++++++++ 2 files changed, 25 insertions(+) create mode 100644 modules/data.land/man/partition_roots.Rd diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index 40bf1781bcc..348ac3c10f9 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -22,6 +22,7 @@ export(match_pft) export(match_species_id) export(mpot2smoist) export(parse.MatrixNames) +export(partition_roots) export(plot2AGB) export(pool_ic_list2netcdf) export(sclass) diff --git a/modules/data.land/man/partition_roots.Rd b/modules/data.land/man/partition_roots.Rd new file mode 100644 index 00000000000..a883102640b --- /dev/null +++ b/modules/data.land/man/partition_roots.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/partition_roots.R +\name{partition_roots} +\alias{partition_roots} +\title{partition_roots} +\usage{ +partition_roots(roots, rtsize) +} +\arguments{ +\item{roots}{vector of root carbon values in kg C m-2} + +\item{rtsize}{vector of lower bounds of root size class thresholds in m, length greater than one and equal to roots. Must contain threshold within .0005 m of .002 m} +} +\value{ +list containing summed fine root and coarse root carbon (2 values) +} +\description{ +Given a vector of root size thresholds (lower bound of each) and a vector of corresponding root carbon values, partition_roots checks if the input can be partitioned along the .002 m threshold between fine and coarse roots and returns a list containing the summed values for fine and coarse. If there are fewer than two thresholds or none within .0005 m of .002 m, returns NULL. Meant to be used in conjunction with standard variable root_carbon_content with rtsize dimension, extracted from netcdf. +} +\author{ +Anne Thomas + +partition_roots: function to split root_carbon_content into fine and coarse roots by rtsize dimension at the .002 m threshold +} From 0489481762592d41710d9fcab6e0f625c5ab6234 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Tue, 25 Jul 2017 18:10:51 -0500 Subject: [PATCH 183/771] Reverting back to using input id instead of format id --- shiny/workflowPlot/server.R | 12 ++++++------ shiny/workflowPlot/ui.R | 13 +++++++------ 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 67ac66a3898..509a1396da7 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -105,11 +105,11 @@ server <- shinyServer(function(input, output, session) { observations<-PEcAn.benchmark::load_data(data.path = File_path, format= File_format, time.row = File_format$time.row, site = site, start_year = start.year, end_year = end.year) return(observations) } - getFileFormat <- function(bety,format.id){ -# getFileFormat <- function(bety,input.id){ + # getFileFormat <- function(bety,format.id){ + getFileFormat <- function(bety,input.id){ # Retaining the code for getting file format using inputRecordID - File_format <- PEcAn.DB::query.format.vars(bety = bety, format.id = format.id) - # File_format <- PEcAn.DB::query.format.vars(bety = bety, input.id = input.id) + # File_format <- PEcAn.DB::query.format.vars(bety = bety, format.id = format.id) + File_format <- PEcAn.DB::query.format.vars(bety = bety, input.id = input.id) return(File_format) } getSettingsFromWorkflowId <- function(bety,workflowID){ @@ -163,9 +163,9 @@ server <- shinyServer(function(input, output, session) { # Check if user wants to load external data # Similar to using event reactive if (input$load_data>0) { - File_format <- getFileFormat(bety,input$formatID) + # File_format <- getFileFormat(bety,input$formatID) # Retaining the code for getting file format using inputRecordID - # File_format <- getFileFormat(bety,input$inputRecordID) + File_format <- getFileFormat(bety,input$inputRecordID) ids_DF <- parse_ids_from_input_runID(input$all_run_id) settings <- getSettingsFromWorkflowId(bety,ids_DF$wID[1]) inFile <- input$fileUploaded diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 8b986819cbd..15c7ecbd6d4 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -23,12 +23,13 @@ ui <- shinyUI(fluidPage( min=0, max=100, value=80), tags$hr(), tags$hr(), - fileInput('fileUploaded', 'Choose file to upload data', - accept=c('text/csv', - 'text/comma-separated-values,text/plain', - '.csv')), - # textInput("inputRecordID", "Input Record ID for file", "1000011260"), - textInput("formatID", "Format ID for file (Default CSV)", "5000000002"), + fileInput('fileUploaded', 'Choose file to upload data' + # accept=c('text/csv', + # 'text/comma-separated-values,text/plain', + # '.csv') + ), + textInput("inputRecordID", "Input Record ID for file", "1000011260"), + # textInput("formatID", "Format ID for file (Default CSV)", "5000000002"), radioButtons("data_geom", "Plot Type (for loaded data)", c("Scatter Plot" = "point", "Line Chart" = "line"), From 7f58eec610171d9dc47bb75eef4896989b033014 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 25 Jul 2017 19:12:50 -0400 Subject: [PATCH 184/771] add unsaved changes --- modules/data.land/R/partition_roots.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/modules/data.land/R/partition_roots.R b/modules/data.land/R/partition_roots.R index d01966aa6bc..2d610a76544 100644 --- a/modules/data.land/R/partition_roots.R +++ b/modules/data.land/R/partition_roots.R @@ -8,12 +8,12 @@ ##' @return list containing summed fine root and coarse root carbon (2 values) ##' @author Anne Thomas ##' -##' partition_roots: function to split root_carbon_content into fine and coarse roots by rtsize dimension at the .002 m threshold partition_roots <- function(roots, rtsize){ if(length(rtsize) > 1 && length(rtsize) == length(roots)){ threshold <- .002 epsilon <- .0005 - rtsize_thresh_idx <- which.min(sapply(rtsize-threshold,abs)) + #find index of threshold in rtsize closest to .002 + rtsize_thresh_idx <- which.min(sapply(rtsize-threshold,abs)) rtsize_thresh <- rtsize[rtsize_thresh_idx] if(abs(rtsize_thresh-threshold) > epsilon){ PEcAn.utils::logger.error(paste("Closest rtsize to fine root threshold of", threshold, "m (", rtsize_thresh, @@ -21,6 +21,7 @@ partition_roots <- function(roots, rtsize){ "m off; fine roots can't be partitioned. Please improve rtsize dimensions.")) return(NULL) } else{ + #sum fine roots from lowest group through group below threshold and coarse from group including threshold to the highest fine.roots <- sum(roots[1:rtsize_thresh_idx-1]) coarse.roots <- sum(roots) - fine.roots if(fine.roots >= 0 && coarse.roots >= 0){ From f810bf9230cbe89dd06934277284e3d655ab9d57 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 25 Jul 2017 20:01:09 -0400 Subject: [PATCH 185/771] documentation update --- modules/data.land/man/partition_roots.Rd | 2 -- 1 file changed, 2 deletions(-) diff --git a/modules/data.land/man/partition_roots.Rd b/modules/data.land/man/partition_roots.Rd index a883102640b..40b0d9b96e2 100644 --- a/modules/data.land/man/partition_roots.Rd +++ b/modules/data.land/man/partition_roots.Rd @@ -19,6 +19,4 @@ Given a vector of root size thresholds (lower bound of each) and a vector of cor } \author{ Anne Thomas - -partition_roots: function to split root_carbon_content into fine and coarse roots by rtsize dimension at the .002 m threshold } From abdb91064f0649b39239c2b13585bd0e95ad03d5 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Wed, 26 Jul 2017 21:35:51 -0400 Subject: [PATCH 186/771] Roxygenized all four functions. --- modules/data.land/NAMESPACE | 4 +++ modules/data.land/R/DataONE_doi_download.R | 4 +-- modules/data.land/man/download.package.rm.Rd | 26 ++++++++++++++++++++ modules/data.land/man/format.identifier.Rd | 26 ++++++++++++++++++++ modules/data.land/man/get.resource.map.Rd | 19 ++++++++++++++ modules/data.land/man/id.resolveable.Rd | 21 ++++++++++++++++ 6 files changed, 98 insertions(+), 2 deletions(-) create mode 100644 modules/data.land/man/download.package.rm.Rd create mode 100644 modules/data.land/man/format.identifier.Rd create mode 100644 modules/data.land/man/get.resource.map.Rd create mode 100644 modules/data.land/man/id.resolveable.Rd diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index 348ac3c10f9..0a326622662 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -1,10 +1,12 @@ # Generated by roxygen2: do not edit by hand +S3method(format,identifier) export(Clean_Tucson) export(InventoryGrowthFusion) export(InventoryGrowthFusionDiagnostics) export(Read_Tucson) export(buildJAGSdata_InventoryRings) +export(download.package.rm) export(extract.stringCode) export(extract_FIA) export(extract_soil_nc) @@ -14,8 +16,10 @@ export(find.land) export(from.Tag) export(from.TreeCode) export(get.attributes) +export(get.resource.map) export(get.soil) export(ic_process) +export(id.resolveable) export(load_veg) export(matchInventoryRings) export(match_pft) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 8b5420d29e3..eee00b5b663 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -9,7 +9,7 @@ #' @return returns the id in the proper format for querying the DataONE Federation (using solrQuery syntax) #' @export #' -#' @author Liam P Burke, \email{lpburke@bu.edu} +#' @author Liam P Burke, \email{lpburke@@bu.edu} #' #' @examples format.identifier = function(id){ @@ -46,7 +46,7 @@ id.resolveable = function(id, return_result = TRUE, CNode = "PROD"){ Either download this data locally and import using PEcAn's drag and drop feature, or search DataOne manually for another data identifier. Thank you for your patience.") } else{ return("data can be found in D1 federation") - e + } } # end function # ----------------------------------------------------------------------------------------------------------------------------------------------------------------- diff --git a/modules/data.land/man/download.package.rm.Rd b/modules/data.land/man/download.package.rm.Rd new file mode 100644 index 00000000000..48b6e7bd563 --- /dev/null +++ b/modules/data.land/man/download.package.rm.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/DataONE_doi_download.R +\name{download.package.rm} +\alias{download.package.rm} +\title{download.packages} +\usage{ +download.package.rm(resource_map, directory, CNode = "PROD", + download_format = "application/bagit-097", overwrite_directory = TRUE) +} +\arguments{ +\item{resource_map}{the resource map that corresponds to the given data package} + +\item{directory}{location that download.packages places the data} + +\item{CNode}{defaults to "PROD"} + +\item{download_format}{typically "application/bagit-097". Other possible formats currently unknown.} + +\item{overwrite_directory}{boolean that indicates whether or not the function should overwrite the directory} +} +\value{ +results of download +} +\description{ +download.packages +} diff --git a/modules/data.land/man/format.identifier.Rd b/modules/data.land/man/format.identifier.Rd new file mode 100644 index 00000000000..754f975038a --- /dev/null +++ b/modules/data.land/man/format.identifier.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/DataONE_doi_download.R +\name{format.identifier} +\alias{format.identifier} +\title{Functions to determine if data can be found by doi in R +Author: Liam Burke +Code draws heavily on dataoneR package for communication with the DataONE federation +format.identifier} +\usage{ +\method{format}{identifier}(id) +} +\arguments{ +\item{id}{the doi or other identifier linked to the package in DataONE} +} +\value{ +returns the id in the proper format for querying the DataONE Federation (using solrQuery syntax) +} +\description{ +Functions to determine if data can be found by doi in R +Author: Liam Burke +Code draws heavily on dataoneR package for communication with the DataONE federation +format.identifier +} +\author{ +Liam P Burke, \email{lpburke@bu.edu} +} diff --git a/modules/data.land/man/get.resource.map.Rd b/modules/data.land/man/get.resource.map.Rd new file mode 100644 index 00000000000..78afcf6c189 --- /dev/null +++ b/modules/data.land/man/get.resource.map.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/DataONE_doi_download.R +\name{get.resource.map} +\alias{get.resource.map} +\title{get.resource.map} +\usage{ +get.resource.map(id, CNode = "PROD") +} +\arguments{ +\item{id}{the doi or other identifier linked to the package in DataONE} + +\item{CNode}{default is "PROD"} +} +\value{ +return the resource_map or a message indicating that there is no corresponding resource_map for the given id +} +\description{ +get.resource.map +} diff --git a/modules/data.land/man/id.resolveable.Rd b/modules/data.land/man/id.resolveable.Rd new file mode 100644 index 00000000000..2e643c0cc70 --- /dev/null +++ b/modules/data.land/man/id.resolveable.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/DataONE_doi_download.R +\name{id.resolveable} +\alias{id.resolveable} +\title{id.resolveable} +\usage{ +id.resolveable(id, return_result = TRUE, CNode = "PROD") +} +\arguments{ +\item{id}{the doi or other identifier linked to the package in DataONE} + +\item{return_result}{boolean that returns or suppresses result of query. defaults to TRUE.} + +\item{CNode}{CNode="PROD"} +} +\value{ +returns message indicating wether or not the id resolves to data in the DataONE federation +} +\description{ +id.resolveable +} From 322d05af3d8e2ed348ad8c2dc9859ed6721dfe88 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Wed, 26 Jul 2017 22:31:11 -0400 Subject: [PATCH 187/771] accidentally changed package from dataone to DataONE. Fixed this error. --- modules/data.land/R/DataONE_doi_download.R | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index eee00b5b663..feb6bf8b1dc 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -33,9 +33,9 @@ format.identifier = function(id){ id.resolveable = function(id, return_result = TRUE, CNode = "PROD"){ format.identifier(id) # reformat the id in solr format - cn <- DataONE::CNode(CNode) + cn <- dataone::CNode(CNode) queryParams <- list(q=doi1, rows="5") - result <- DataONE::query(cn, solrQuery = queryParams, as = "data.frame") # return query results as a data.frame + result <- dataone::query(cn, solrQuery = queryParams, as = "data.frame") # return query results as a data.frame if(return_result == TRUE){ # option that displays data.frame of query print(result) @@ -61,10 +61,10 @@ id.resolveable = function(id, return_result = TRUE, CNode = "PROD"){ #' #' @examples get.resource.map = function(id, CNode = "PROD"){ - cn <- DataONE::CNode(CNode) - locations <- DataONE::resolve(cn, pid = id) + cn <- dataone::CNode(CNode) + locations <- dataone::resolve(cn, pid = id) mnId <<- locations$data[1,"nodeIdentifier"] # store mnId in global environment - mn <<- DataONE::getMNode(cn, mnId) # store mn in global environment + mn <<- dataone::getMNode(cn, mnId) # store mn in global environment format.identifier(id) # format the identifier in solr Query format queryParamList <- list(q=doi1, fl="resourceMap") # custom query for the resourceMap @@ -96,13 +96,13 @@ get.resource.map = function(id, CNode = "PROD"){ download.package.rm = function(resource_map, directory, CNode = "PROD", download_format = "application/bagit-097", overwrite_directory = TRUE){ # Finding the mnId (query) - cn <- DataONE::CNode(CNode) - locations <- DataONE::resolve(cn, pid = resource_map) + cn <- dataone::CNode(CNode) + locations <- dataone::resolve(cn, pid = resource_map) mnId <<- locations$data[1,"nodeIdentifier"] # download the bagitFile - mn <<- DataONE::getMNode(cn, mnId) - bagitFile <<- DataONE::getPackage(mn, id = resource_map, format = download_format) + mn <<- dataone::getMNode(cn, mnId) + bagitFile <<- dataone::getPackage(mn, id = resource_map, format = download_format) bagitFile From c16126550d8a4ce6ff2ec66f79aff1defe4d4771 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Wed, 26 Jul 2017 22:32:50 -0400 Subject: [PATCH 188/771] caught another DataONE -> dataone error --- modules/data.land/R/DataONE_doi_download.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index feb6bf8b1dc..12188b64c70 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -68,7 +68,7 @@ get.resource.map = function(id, CNode = "PROD"){ format.identifier(id) # format the identifier in solr Query format queryParamList <- list(q=doi1, fl="resourceMap") # custom query for the resourceMap - resource_map_df <- DataONE::query(cn, solrQuery = queryParamList, as="data.frame") + resource_map_df <- dataone::query(cn, solrQuery = queryParamList, as="data.frame") resource_map <<- resource_map_df[1,1] # store resource map in global env. resource map is always in resource_map_df[1,1] if (is.null(resource_map_df[1,1])){ # inform user if id/ doi has a corresponding resource_map or if this needs to be found manually From ca7c3e5429bcd9c2d89d6563aee92fbc312232ca Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 27 Jul 2017 11:48:01 -0400 Subject: [PATCH 189/771] Basic drag and drop functionality for PEcAn web --- web/drag.and.drop.upload | 141 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 141 insertions(+) create mode 100644 web/drag.and.drop.upload diff --git a/web/drag.and.drop.upload b/web/drag.and.drop.upload new file mode 100644 index 00000000000..580410c874b --- /dev/null +++ b/web/drag.and.drop.upload @@ -0,0 +1,141 @@ + + $min_upload_level) { + header( "Location: index.php"); + close_database(); + exit; +} + +Drag and drop, automatic upload + +
    +
    +
    + +

    File API & FileReader API not supported

    +

    XHR2's FormData is not supported

    +

    XHR2's upload progress isn't supported

    +

    Upload progress: 0

    +

    Drag an image from your desktop on to the drop zone above to see the browser both render the preview, but also upload automatically to this server.

    +
    + \ No newline at end of file From fca2490e8ee46203cf53d397052507de4e9168a4 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 27 Jul 2017 16:16:59 -0400 Subject: [PATCH 190/771] changed function names from "." to "_" --- modules/data.land/R/DataONE_doi_download.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 12188b64c70..d518ad1b76c 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -12,7 +12,7 @@ #' @author Liam P Burke, \email{lpburke@@bu.edu} #' #' @examples -format.identifier = function(id){ +format_identifier = function(id){ doi.template <- 'id:"_"' # solr format doi1 <<- base::gsub("_", id, doi.template) # replace "_" with the doi or id and store in global environment return(doi1) @@ -30,8 +30,8 @@ format.identifier = function(id){ #' @export #' #' @examples -id.resolveable = function(id, return_result = TRUE, CNode = "PROD"){ - format.identifier(id) # reformat the id in solr format +id_resolveable = function(id, return_result = TRUE, CNode = "PROD"){ + format_identifier(id) # reformat the id in solr format cn <- dataone::CNode(CNode) queryParams <- list(q=doi1, rows="5") @@ -60,13 +60,13 @@ id.resolveable = function(id, return_result = TRUE, CNode = "PROD"){ #' @export #' #' @examples -get.resource.map = function(id, CNode = "PROD"){ +get_resource_map = function(id, CNode = "PROD"){ cn <- dataone::CNode(CNode) locations <- dataone::resolve(cn, pid = id) mnId <<- locations$data[1,"nodeIdentifier"] # store mnId in global environment mn <<- dataone::getMNode(cn, mnId) # store mn in global environment - format.identifier(id) # format the identifier in solr Query format + format_identifier(id) # format the identifier in solr Query format queryParamList <- list(q=doi1, fl="resourceMap") # custom query for the resourceMap resource_map_df <- dataone::query(cn, solrQuery = queryParamList, as="data.frame") resource_map <<- resource_map_df[1,1] # store resource map in global env. resource map is always in resource_map_df[1,1] @@ -93,7 +93,7 @@ get.resource.map = function(id, CNode = "PROD"){ #' @export #' #' @examples -download.package.rm = function(resource_map, directory, CNode = "PROD", download_format = "application/bagit-097", +download_package_rm = function(resource_map, directory, CNode = "PROD", download_format = "application/bagit-097", overwrite_directory = TRUE){ # Finding the mnId (query) cn <- dataone::CNode(CNode) From 5a2871dcb947781b78dcf4dac6bd8413e2901529 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 27 Jul 2017 16:19:30 -0400 Subject: [PATCH 191/771] set exdir to directory instead of "downloads" --- modules/data.land/R/DataONE_doi_download.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index d518ad1b76c..8bc6a177ab1 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -106,8 +106,8 @@ download_package_rm = function(resource_map, directory, CNode = "PROD", download bagitFile - zip_contents <<- utils::unzip(bagitFile, files = NULL, list = TRUE, overwrite = TRUE, # list files in bagitFile - junkpaths = FALSE, exdir = "downloads", unzip = "internal", + zip_contents <<- utils::unzip(bagitFile, files = NULL, list = TRUE, overwrite = overwrite_directory, # list files in bagitFile + junkpaths = FALSE, exdir = directory, unzip = "internal", setTimes = FALSE) utils::unzip(bagitFile, files = NULL, list = FALSE, overwrite = overwrite_directory, # Unzip the bagitFile and store in directory specified under exdir From c7dee5e15b68e2d05c7ef600695956d8de5f3fa4 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 27 Jul 2017 16:22:27 -0400 Subject: [PATCH 192/771] delete 'bagitFile' and storing data in local environment as zip_contents. Now function only stores data to exdir. --- modules/data.land/R/DataONE_doi_download.R | 6 ------ 1 file changed, 6 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 8bc6a177ab1..5a0a94b4efb 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -103,12 +103,6 @@ download_package_rm = function(resource_map, directory, CNode = "PROD", download # download the bagitFile mn <<- dataone::getMNode(cn, mnId) bagitFile <<- dataone::getPackage(mn, id = resource_map, format = download_format) - bagitFile - - - zip_contents <<- utils::unzip(bagitFile, files = NULL, list = TRUE, overwrite = overwrite_directory, # list files in bagitFile - junkpaths = FALSE, exdir = directory, unzip = "internal", - setTimes = FALSE) utils::unzip(bagitFile, files = NULL, list = FALSE, overwrite = overwrite_directory, # Unzip the bagitFile and store in directory specified under exdir junkpaths = FALSE, exdir = directory, unzip = "internal", From 157a2bb83246c68e55e086f23701b4a325dcb494 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 27 Jul 2017 16:37:40 -0400 Subject: [PATCH 193/771] store the unzip in zip_contents so the return passes. This is a TEMPORARY fix until we pick a more mreaningful return. --- modules/data.land/R/DataONE_doi_download.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 5a0a94b4efb..4abac9acf6f 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -104,7 +104,7 @@ download_package_rm = function(resource_map, directory, CNode = "PROD", download mn <<- dataone::getMNode(cn, mnId) bagitFile <<- dataone::getPackage(mn, id = resource_map, format = download_format) - utils::unzip(bagitFile, files = NULL, list = FALSE, overwrite = overwrite_directory, # Unzip the bagitFile and store in directory specified under exdir + zip_contents <<- utils::unzip(bagitFile, files = NULL, list = FALSE, overwrite = overwrite_directory, # Unzip the bagitFile and store in directory specified under exdir junkpaths = FALSE, exdir = directory, unzip = "internal", setTimes = FALSE) return(zip_contents) From 16a4933db208099874b6be83a2408e5c0cbf91cb Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 27 Jul 2017 18:42:50 -0400 Subject: [PATCH 194/771] Updated descriptions for all functions --- modules/data.land/NAMESPACE | 8 ++++---- modules/data.land/R/DataONE_doi_download.R | 14 +++++++++----- ...wnload.package.rm.Rd => download_package_rm.Rd} | 6 +++--- .../{format.identifier.Rd => format_identifier.Rd} | 6 +++--- .../{get.resource.map.Rd => get_resource_map.Rd} | 6 +++--- .../man/{id.resolveable.Rd => id_resolveable.Rd} | 6 +++--- modules/data.land/man/subset.layer.Rd | 4 ++-- 7 files changed, 27 insertions(+), 23 deletions(-) rename modules/data.land/man/{download.package.rm.Rd => download_package_rm.Rd} (85%) rename modules/data.land/man/{format.identifier.Rd => format_identifier.Rd} (89%) rename modules/data.land/man/{get.resource.map.Rd => get_resource_map.Rd} (82%) rename modules/data.land/man/{id.resolveable.Rd => id_resolveable.Rd} (82%) diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index 0a326622662..ac2229d0641 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -1,25 +1,25 @@ # Generated by roxygen2: do not edit by hand -S3method(format,identifier) export(Clean_Tucson) export(InventoryGrowthFusion) export(InventoryGrowthFusionDiagnostics) export(Read_Tucson) export(buildJAGSdata_InventoryRings) -export(download.package.rm) +export(download_package_rm) export(extract.stringCode) export(extract_FIA) export(extract_soil_nc) export(extract_veg) export(fia.to.psscss) export(find.land) +export(format_identifier) export(from.Tag) export(from.TreeCode) export(get.attributes) -export(get.resource.map) export(get.soil) +export(get_resource_map) export(ic_process) -export(id.resolveable) +export(id_resolveable) export(load_veg) export(matchInventoryRings) export(match_pft) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 4abac9acf6f..1328bab1a0f 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -1,6 +1,6 @@ -##' Functions to determine if data can be found by doi in R -##' Author: Liam Burke -##' Code draws heavily on dataoneR package for communication with the DataONE federation +## Functions to determine if data can be found by doi in R +## Author: Liam Burke +## Code draws heavily on dataoneR package for communication with the DataONE federation #' format.identifier #' @@ -10,6 +10,7 @@ #' @export #' #' @author Liam P Burke, \email{lpburke@@bu.edu} +#' @description This function is for formatting purposes. It simply inserts the doi or id that the user wishes to query into Solr format so that it is compatible with the dataoneR query functionality in the PEcAn function #' #' @examples format_identifier = function(id){ @@ -25,8 +26,9 @@ format_identifier = function(id){ #' @param id the doi or other identifier linked to the package in DataONE #' @param CNode CNode="PROD" #' @param return_result boolean that returns or suppresses result of query. defaults to TRUE. -#' -#' @return returns message indicating wether or not the id resolves to data in the DataONE federation +#' @description Uses dataone::query from dataoneR to query DataONE. Prints result if data exists +#' +#' @return returns message indicating wether or not the id resolves to data in the DataONE federation and information about said data. #' @export #' #' @examples @@ -55,6 +57,7 @@ id_resolveable = function(id, return_result = TRUE, CNode = "PROD"){ #' #' @param id the doi or other identifier linked to the package in DataONE #' @param CNode default is "PROD" +#' @description Locates data in DataONE and returns the resource_map or a message indicating that there is no corresponding resource_map for the given id #' #' @return return the resource_map or a message indicating that there is no corresponding resource_map for the given id #' @export @@ -89,6 +92,7 @@ get_resource_map = function(id, CNode = "PROD"){ #' @param overwrite_directory boolean that indicates whether or not the function should overwrite the directory #' @param directory location that download.packages places the data #' +#' @description Uses resource_map and dataone::getPackage to download the data into a BagItFile. Then utils::unzip unzips the data and stores in the user's directory. #' @return results of download #' @export #' diff --git a/modules/data.land/man/download.package.rm.Rd b/modules/data.land/man/download_package_rm.Rd similarity index 85% rename from modules/data.land/man/download.package.rm.Rd rename to modules/data.land/man/download_package_rm.Rd index 48b6e7bd563..998f7d1c2d5 100644 --- a/modules/data.land/man/download.package.rm.Rd +++ b/modules/data.land/man/download_package_rm.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/DataONE_doi_download.R -\name{download.package.rm} -\alias{download.package.rm} +\name{download_package_rm} +\alias{download_package_rm} \title{download.packages} \usage{ -download.package.rm(resource_map, directory, CNode = "PROD", +download_package_rm(resource_map, directory, CNode = "PROD", download_format = "application/bagit-097", overwrite_directory = TRUE) } \arguments{ diff --git a/modules/data.land/man/format.identifier.Rd b/modules/data.land/man/format_identifier.Rd similarity index 89% rename from modules/data.land/man/format.identifier.Rd rename to modules/data.land/man/format_identifier.Rd index 754f975038a..98fb9d67be6 100644 --- a/modules/data.land/man/format.identifier.Rd +++ b/modules/data.land/man/format_identifier.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/DataONE_doi_download.R -\name{format.identifier} -\alias{format.identifier} +\name{format_identifier} +\alias{format_identifier} \title{Functions to determine if data can be found by doi in R Author: Liam Burke Code draws heavily on dataoneR package for communication with the DataONE federation format.identifier} \usage{ -\method{format}{identifier}(id) +format_identifier(id) } \arguments{ \item{id}{the doi or other identifier linked to the package in DataONE} diff --git a/modules/data.land/man/get.resource.map.Rd b/modules/data.land/man/get_resource_map.Rd similarity index 82% rename from modules/data.land/man/get.resource.map.Rd rename to modules/data.land/man/get_resource_map.Rd index 78afcf6c189..8d8b75f8a5f 100644 --- a/modules/data.land/man/get.resource.map.Rd +++ b/modules/data.land/man/get_resource_map.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/DataONE_doi_download.R -\name{get.resource.map} -\alias{get.resource.map} +\name{get_resource_map} +\alias{get_resource_map} \title{get.resource.map} \usage{ -get.resource.map(id, CNode = "PROD") +get_resource_map(id, CNode = "PROD") } \arguments{ \item{id}{the doi or other identifier linked to the package in DataONE} diff --git a/modules/data.land/man/id.resolveable.Rd b/modules/data.land/man/id_resolveable.Rd similarity index 82% rename from modules/data.land/man/id.resolveable.Rd rename to modules/data.land/man/id_resolveable.Rd index 2e643c0cc70..cb020c3da80 100644 --- a/modules/data.land/man/id.resolveable.Rd +++ b/modules/data.land/man/id_resolveable.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/DataONE_doi_download.R -\name{id.resolveable} -\alias{id.resolveable} +\name{id_resolveable} +\alias{id_resolveable} \title{id.resolveable} \usage{ -id.resolveable(id, return_result = TRUE, CNode = "PROD") +id_resolveable(id, return_result = TRUE, CNode = "PROD") } \arguments{ \item{id}{the doi or other identifier linked to the package in DataONE} diff --git a/modules/data.land/man/subset.layer.Rd b/modules/data.land/man/subset.layer.Rd index 5a6de814fe2..c148312246f 100644 --- a/modules/data.land/man/subset.layer.Rd +++ b/modules/data.land/man/subset.layer.Rd @@ -5,8 +5,8 @@ \title{Function to subset and clip a GIS vector or raster layer by a bounding box or clip/subset layer (e.g. shapefile/KML)} \usage{ -\method{subset}{layer}(file, coords = NULL, sub.layer = NULL, - clip = FALSE, out.dir = NULL, out.name = NULL) +subset.layer(file, coords = NULL, sub.layer = NULL, clip = FALSE, + out.dir = NULL, out.name = NULL) } \arguments{ \item{file}{input file to be subset} From 2d838fd7421040c73f26c791d58e208a24ab435c Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 27 Jul 2017 18:45:58 -0400 Subject: [PATCH 195/771] removed unnecessary header from roxygen doc --- modules/data.land/R/DataONE_doi_download.R | 4 ---- modules/data.land/man/download_package_rm.Rd | 2 +- modules/data.land/man/format_identifier.Rd | 10 ++-------- modules/data.land/man/get_resource_map.Rd | 2 +- modules/data.land/man/id_resolveable.Rd | 4 ++-- modules/data.land/man/subset.layer.Rd | 4 ++-- 6 files changed, 8 insertions(+), 18 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 1328bab1a0f..db1551f0642 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -1,7 +1,3 @@ -## Functions to determine if data can be found by doi in R -## Author: Liam Burke -## Code draws heavily on dataoneR package for communication with the DataONE federation - #' format.identifier #' #' @param id the doi or other identifier linked to the package in DataONE diff --git a/modules/data.land/man/download_package_rm.Rd b/modules/data.land/man/download_package_rm.Rd index 998f7d1c2d5..2b8d16fd174 100644 --- a/modules/data.land/man/download_package_rm.Rd +++ b/modules/data.land/man/download_package_rm.Rd @@ -22,5 +22,5 @@ download_package_rm(resource_map, directory, CNode = "PROD", results of download } \description{ -download.packages +Uses resource_map and dataone::getPackage to download the data into a BagItFile. Then utils::unzip unzips the data and stores in the user's directory. } diff --git a/modules/data.land/man/format_identifier.Rd b/modules/data.land/man/format_identifier.Rd index 98fb9d67be6..c5a44550e79 100644 --- a/modules/data.land/man/format_identifier.Rd +++ b/modules/data.land/man/format_identifier.Rd @@ -2,10 +2,7 @@ % Please edit documentation in R/DataONE_doi_download.R \name{format_identifier} \alias{format_identifier} -\title{Functions to determine if data can be found by doi in R -Author: Liam Burke -Code draws heavily on dataoneR package for communication with the DataONE federation -format.identifier} +\title{format.identifier} \usage{ format_identifier(id) } @@ -16,10 +13,7 @@ format_identifier(id) returns the id in the proper format for querying the DataONE Federation (using solrQuery syntax) } \description{ -Functions to determine if data can be found by doi in R -Author: Liam Burke -Code draws heavily on dataoneR package for communication with the DataONE federation -format.identifier +This function is for formatting purposes. It simply inserts the doi or id that the user wishes to query into Solr format so that it is compatible with the dataoneR query functionality in the PEcAn function } \author{ Liam P Burke, \email{lpburke@bu.edu} diff --git a/modules/data.land/man/get_resource_map.Rd b/modules/data.land/man/get_resource_map.Rd index 8d8b75f8a5f..50fedc7b75d 100644 --- a/modules/data.land/man/get_resource_map.Rd +++ b/modules/data.land/man/get_resource_map.Rd @@ -15,5 +15,5 @@ get_resource_map(id, CNode = "PROD") return the resource_map or a message indicating that there is no corresponding resource_map for the given id } \description{ -get.resource.map +Locates data in DataONE and returns the resource_map or a message indicating that there is no corresponding resource_map for the given id } diff --git a/modules/data.land/man/id_resolveable.Rd b/modules/data.land/man/id_resolveable.Rd index cb020c3da80..906ac489b59 100644 --- a/modules/data.land/man/id_resolveable.Rd +++ b/modules/data.land/man/id_resolveable.Rd @@ -14,8 +14,8 @@ id_resolveable(id, return_result = TRUE, CNode = "PROD") \item{CNode}{CNode="PROD"} } \value{ -returns message indicating wether or not the id resolves to data in the DataONE federation +returns message indicating wether or not the id resolves to data in the DataONE federation and information about said data. } \description{ -id.resolveable +Uses dataone::query from dataoneR to query DataONE. Prints result if data exists } diff --git a/modules/data.land/man/subset.layer.Rd b/modules/data.land/man/subset.layer.Rd index c148312246f..5a6de814fe2 100644 --- a/modules/data.land/man/subset.layer.Rd +++ b/modules/data.land/man/subset.layer.Rd @@ -5,8 +5,8 @@ \title{Function to subset and clip a GIS vector or raster layer by a bounding box or clip/subset layer (e.g. shapefile/KML)} \usage{ -subset.layer(file, coords = NULL, sub.layer = NULL, clip = FALSE, - out.dir = NULL, out.name = NULL) +\method{subset}{layer}(file, coords = NULL, sub.layer = NULL, + clip = FALSE, out.dir = NULL, out.name = NULL) } \arguments{ \item{file}{input file to be subset} From 1950bd3cf1046c4c2f656d0f9c4101f3edab9662 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 27 Jul 2017 18:47:18 -0400 Subject: [PATCH 196/771] Roxygenize functions --- modules/data.land/man/subset.layer.Rd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.land/man/subset.layer.Rd b/modules/data.land/man/subset.layer.Rd index 5a6de814fe2..c148312246f 100644 --- a/modules/data.land/man/subset.layer.Rd +++ b/modules/data.land/man/subset.layer.Rd @@ -5,8 +5,8 @@ \title{Function to subset and clip a GIS vector or raster layer by a bounding box or clip/subset layer (e.g. shapefile/KML)} \usage{ -\method{subset}{layer}(file, coords = NULL, sub.layer = NULL, - clip = FALSE, out.dir = NULL, out.name = NULL) +subset.layer(file, coords = NULL, sub.layer = NULL, clip = FALSE, + out.dir = NULL, out.name = NULL) } \arguments{ \item{file}{input file to be subset} From 973cbd7227c1fcabb4377a2a530b1e678517ead7 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 27 Jul 2017 19:01:30 -0400 Subject: [PATCH 197/771] Coordenated titles for all functions ("_" vs ".") --- modules/data.land/R/DataONE_doi_download.R | 8 ++++---- modules/data.land/man/download_package_rm.Rd | 2 +- modules/data.land/man/format_identifier.Rd | 2 +- modules/data.land/man/get_resource_map.Rd | 2 +- modules/data.land/man/id_resolveable.Rd | 2 +- modules/data.land/man/subset.layer.Rd | 4 ++-- 6 files changed, 10 insertions(+), 10 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index db1551f0642..0e33e916db9 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -1,4 +1,4 @@ -#' format.identifier +#' format_identifier #' #' @param id the doi or other identifier linked to the package in DataONE #' @@ -17,7 +17,7 @@ format_identifier = function(id){ # ----------------------------------------------------------------------------------------------------------------------------------------------------------------- -#' id.resolveable +#' id_resolveable #' #' @param id the doi or other identifier linked to the package in DataONE #' @param CNode CNode="PROD" @@ -49,7 +49,7 @@ id_resolveable = function(id, return_result = TRUE, CNode = "PROD"){ # ----------------------------------------------------------------------------------------------------------------------------------------------------------------- -#' get.resource.map +#' get_resource.map #' #' @param id the doi or other identifier linked to the package in DataONE #' @param CNode default is "PROD" @@ -80,7 +80,7 @@ get_resource_map = function(id, CNode = "PROD"){ # ----------------------------------------------------------------------------------------------------------------------------------------------------------------- -#' download.packages +#' download_packages #' #' @param resource_map the resource map that corresponds to the given data package #' @param CNode defaults to "PROD" diff --git a/modules/data.land/man/download_package_rm.Rd b/modules/data.land/man/download_package_rm.Rd index 2b8d16fd174..895927451fd 100644 --- a/modules/data.land/man/download_package_rm.Rd +++ b/modules/data.land/man/download_package_rm.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/DataONE_doi_download.R \name{download_package_rm} \alias{download_package_rm} -\title{download.packages} +\title{download_packages} \usage{ download_package_rm(resource_map, directory, CNode = "PROD", download_format = "application/bagit-097", overwrite_directory = TRUE) diff --git a/modules/data.land/man/format_identifier.Rd b/modules/data.land/man/format_identifier.Rd index c5a44550e79..69a559cd50c 100644 --- a/modules/data.land/man/format_identifier.Rd +++ b/modules/data.land/man/format_identifier.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/DataONE_doi_download.R \name{format_identifier} \alias{format_identifier} -\title{format.identifier} +\title{format_identifier} \usage{ format_identifier(id) } diff --git a/modules/data.land/man/get_resource_map.Rd b/modules/data.land/man/get_resource_map.Rd index 50fedc7b75d..d7628ae5cb1 100644 --- a/modules/data.land/man/get_resource_map.Rd +++ b/modules/data.land/man/get_resource_map.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/DataONE_doi_download.R \name{get_resource_map} \alias{get_resource_map} -\title{get.resource.map} +\title{get_resource.map} \usage{ get_resource_map(id, CNode = "PROD") } diff --git a/modules/data.land/man/id_resolveable.Rd b/modules/data.land/man/id_resolveable.Rd index 906ac489b59..ef22e673e02 100644 --- a/modules/data.land/man/id_resolveable.Rd +++ b/modules/data.land/man/id_resolveable.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/DataONE_doi_download.R \name{id_resolveable} \alias{id_resolveable} -\title{id.resolveable} +\title{id_resolveable} \usage{ id_resolveable(id, return_result = TRUE, CNode = "PROD") } diff --git a/modules/data.land/man/subset.layer.Rd b/modules/data.land/man/subset.layer.Rd index c148312246f..5a6de814fe2 100644 --- a/modules/data.land/man/subset.layer.Rd +++ b/modules/data.land/man/subset.layer.Rd @@ -5,8 +5,8 @@ \title{Function to subset and clip a GIS vector or raster layer by a bounding box or clip/subset layer (e.g. shapefile/KML)} \usage{ -subset.layer(file, coords = NULL, sub.layer = NULL, clip = FALSE, - out.dir = NULL, out.name = NULL) +\method{subset}{layer}(file, coords = NULL, sub.layer = NULL, + clip = FALSE, out.dir = NULL, out.name = NULL) } \arguments{ \item{file}{input file to be subset} From 49b99b0737ee7c71d5bfef5e4081e21ba27558be Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 27 Jul 2017 19:02:16 -0400 Subject: [PATCH 198/771] subset.layer.Rd --- modules/data.land/man/subset.layer.Rd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.land/man/subset.layer.Rd b/modules/data.land/man/subset.layer.Rd index 5a6de814fe2..c148312246f 100644 --- a/modules/data.land/man/subset.layer.Rd +++ b/modules/data.land/man/subset.layer.Rd @@ -5,8 +5,8 @@ \title{Function to subset and clip a GIS vector or raster layer by a bounding box or clip/subset layer (e.g. shapefile/KML)} \usage{ -\method{subset}{layer}(file, coords = NULL, sub.layer = NULL, - clip = FALSE, out.dir = NULL, out.name = NULL) +subset.layer(file, coords = NULL, sub.layer = NULL, clip = FALSE, + out.dir = NULL, out.name = NULL) } \arguments{ \item{file}{input file to be subset} From 070cb24fda7cc029d12d8635db9b0721ce16b1c7 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 27 Jul 2017 19:05:27 -0400 Subject: [PATCH 199/771] get_resource_map <- get_resource.map --- modules/data.land/R/DataONE_doi_download.R | 2 +- modules/data.land/man/subset.layer.Rd | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/data.land/R/DataONE_doi_download.R b/modules/data.land/R/DataONE_doi_download.R index 0e33e916db9..3bebebb33be 100644 --- a/modules/data.land/R/DataONE_doi_download.R +++ b/modules/data.land/R/DataONE_doi_download.R @@ -49,7 +49,7 @@ id_resolveable = function(id, return_result = TRUE, CNode = "PROD"){ # ----------------------------------------------------------------------------------------------------------------------------------------------------------------- -#' get_resource.map +#' get_resource_map #' #' @param id the doi or other identifier linked to the package in DataONE #' @param CNode default is "PROD" diff --git a/modules/data.land/man/subset.layer.Rd b/modules/data.land/man/subset.layer.Rd index c148312246f..5a6de814fe2 100644 --- a/modules/data.land/man/subset.layer.Rd +++ b/modules/data.land/man/subset.layer.Rd @@ -5,8 +5,8 @@ \title{Function to subset and clip a GIS vector or raster layer by a bounding box or clip/subset layer (e.g. shapefile/KML)} \usage{ -subset.layer(file, coords = NULL, sub.layer = NULL, clip = FALSE, - out.dir = NULL, out.name = NULL) +\method{subset}{layer}(file, coords = NULL, sub.layer = NULL, + clip = FALSE, out.dir = NULL, out.name = NULL) } \arguments{ \item{file}{input file to be subset} From f3fbb7808af3294eab0c480ffad047d809baa7c1 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Fri, 28 Jul 2017 15:28:43 -0400 Subject: [PATCH 200/771] fixed another "." to "_" error --- modules/data.land/man/get_resource_map.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/man/get_resource_map.Rd b/modules/data.land/man/get_resource_map.Rd index d7628ae5cb1..c496c513637 100644 --- a/modules/data.land/man/get_resource_map.Rd +++ b/modules/data.land/man/get_resource_map.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/DataONE_doi_download.R \name{get_resource_map} \alias{get_resource_map} -\title{get_resource.map} +\title{get_resource_map} \usage{ get_resource_map(id, CNode = "PROD") } From dd8345cbe7a168d123860e4524d6f3401a2a02aa Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sat, 29 Jul 2017 13:16:14 -0500 Subject: [PATCH 201/771] Query unique site ids --- shiny/workflowPlot/helper.R | 36 +++++++++++++++++++++++++++++++++--- shiny/workflowPlot/server.R | 21 ++++++++++++++++++--- shiny/workflowPlot/ui.R | 14 ++++++++------ 3 files changed, 59 insertions(+), 12 deletions(-) diff --git a/shiny/workflowPlot/helper.R b/shiny/workflowPlot/helper.R index 5dfbdcd0b7f..c4f2c9d28c4 100644 --- a/shiny/workflowPlot/helper.R +++ b/shiny/workflowPlot/helper.R @@ -10,6 +10,36 @@ isInstalled <- function(mypkg){ is.element(mypkg, installed.packages()[,1]) } checkAndDownload(c('plotly','scales','dplyr')) - -# write.csv(globalDF,file='/home/carya/pecan/shiny/workflowPlot/sampleFile.csv', -# quote = FALSE,sep = ',',col.names = TRUE,row.names=FALSE) \ No newline at end of file +# Stashing Code for file upload to shiny app +# Based on https://shiny.rstudio.com/gallery/file-upload.html +# ui.R +# tags$hr(), +# fileInput('file1', 'Choose CSV File to upload data', +# accept=c('text/csv', +# 'text/comma-separated-values,text/plain', +# '.csv')), +# checkboxInput('header', 'Header', TRUE), +# radioButtons('sep', 'Separator', +# c(Comma=',', +# Semicolon=';', +# Tab='\t'), +# ','), +# radioButtons('quote', 'Quote', +# c(None='', +# 'Double Quote'='"', +# 'Single Quote'="'"), +# ''), +# actionButton("load_data", "Load External Data") +# server.R +# loadExternalData <-eventReactive(input$load_data,{ +# inFile <- input$file1 +# if (is.null(inFile)) +# return(data.frame()) +# # output$info1 <- renderText({ +# # # paste0(nrow(externalData)) +# # paste0(inFile$datapath) +# # }) +# externalData <- read.csv(inFile$datapath, header=input$header, sep=input$sep, +# quote=input$quote) +# return(externalData) +# }) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 509a1396da7..2aa5df8fc7b 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -84,6 +84,7 @@ server <- shinyServer(function(input, output, session) { # Loads data for all workflow and run ids after the load button is pressed. # All information about a model is contained in 'all_run_id' string # Wrapper over 'load_data_single_run' in PEcAn.db::query.dplyr + # Model data different from observations data loadNewData <-eventReactive(input$load,{ req(input$all_run_id) # Get IDs DF from 'all_run_id' string @@ -105,21 +106,35 @@ server <- shinyServer(function(input, output, session) { observations<-PEcAn.benchmark::load_data(data.path = File_path, format= File_format, time.row = File_format$time.row, site = site, start_year = start.year, end_year = end.year) return(observations) } - # getFileFormat <- function(bety,format.id){ - getFileFormat <- function(bety,input.id){ + # This function as a wrapper over PEcAn.DB::query.format.vars where + # file format can be retrieved using either by input or format id. + getFileFormat <- function(bety,input.id,format.id=NULL){ # Retaining the code for getting file format using inputRecordID # File_format <- PEcAn.DB::query.format.vars(bety = bety, format.id = format.id) File_format <- PEcAn.DB::query.format.vars(bety = bety, input.id = input.id) return(File_format) } getSettingsFromWorkflowId <- function(bety,workflowID){ - basePath <- tbl(bety, 'workflows') %>% filter(id == workflowID) %>% pull(folder) + basePath <- tbl(bety, 'workflows') %>% filter(id %in% workflowID) %>% pull(folder) configPath <- file.path(basePath, 'pecan.CONFIGS.xml') # Second way of proving configPath. More of a hack # configPath <- paste0("~/output/PEcAn_",workflowID,"/pecan.CONFIGS.xml") settings<-PEcAn.settings::read.settings(configPath) return(settings) } + observeEvent(input$load,{ + # Retrieves all site ids from multiple seleted run ids when load button is pressed + req(input$all_run_id) + ids_DF <- parse_ids_from_input_runID(input$all_run_id) + site_id_list <- c() + for(row_num in 1:nrow(ids_DF)){ + settings <- getSettingsFromWorkflowId(bety,ids_DF$wID[row_num]) + site.id <- c(settings$run$site$id) + site_id_list <- c(site_id_list,site.id) + } + updateSelectizeInput(session, "all_site_id", choices=site_id_list) + }) + # Renders ggplotly output$outputPlot <- renderPlotly({ # Error messages diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 15c7ecbd6d4..30c99dfa136 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -23,12 +23,14 @@ ui <- shinyUI(fluidPage( min=0, max=100, value=80), tags$hr(), tags$hr(), - fileInput('fileUploaded', 'Choose file to upload data' - # accept=c('text/csv', - # 'text/comma-separated-values,text/plain', - # '.csv') - ), - textInput("inputRecordID", "Input Record ID for file", "1000011260"), + selectizeInput("all_site_id", "Select Site IDs", c()), + selectizeInput("all_input_id", "Select Input ID", c()), + # fileInput('fileUploaded', 'Choose file to upload data' + # # accept=c('text/csv', + # # 'text/comma-separated-values,text/plain', + # # '.csv') + # ), + # textInput("inputRecordID", "Input Record ID for file", "1000011260"), # textInput("formatID", "Format ID for file (Default CSV)", "5000000002"), radioButtons("data_geom", "Plot Type (for loaded data)", c("Scatter Plot" = "point", From 22520204d7962e2918d5dcbfb11377e8423f4746 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sat, 29 Jul 2017 15:37:23 -0500 Subject: [PATCH 202/771] Input ids populated based on site ids.Step 2-8 Alexey comments. git stash due to corrupted version --- shiny/workflowPlot/server.R | 50 ++++++++++++++++++++++--------------- shiny/workflowPlot/ui.R | 2 +- 2 files changed, 31 insertions(+), 21 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 2aa5df8fc7b..c0edc16f98f 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -33,7 +33,7 @@ server <- shinyServer(function(input, output, session) { # Will return a list run_id_list <- c() for(w_id in w_ids){ - # For all the workflow ids + # For all the workflow ids r_ids <- get_run_ids(bety, w_id) for(r_id in r_ids){ # Each workflow id can have more than one run ids @@ -109,7 +109,7 @@ server <- shinyServer(function(input, output, session) { # This function as a wrapper over PEcAn.DB::query.format.vars where # file format can be retrieved using either by input or format id. getFileFormat <- function(bety,input.id,format.id=NULL){ - # Retaining the code for getting file format using inputRecordID + # Retaining the code for getting file format using format Id as in tutorial # File_format <- PEcAn.DB::query.format.vars(bety = bety, format.id = format.id) File_format <- PEcAn.DB::query.format.vars(bety = bety, input.id = input.id) return(File_format) @@ -134,7 +134,16 @@ server <- shinyServer(function(input, output, session) { } updateSelectizeInput(session, "all_site_id", choices=site_id_list) }) - + # Get input id from selected site id + getInputs <- function(bety,site_Id){ + inputIds <- tbl(bety, 'inputs') %>% filter(site_id %in% site_Id) %>% distinct(id) %>% pull(id) + inputIds <- sort(inputIds) + return(inputIds) + } + observe({ + req(input$all_site_id) + updateSelectizeInput(session, "all_input_id", choices=getInputs(bety,input$all_site_id)) + }) # Renders ggplotly output$outputPlot <- renderPlotly({ # Error messages @@ -166,25 +175,26 @@ server <- shinyServer(function(input, output, session) { # ggplot function for now scatter plots. plt <- ggplot(df, aes(x=dates, y=vals, color=run_id)) # Toggle chart type using switch - switch(input$plotType, - "scatterPlot" = { - plt <- plt + geom_point() - }, - "lineChart" = { - plt <- plt + geom_line() - } - ) + switch(input$plotType, + "scatterPlot" = { + plt <- plt + geom_point() + }, + "lineChart" = { + plt <- plt + geom_line() + } + ) plt <- plt + labs(title=title, x=xlab, y=ylab) + geom_smooth(n=input$smooth_n) # Check if user wants to load external data # Similar to using event reactive if (input$load_data>0) { # File_format <- getFileFormat(bety,input$formatID) # Retaining the code for getting file format using inputRecordID - File_format <- getFileFormat(bety,input$inputRecordID) + File_format <- getFileFormat(bety,input$all_input_id) ids_DF <- parse_ids_from_input_runID(input$all_run_id) settings <- getSettingsFromWorkflowId(bety,ids_DF$wID[1]) inFile <- input$fileUploaded - externalData <- loadObservationData(bety,settings,inFile$datapath,File_format) + filePath <- PEcAn.DB::dbfile.file(type = 'Input', id = input$all_input_id,con = bety$con) + externalData <- loadObservationData(bety,settings,filePath,File_format) # If variable found in the uploaded file if (input$variable_name %in% names(externalData)){ externalData <- externalData %>% dplyr::select(posix,dplyr::one_of(input$variable_name)) @@ -203,17 +213,17 @@ server <- shinyServer(function(input, output, session) { }) } } - # Earlier smoothing and y labels - # geom_smooth(aes(fill = "Spline fit")) + - # scale_y_continuous(labels=fancy_scientific) + - # Earlier color and fill values - # scale_color_manual(name = "", values = "black") + - # scale_fill_manual(name = "", values = "grey50") + # Earlier smoothing and y labels + # geom_smooth(aes(fill = "Spline fit")) + + # scale_y_continuous(labels=fancy_scientific) + + # Earlier color and fill values + # scale_color_manual(name = "", values = "black") + + # scale_fill_manual(name = "", values = "grey50") plt<-ggplotly(plt) # Not able to add icon over ggplotly # add_icon() }) -# Shiny server closes here + # Shiny server closes here }) # runApp(port=6480, launch.browser=FALSE) diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 30c99dfa136..d9ae275a96b 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -23,7 +23,7 @@ ui <- shinyUI(fluidPage( min=0, max=100, value=80), tags$hr(), tags$hr(), - selectizeInput("all_site_id", "Select Site IDs", c()), + selectizeInput("all_site_id", "Select Site ID", c()), selectizeInput("all_input_id", "Select Input ID", c()), # fileInput('fileUploaded', 'Choose file to upload data' # # accept=c('text/csv', From 39d7bc8b397eebb6be24434db2f8d9c25df857c1 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sun, 30 Jul 2017 12:57:09 -0400 Subject: [PATCH 203/771] install PEcAn packages before resolving dependencies --- Makefile | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index ca85829ad51..1745a59c5c1 100644 --- a/Makefile +++ b/Makefile @@ -36,7 +36,7 @@ ALL_PKGS_D := $(BASE_D) $(MODELS_D) $(MODULES_D) .doc/models/template .PHONY: all install check test document -all: document install +all: install document document: .doc/all install: .install/all @@ -60,8 +60,9 @@ $(call depends,modules/meta.analysis): .install/utils .install/db $(call depends,modules/priors): .install/utils $(call depends,modules/assim.batch): .install/utils .install/db .install/modules/meta.analysis $(call depends,modules/rtm): .install/modules/assim.batch +$(call depends,modules/uncertainty): .install/utils .install/modules/priors $(call depends,models/template): .install/utils -$(call depends,models/biocro): .install/utils .install/modules/data.atmosphere .install/modules/data.land +$(call depends,models/biocro): .install/utils .install/settings .install/db .install/modules/data.atmosphere .install/modules/data.land $(MODELS_I): .install/models/template @@ -85,7 +86,7 @@ clean: mkdir -p $(@D) echo `date` > $@ -depends_R_pkg = Rscript -e "devtools::install_deps('$(strip $(1))', Ncpus = ${NCPUS});" +depends_R_pkg = Rscript -e "devtools::install_deps('$(strip $(1))', threads = ${NCPUS});" install_R_pkg = Rscript -e "devtools::install('$(strip $(1))', Ncpus = ${NCPUS});" check_R_pkg = Rscript scripts/check_with_errors.R $(strip $(1)) test_R_pkg = Rscript -e "devtools::test('"$(strip $(1))"', reporter = 'stop')" From 70d6d97f258d96e0b2f499a19c24b312ce6caa64 Mon Sep 17 00:00:00 2001 From: Katie Date: Mon, 31 Jul 2017 10:38:56 -0400 Subject: [PATCH 204/771] Created new folder from template for CABLE under models and edited the generic template files. --- models/cable/DESCRIPTION | 19 ++++ models/cable/LICENSE | 34 +++++++ models/cable/NAMESPACE | 7 ++ models/cable/R/met2model.CABLE.R | 36 +++++++ models/cable/R/model2netcdf.CABLE.R | 37 +++++++ models/cable/R/read_restart.CABLE.R | 22 +++++ models/cable/R/write.config.CABLE.R | 125 ++++++++++++++++++++++++ models/cable/R/write_restart.CABLE.R | 18 ++++ models/cable/README.md | 64 ++++++++++++ models/cable/inst/template.job | 41 ++++++++ models/cable/man/met2model.CABLE.Rd | 25 +++++ models/cable/man/model2netcdf.CABLE.Rd | 25 +++++ models/cable/man/read_restart.CABLE.Rd | 30 ++++++ models/cable/man/write.config.CABLE.Rd | 30 ++++++ models/cable/man/write_restart.CABLE.Rd | 22 +++++ models/cable/tests/testthat.R | 13 +++ models/cable/tests/testthat/README.txt | 3 + 17 files changed, 551 insertions(+) create mode 100644 models/cable/DESCRIPTION create mode 100644 models/cable/LICENSE create mode 100644 models/cable/NAMESPACE create mode 100644 models/cable/R/met2model.CABLE.R create mode 100644 models/cable/R/model2netcdf.CABLE.R create mode 100644 models/cable/R/read_restart.CABLE.R create mode 100644 models/cable/R/write.config.CABLE.R create mode 100644 models/cable/R/write_restart.CABLE.R create mode 100644 models/cable/README.md create mode 100644 models/cable/inst/template.job create mode 100644 models/cable/man/met2model.CABLE.Rd create mode 100644 models/cable/man/model2netcdf.CABLE.Rd create mode 100644 models/cable/man/read_restart.CABLE.Rd create mode 100644 models/cable/man/write.config.CABLE.Rd create mode 100644 models/cable/man/write_restart.CABLE.Rd create mode 100644 models/cable/tests/testthat.R create mode 100644 models/cable/tests/testthat/README.txt diff --git a/models/cable/DESCRIPTION b/models/cable/DESCRIPTION new file mode 100644 index 00000000000..43e4ecaf4ec --- /dev/null +++ b/models/cable/DESCRIPTION @@ -0,0 +1,19 @@ +Package: PEcAn.CABLE +Type: Package +Title: PEcAn package for integration of the CABLE model +Version: 1.4.10.1 +Date: 2017-04-18 +Author: Kaitlin Ragosta +Maintainer: Anthony Gardella +Description: This module provides functions to link the (CABLE) to PEcAn. +Imports: + PEcAn.utils (>= 1.4.8) +Suggests: + testthat (>= 1.0.2) +SystemRequirements: CABLE +OS_type: unix +License: FreeBSD + file LICENSE +Copyright: Authors +LazyLoad: yes +LazyData: FALSE +RoxygenNote: 6.0.1 diff --git a/models/cable/LICENSE b/models/cable/LICENSE new file mode 100644 index 00000000000..5a9e44128f1 --- /dev/null +++ b/models/cable/LICENSE @@ -0,0 +1,34 @@ +## This is the master copy of the PEcAn License + +University of Illinois/NCSA Open Source License + +Copyright (c) 2012, University of Illinois, NCSA. All rights reserved. + +PEcAn project +www.pecanproject.org + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal with the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimers. +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimers in the + documentation and/or other materials provided with the distribution. +- Neither the names of University of Illinois, NCSA, nor the names + of its contributors may be used to endorse or promote products + derived from this Software without specific prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR +ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF +CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. + diff --git a/models/cable/NAMESPACE b/models/cable/NAMESPACE new file mode 100644 index 00000000000..e815441f0ca --- /dev/null +++ b/models/cable/NAMESPACE @@ -0,0 +1,7 @@ +# Generated by roxygen2: do not edit by hand + +export(met2model.MODEL) +export(model2netcdf.MODEL) +export(read_restart.ModelName) +export(write.config.MODEL) +export(write_restart.ModelName) diff --git a/models/cable/R/met2model.CABLE.R b/models/cable/R/met2model.CABLE.R new file mode 100644 index 00000000000..f495e5bee9c --- /dev/null +++ b/models/cable/R/met2model.CABLE.R @@ -0,0 +1,36 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2012 University of Illinois, NCSA. +# All rights reserved. This program and the accompanying materials +# are made available under the terms of the +# University of Illinois/NCSA Open Source License +# which accompanies this distribution, and is available at +# http://opensource.ncsa.illinois.edu/license.html +#------------------------------------------------------------------------------- + +##-------------------------------------------------------------------------------------------------# +##' Converts a met CF file to a model specific met file. The input +##' files are calld /.YYYY.cf +##' +##' @name met2model.CABLE +##' @title Write CABLE met files +##' @param in.path path on disk where CF file lives +##' @param in.prefix prefix for each file +##' @param outfolder location where model specific output is written. +##' @return OK if everything was succesful. +##' @export +##' @author Rob Kooper +##-------------------------------------------------------------------------------------------------# +met2model.CABLE <- function(in.path, in.prefix, outfolder, overwrite = FALSE) { + logger.severe("NOT IMPLEMENTED") + + # Please follow the PEcAn style guide: + # https://pecan.gitbooks.io/pecan-documentation/content/developers_guide/Coding_style.html + + # Note that `library()` calls should _never_ appear here; instead, put + # packages dependencies in the DESCRIPTION file, under "Imports:". + # Calls to dependent packages should use a double colon, e.g. + # `packageName::functionName()`. + # Also, `require()` should be used only when a package dependency is truly + # optional. In this case, put the package name under "Suggests:" in DESCRIPTION. + +} # met2model.CABLE diff --git a/models/cable/R/model2netcdf.CABLE.R b/models/cable/R/model2netcdf.CABLE.R new file mode 100644 index 00000000000..8d0d2d44a2b --- /dev/null +++ b/models/cable/R/model2netcdf.CABLE.R @@ -0,0 +1,37 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2012 University of Illinois, NCSA. +# All rights reserved. This program and the accompanying materials +# are made available under the terms of the +# University of Illinois/NCSA Open Source License +# which accompanies this distribution, and is available at +# http://opensource.ncsa.illinois.edu/license.html +#------------------------------------------------------------------------------- + +##-------------------------------------------------------------------------------------------------# +##' Convert CABLE output into the NACP Intercomparison format (ALMA using netCDF) +##' +##' @name model2netcdf.CABLE +##' @title Code to convert CABLE's output into netCDF format +##' +##' @param outdir Location of model output +##' @param sitelat Latitude of the site +##' @param sitelon Longitude of the site +##' @param start_date Start time of the simulation +##' @param end_date End time of the simulation +##' @export +##' +##' @author Rob Kooper +model2netcdf.CABLE <- function(outdir, sitelat, sitelon, start_date, end_date) { + logger.severe("NOT IMPLEMENTED") + + # Please follow the PEcAn style guide: + # https://pecan.gitbooks.io/pecan-documentation/content/developers_guide/Coding_style.html + + # Note that `library()` calls should _never_ appear here; instead, put + # packages dependencies in the DESCRIPTION file, under "Imports:". + # Calls to dependent packages should use a double colon, e.g. + # `packageName::functionName()`. + # Also, `require()` should be used only when a package dependency is truly + # optional. In this case, put the package name under "Suggests:" in DESCRIPTION. + +} # model2netcdf.CABLE diff --git a/models/cable/R/read_restart.CABLE.R b/models/cable/R/read_restart.CABLE.R new file mode 100644 index 00000000000..9372c8ee14a --- /dev/null +++ b/models/cable/R/read_restart.CABLE.R @@ -0,0 +1,22 @@ +#' @title Read restart template for SDA +#' +#' @author Alexey Shiklomanov +#' +#' @param outdir Output directory +#' @param runid Run ID +#' @param stop.time Year that is being read +#' @param settings PEcAn settings object +#' @param var.names Variable names to be extracted +#' @param params Any parameters required for state calculations +#' +#' @description Read restart files from model. +#' +#' @return Forecast numeric matrix +#' @export +read_restart.CABLE <- function(outdir, + runid, + stop.time, + settings, + var.names, + params) {} + diff --git a/models/cable/R/write.config.CABLE.R b/models/cable/R/write.config.CABLE.R new file mode 100644 index 00000000000..97135b8e21e --- /dev/null +++ b/models/cable/R/write.config.CABLE.R @@ -0,0 +1,125 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2012 University of Illinois, NCSA. +# All rights reserved. This program and the accompanying materials +# are made available under the terms of the +# University of Illinois/NCSA Open Source License +# which accompanies this distribution, and is available at +# http://opensource.ncsa.illinois.edu/license.html +#------------------------------------------------------------------------------- + +##-------------------------------------------------------------------------------------------------# +##' Writes a CABLE config file. +##' +##' Requires a pft xml object, a list of trait values for a single model run, +##' and the name of the file to create +##' +##' @name write.config.CABLE +##' @title Write CABLE configuration files +##' @param defaults list of defaults to process +##' @param trait.samples vector of samples for a given trait +##' @param settings list of settings from pecan settings file +##' @param run.id id of run +##' @return configuration file for CABLE for given run +##' @export +##' @author Rob Kooper +##-------------------------------------------------------------------------------------------------# +write.config.CABLE <- function(defaults, trait.values, settings, run.id) { + + # Please follow the PEcAn style guide: + # https://pecan.gitbooks.io/pecan-documentation/content/developers_guide/Coding_style.html + + # Note that `library()` calls should _never_ appear here; instead, put + # packages dependencies in the DESCRIPTION file, under "Imports:". + # Calls to dependent packages should use a double colon, e.g. + # `packageName::functionName()`. + # Also, `require()` should be used only when a package dependency is truly + # optional. In this case, put the package name under "Suggests:" in DESCRIPTION. + + # find out where to write run/ouput + rundir <- file.path(settings$host$rundir, run.id) + outdir <- file.path(settings$host$outdir, run.id) + + #----------------------------------------------------------------------- + # create launch script (which will create symlink) + if (!is.null(settings$model$jobtemplate) && file.exists(settings$model$jobtemplate)) { + jobsh <- readLines(con = settings$model$jobtemplate, n = -1) + } else { + jobsh <- readLines(con = system.file("template.job", package = "PEcAn.CABLE"), n = -1) + } + + # create host specific setttings + hostsetup <- "" + if (!is.null(settings$model$prerun)) { + hostsetup <- paste(hostsetup, sep = "\n", paste(settings$model$prerun, collapse = "\n")) + } + if (!is.null(settings$host$prerun)) { + hostsetup <- paste(hostsetup, sep = "\n", paste(settings$host$prerun, collapse = "\n")) + } + + hostteardown <- "" + if (!is.null(settings$model$postrun)) { + hostteardown <- paste(hostteardown, sep = "\n", paste(settings$model$postrun, collapse = "\n")) + } + if (!is.null(settings$host$postrun)) { + hostteardown <- paste(hostteardown, sep = "\n", paste(settings$host$postrun, collapse = "\n")) + } + + # create job.sh + jobsh <- gsub("@HOST_SETUP@", hostsetup, jobsh) + jobsh <- gsub("@HOST_TEARDOWN@", hostteardown, jobsh) + + jobsh <- gsub("@SITE_LAT@", settings$run$site$lat, jobsh) + jobsh <- gsub("@SITE_LON@", settings$run$site$lon, jobsh) + jobsh <- gsub("@SITE_MET@", settings$run$site$met, jobsh) + + jobsh <- gsub("@START_DATE@", settings$run$start.date, jobsh) + jobsh <- gsub("@END_DATE@", settings$run$end.date, jobsh) + + jobsh <- gsub("@OUTDIR@", outdir, jobsh) + jobsh <- gsub("@RUNDIR@", rundir, jobsh) + + jobsh <- gsub("@BINARY@", settings$model$binary, jobsh) + + writeLines(jobsh, con = file.path(settings$rundir, run.id, "job.sh")) + Sys.chmod(file.path(settings$rundir, run.id, "job.sh")) + + #----------------------------------------------------------------------- + ### Edit a templated config file for runs + if (!is.null(settings$model$config) && file.exists(settings$model$config)) { + config.text <- readLines(con = settings$model$config, n = -1) + } else { + filename <- system.file(settings$model$config, package = "PEcAn.CABLE") + if (filename == "") { + if (!is.null(settings$model$revision)) { + filename <- system.file(paste0("config.", settings$model$revision), package = "PEcAn.CABLE") + } else { + model <- db.query(paste("SELECT * FROM models WHERE id =", settings$model$id), params = settings$database$bety) + filename <- system.file(paste0("config.r", model$revision), package = "PEcAn.CABLE") + } + } + if (filename == "") { + logger.severe("Could not find config template") + } + logger.info("Using", filename, "as template") + config.text <- readLines(con = filename, n = -1) + } + + config.text <- gsub("@SITE_LAT@", settings$run$site$lat, config.text) + config.text <- gsub("@SITE_LON@", settings$run$site$lon, config.text) + config.text <- gsub("@SITE_MET@", settings$run$inputs$met$path, config.text) + config.text <- gsub("@MET_START@", settings$run$site$met.start, config.text) + config.text <- gsub("@MET_END@", settings$run$site$met.end, config.text) + config.text <- gsub("@START_MONTH@", format(startdate, "%m"), config.text) + config.text <- gsub("@START_DAY@", format(startdate, "%d"), config.text) + config.text <- gsub("@START_YEAR@", format(startdate, "%Y"), config.text) + config.text <- gsub("@END_MONTH@", format(enddate, "%m"), config.text) + config.text <- gsub("@END_DAY@", format(enddate, "%d"), config.text) + config.text <- gsub("@END_YEAR@", format(enddate, "%Y"), config.text) + config.text <- gsub("@OUTDIR@", settings$host$outdir, config.text) + config.text <- gsub("@ENSNAME@", run.id, config.text) + config.text <- gsub("@OUTFILE@", paste0("out", run.id), config.text) + + #----------------------------------------------------------------------- + config.file.name <- paste0("CONFIG.", run.id, ".txt") + writeLines(config.text, con = paste(outdir, config.file.name, sep = "")) +} # write.config.CABLE diff --git a/models/cable/R/write_restart.CABLE.R b/models/cable/R/write_restart.CABLE.R new file mode 100644 index 00000000000..3c52ffac8a1 --- /dev/null +++ b/models/cable/R/write_restart.CABLE.R @@ -0,0 +1,18 @@ +#' @title Write restart template for SDA +#' +#' @author Alexey Shiklomanov +#' +#' @param start.time Time of current assimilation step +#' @param stop.time Time of next assimilation step +#' @param new.state Analysis state matrix returned by \code{sda.enkf} +#' @inheritParams read.restart.CABLE +#' +#' @description Write restart files for model +#' +#' @export +write_restart.CABLE <- function(outdir, + runid, + start.time, + stop.time, + settings, + new.state) {} diff --git a/models/cable/README.md b/models/cable/README.md new file mode 100644 index 00000000000..ac17ce2dae4 --- /dev/null +++ b/models/cable/README.md @@ -0,0 +1,64 @@ +A generic template for adding a new model to PEcAn +========================================================================== + +Adding a new model to PEcAn in a few easy steps: + +1. add modeltype to BETY +2. add a model and PFT to BETY for use with modeltype +3. implement 3 functions as described below +4. Add tests to `tests/testthat` +5. Update README, documentation +6. execute pecan with new model + + +### Three Functions + +There are 3 functions that will need to be implemented, each of these +functions will need to have MODEL be replaced with the actual modeltype as +it is defined in the BETY database. + +* `write.config.MODEL.R` + + This will write the configuratin file as well as the job launcher used by + PEcAn. There is an example of the job execution script in the template + folder. The configuration file can also be a template that is found based + on the revision number of the model. This should use the computed results + specified in defaults and trait.values to write a configuration file + based on the PFT and traits found. + +* `met2model.MODEL.R` + + This will convert the standard Met CF file to the model specific file + format. This will allow PEcAn to create metereological files for the + specific site and model. This will only be called if no meterological + data is found for that specific site and model combination. + +* `model2netcdf.MODEL.R` + + This will convert the model specific output to NACP Intercomparison + format. After this function is finished PEcAn will use the generated + output and not use the model specific outputs. The outputs should be + named YYYY.nc + +### Additional Changes + +* `README.md` + +This file should contain basic background information about the model. +At a minimum, this should include the scientific motivation and scope, +name(s) of maintainer(s), links to project homepage, and a list of a few +key publications. +relevant publications. + +* `/tests/testthat/` + +Each package should have tests that cover the key functions of the package, +at a minimum, the three functions above. + +* documentation + +Update the `NAMESPACE`, `DESCRIPTION` and `man/*.Rd` files by running + +```r +devtools("models//") +``` diff --git a/models/cable/inst/template.job b/models/cable/inst/template.job new file mode 100644 index 00000000000..06e667df2e1 --- /dev/null +++ b/models/cable/inst/template.job @@ -0,0 +1,41 @@ +#!/bin/bash + +# redirect output +exec 3>&1 +exec &> "@OUTDIR@/logfile.txt" + +# host specific setup +@HOST_SETUP@ + +# create output folder +mkdir -p "@OUTDIR@" + +# see if application needs running +if [ ! -e "@OUTDIR@/results.csv" ]; then + cd "@RUNDIR@" + + "@BINARY@" + STATUS=$? + + # check the status + if [ $STATUS -ne 0 ]; then + echo -e "ERROR IN MODEL RUN\nLogfile is located at '@OUTDIR@/logfile.txt'" >&3 + exit $STATUS + fi + + # convert to MsTMIP + echo "require (PEcAn.CABLE) +model2netcdf.CABLE('@OUTDIR@', @SITE_LAT@, @SITE_LON@, '@START_DATE@', '@END_DATE@') +" | R --vanilla +fi + +# copy readme with specs to output +cp "@RUNDIR@/README.txt" "@OUTDIR@/README.txt" + +# run getdata to extract right variables + +# host specific teardown +@HOST_TEARDOWN@ + +# all done +echo -e "MODEL FINISHED\nLogfile is located at '@OUTDIR@/logfile.txt'" >&3 diff --git a/models/cable/man/met2model.CABLE.Rd b/models/cable/man/met2model.CABLE.Rd new file mode 100644 index 00000000000..dbc063ff812 --- /dev/null +++ b/models/cable/man/met2model.CABLE.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/met2model.CABLE.R +\name{met2model.CABLE} +\alias{met2model.CABLE} +\title{Write CABLE met files} +\usage{ +met2model.CABLE(in.path, in.prefix, outfolder, overwrite = FALSE) +} +\arguments{ +\item{in.path}{path on disk where CF file lives} + +\item{in.prefix}{prefix for each file} + +\item{outfolder}{location where model specific output is written.} +} +\value{ +OK if everything was succesful. +} +\description{ +Converts a met CF file to a model specific met file. The input +files are calld /.YYYY.cf +} +\author{ +Rob Kooper +} diff --git a/models/cable/man/model2netcdf.CABLE.Rd b/models/cable/man/model2netcdf.CABLE.Rd new file mode 100644 index 00000000000..fca84d6c8e0 --- /dev/null +++ b/models/cable/man/model2netcdf.CABLE.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/model2netcdf.CABLE.R +\name{model2netcdf.CABLE} +\alias{model2netcdf.CABLE} +\title{Code to convert CABLE's output into netCDF format} +\usage{ +model2netcdf.CABLE(outdir, sitelat, sitelon, start_date, end_date) +} +\arguments{ +\item{outdir}{Location of model output} + +\item{sitelat}{Latitude of the site} + +\item{sitelon}{Longitude of the site} + +\item{start_date}{Start time of the simulation} + +\item{end_date}{End time of the simulation} +} +\description{ +Convert CABLE output into the NACP Intercomparison format (ALMA using netCDF) +} +\author{ +Rob Kooper +} diff --git a/models/cable/man/read_restart.CABLE.Rd b/models/cable/man/read_restart.CABLE.Rd new file mode 100644 index 00000000000..d8223bab94f --- /dev/null +++ b/models/cable/man/read_restart.CABLE.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/read_restart.CABLE.R +\name{read_restart.CABLE} +\alias{read_restart.CABLE} +\title{Read restart template for SDA} +\usage{ +read_restart.CABLE(outdir, runid, stop.time, settings, var.names, params) +} +\arguments{ +\item{outdir}{Output directory} + +\item{runid}{Run ID} + +\item{stop.time}{Year that is being read} + +\item{settings}{PEcAn settings object} + +\item{var.names}{Variable names to be extracted} + +\item{params}{Any parameters required for state calculations} +} +\value{ +Forecast numeric matrix +} +\description{ +Read restart files from model. +} +\author{ +Alexey Shiklomanov +} diff --git a/models/cable/man/write.config.CABLE.Rd b/models/cable/man/write.config.CABLE.Rd new file mode 100644 index 00000000000..e9d649106f6 --- /dev/null +++ b/models/cable/man/write.config.CABLE.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/write.config.CABLE.R +\name{write.config.CABLE} +\alias{write.config.CABLE} +\title{Write CABLE configuration files} +\usage{ +write.config.CABLE(defaults, trait.values, settings, run.id) +} +\arguments{ +\item{defaults}{list of defaults to process} + +\item{settings}{list of settings from pecan settings file} + +\item{run.id}{id of run} + +\item{trait.samples}{vector of samples for a given trait} +} +\value{ +configuration file for CABLE for given run +} +\description{ +Writes a CABLE config file. +} +\details{ +Requires a pft xml object, a list of trait values for a single model run, +and the name of the file to create +} +\author{ +Rob Kooper +} diff --git a/models/cable/man/write_restart.CABLE.Rd b/models/cable/man/write_restart.CABLE.Rd new file mode 100644 index 00000000000..52945b79ee6 --- /dev/null +++ b/models/cable/man/write_restart.CABLE.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/write_restart.CABLE.R +\name{write_restart.CABLE} +\alias{write_restart.CABLE} +\title{Write restart template for SDA} +\usage{ +write_restart.CABLE(outdir, runid, start.time, stop.time, settings, + new.state) +} +\arguments{ +\item{start.time}{Time of current assimilation step} + +\item{stop.time}{Time of next assimilation step} + +\item{new.state}{Analysis state matrix returned by \code{sda.enkf}} +} +\description{ +Write restart files for model +} +\author{ +Alexey Shiklomanov +} diff --git a/models/cable/tests/testthat.R b/models/cable/tests/testthat.R new file mode 100644 index 00000000000..905113b058b --- /dev/null +++ b/models/cable/tests/testthat.R @@ -0,0 +1,13 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2012 University of Illinois, NCSA. +# All rights reserved. This program and the accompanying materials +# are made available under the terms of the +# University of Illinois/NCSA Open Source License +# which accompanies this distribution, and is available at +# http://opensource.ncsa.illinois.edu/license.html +#------------------------------------------------------------------------------- +library(testthat) +library(PEcAn.utils) + +logger.setQuitOnSevere(FALSE) +#test_check("PEcAn.ModelName") diff --git a/models/cable/tests/testthat/README.txt b/models/cable/tests/testthat/README.txt new file mode 100644 index 00000000000..b11fefae099 --- /dev/null +++ b/models/cable/tests/testthat/README.txt @@ -0,0 +1,3 @@ +Place your tests here. They will be executed in this folder, so you +can place any data you need in this folder as well (or in a subfolder +called data). From 8762eb7b3a2d4f216089e059dd45404950847831 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 12:27:06 -0400 Subject: [PATCH 205/771] add netcdf2list --- modules/data.land/R/pool_ic_netcdf2list.R | 29 +++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 modules/data.land/R/pool_ic_netcdf2list.R diff --git a/modules/data.land/R/pool_ic_netcdf2list.R b/modules/data.land/R/pool_ic_netcdf2list.R new file mode 100644 index 00000000000..c3437510040 --- /dev/null +++ b/modules/data.land/R/pool_ic_netcdf2list.R @@ -0,0 +1,29 @@ +##' @name pool_ic_netcdf2list +##' @title pool_ic_netcdf2list +##' @description Converts netcdf containing standard dimensions and variables for pool-based initial conditions, created by pool_ic_list2netcdf, back into list format +##' @export +##' +##' @param nc.path path to netcdf file containing standard dimensions and variables +##' @return list with two elements: list of netcdf dimensions (dims, with named values) and list of variables (vals, with named values) +##' @author Anne Thomas +pool_ic_netcdf2list <- function(nc.path){ + IC.nc <- try(ncdf4::nc_open(nc.path)) + if(class(nc) != 'try-error'){ + dims <- vector(mode = "list", length = length(IC.nc$dim)) + names(dims) <- names(IC.nc$dim) + for(i in seq(IC.nc$dim)){ + dims[[i]] <- IC.nc$dim[[i]]$vals + } + + vals <- vector(mode = "list", length = length(IC.nc$var)) + names(vals) <- names(IC.nc$var) + for(varname in names(vals)){ + vals[[varname]] <- ncdf4::ncvar_get(IC.nc,varname) + } + return(list(dims = dims, vals = vals)) + } + else{ + PEcAn.utils::logger.severe("Could not read IC file.") + } + +} \ No newline at end of file From 624c70f7187ac2bcf8023ed36943ac55c3596570 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 12:32:24 -0400 Subject: [PATCH 206/771] fix typo in check --- modules/data.land/R/pool_ic_netcdf2list.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/R/pool_ic_netcdf2list.R b/modules/data.land/R/pool_ic_netcdf2list.R index c3437510040..49d73c0babb 100644 --- a/modules/data.land/R/pool_ic_netcdf2list.R +++ b/modules/data.land/R/pool_ic_netcdf2list.R @@ -8,7 +8,7 @@ ##' @author Anne Thomas pool_ic_netcdf2list <- function(nc.path){ IC.nc <- try(ncdf4::nc_open(nc.path)) - if(class(nc) != 'try-error'){ + if(class(IC.nc) != 'try-error'){ dims <- vector(mode = "list", length = length(IC.nc$dim)) names(dims) <- names(IC.nc$dim) for(i in seq(IC.nc$dim)){ From bf438ff7fa34948a92ec7b7f5acc03ab4bc2c41d Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 12:47:04 -0400 Subject: [PATCH 207/771] documentation --- modules/data.land/NAMESPACE | 1 + modules/data.land/man/pool_ic_netcdf2list.Rd | 20 ++++++++++++++++++++ 2 files changed, 21 insertions(+) create mode 100644 modules/data.land/man/pool_ic_netcdf2list.Rd diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index ac2229d0641..48d5c6a8761 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -29,6 +29,7 @@ export(parse.MatrixNames) export(partition_roots) export(plot2AGB) export(pool_ic_list2netcdf) +export(pool_ic_netcdf2list) export(sclass) export(shp2kml) export(soil.units) diff --git a/modules/data.land/man/pool_ic_netcdf2list.Rd b/modules/data.land/man/pool_ic_netcdf2list.Rd new file mode 100644 index 00000000000..e911d8b649e --- /dev/null +++ b/modules/data.land/man/pool_ic_netcdf2list.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pool_ic_netcdf2list.R +\name{pool_ic_netcdf2list} +\alias{pool_ic_netcdf2list} +\title{pool_ic_netcdf2list} +\usage{ +pool_ic_netcdf2list(nc.path) +} +\arguments{ +\item{nc.path}{path to netcdf file containing standard dimensions and variables} +} +\value{ +list with two elements: list of netcdf dimensions (dims, with named values) and list of variables (vals, with named values) +} +\description{ +Converts netcdf containing standard dimensions and variables for pool-based initial conditions, created by pool_ic_list2netcdf, back into list format +} +\author{ +Anne Thomas +} From eaaf60aeaeb0ee5aed64cd4adcc66019be7e41fc Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 14:11:39 -0400 Subject: [PATCH 208/771] fix confusing SLA var name --- models/dalec/R/write.configs.dalec.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index d6a00c358e2..75e183337cc 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -163,8 +163,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { IC.params[["cf0"]] <- leaf * 1000 #from standard kg C m-2 } else if(is.valid(LAI)){ if("SLA" %in% names(params)){ - SLA <- 1/params[1,"SLA"] #SLA converted to m2/gC in convert.samples - leaf <- LAI * SLA + leaf <- LAI * 1/params[1,"SLA"] #SLA converted to m2/gC in convert.samples IC.params[["cf0"]] <- leaf } else{ SLA <- default.param[which(default.param$cmdFlag == "SLA"),"val"] From 9daa0cc77cb781849e025e637a194e51732a0ea3 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 14:32:01 -0400 Subject: [PATCH 209/771] somewhat generic function to sum pools --- modules/data.land/R/align_pools.R | 124 ++++++++++++++++++++++++++++++ 1 file changed, 124 insertions(+) create mode 100644 modules/data.land/R/align_pools.R diff --git a/modules/data.land/R/align_pools.R b/modules/data.land/R/align_pools.R new file mode 100644 index 00000000000..813b014631f --- /dev/null +++ b/modules/data.land/R/align_pools.R @@ -0,0 +1,124 @@ +align_pools <- function(nc.path,sla=NULL){ + #sla must be converted to m2/kgC + #function to check that ncvar was loaded (numeric) and has a valid value (not NA or negative) + is.valid <- function(var){ + return(all(is.numeric(var) && !is.na(var) && var >= 0)) + } + + default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC"), header = TRUE) + IC.params <- list() + + if (!is.null(settings$run$inputs$poolinitcond$path)) { + IC.list <- PEcAn.data.land::pool_ic_netcdf2list(nc.path) + if(!is.null(IC.list)){ + ### load biomass variables from IC list; will be NULL if not present (checked for later) + TotLivBiom <- IC.list$vals$TotLivBiom + leaf <- IC.list$vals$leaf_carbon_content + LAI <- IC.list$vals$LAI + AbvGrndWood <- IC.list$vals$AbvGrndWood + roots <- IC.list$vals$root_carbon_content + fine.roots <- IC.list$vals$fine_root_carbon_content + coarse.roots <- IC.list$vals$coarse_root_carbon_content + + ### load non-living variables + litter <- IC.list$vals$litter_carbon_content + soil <- IC.list$vals$soil_organic_carbon_content + wood.debris <- IC.list$vals$wood_debris_carbon_content + + if(!all(sapply(c(TotLivBiom,leaf,LAI,AbvGrndWood,roots,fine.roots,coarse.roots),is.numeric))){ + PEcAn.utils::logger.info("DALEC IC: Any missing vars will be calculated from those provided or replaced by DALEC's defaults") + } + + # check if total roots are partitionable + # note: if roots are partitionable, they will override fine_ and/or coarse_root_carbon_content if loaded + if(is.valid(roots)){ + if("rtsize" %in% names(IC.list$dims)){ + PEcAn.utils::logger.info("align_pools: Attempting to partition root_carbon_content") + rtsize <- IC.list$dims$rtsize + part_roots <- PEcAn.data.land::partition_roots(roots, rtsize) + if(!is.null(part_roots)){ + fine.roots <- part_roots$fine.roots + coarse.roots <- part_roots$coarse.roots + } else{ + PEcAn.utils::logger.error("align_pools: could not partition roots; please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + } + } else{ + PEcAn.utils::logger.error("align_pools: Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + } + } else{ + # proceed without error message + } + + + ### Calculate pools from IC list + + # initial canopy foliar carbon (kgC/m2) + if (is.valid(leaf)) { + IC.params[["leaf"]] <- leaf + } else if(is.valid(LAI) && !is.null(sla)){ + leaf <- LAI * 1/SLA + IC.params[["leaf"]] <- leaf + } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && + is.valid(fine.roots) && is.valid(coarse.roots)){ + leaf <- (TotLivBiom - AbvGrndWood - fine.roots - coarse.roots) + if(leaf >= 0){ + IC.params[["leaf"]] <- leaf + } else{ + PEcAn.utils::logger.error("TotLivBiom is less than sum of AbvGrndWood and roots; will use default for leaf biomass") + } + } + + # initial pool of woody carbon (kgC/m2) + if (is.valid(AbvGrndWood)) { + if(is.valid(coarse.roots)){ + IC.params[["wood"]] <- (AbvGrndWood + coarse.roots) + } else{ + PEcAn.utils::logger.error("align_pools can't calculate total woody biomass with only AbvGrndWood; checking for total biomass.") + } + } else if (is.valid(TotLivBiom) && is.valid(leaf) && is.valid(fine.roots)){ + wood <- (TotLivBiom - leaf - fine.roots) + if (wood >= 0){ + IC.params[["wood"]] <- wood + }else{ + PEcAn.utils::logger.error(paste("TotLivBiom (", TotLivBiom, ") is less than sum of leaf (", leaf, ") and fine roots(",fine.roots,"); will use default for woody biomass.")) + } + } else{ + PEcAn.utils::logger.error("align_pools could not calculate woody biomass; will use defaults. Please provide AbvGrndWood and coarse_root_carbon OR leaf_carbon_content/LAI, fine_root_carbon_content, and TotLivBiom in netcdf.") + } + + # initial pool of fine root carbon (kgC/m2) + if (is.valid(fine.roots)) { + IC.params[["fine.roots"]] <- fine.roots + } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && + is.valid(leaf) && is.valid(coarse.roots)){ + fine.roots <- (TotLivBiom - AbvGrndWood - leaf - coarse.roots) + if(fine.roots >= 0){ + IC.params[["fine.roots"]] <- fine.roots + } else{ + PEcAn.utils::logger.error("TotLivBiom is less than sum of AbvGrndWood, coarse roots, and leaf; will use default for fine.roots biomass") + } + } + + + # initial pool of litter carbon (kgC/m2) + if (is.valid(litter)) { + IC.params[["litter"]] <- litter + } + + # initial pool of soil organic matter (kgC/m2) + if(is.valid(soil)){ + IC.params[["soil"]] <- soil + } else { + soil <- IC.list$vals$soil_carbon_content + if(is.valid(soil)){ + IC.params[["soil"]] <- soil + } + } + + # initial pool of woody debris (kgC/m2) + if(is.valid(wood.debris)){ + IC.params[["wood.debris"]] <-sum(wood.debris) + } + } + } +} \ No newline at end of file From 231231f3651621be7cfdcdf8091d643ab8f43ea4 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 14:48:25 -0400 Subject: [PATCH 210/771] clean up and add header --- modules/data.land/R/align_pools.R | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/modules/data.land/R/align_pools.R b/modules/data.land/R/align_pools.R index 813b014631f..30a95a31ff5 100644 --- a/modules/data.land/R/align_pools.R +++ b/modules/data.land/R/align_pools.R @@ -1,14 +1,21 @@ -align_pools <- function(nc.path,sla=NULL){ - #sla must be converted to m2/kgC - #function to check that ncvar was loaded (numeric) and has a valid value (not NA or negative) +##' @name align_pools +##' @title align_pools +##' @description Calculates pools from given initial condition values, deriving complements where necessary/possible if given TotLivBiomass +##' @export +##' +##' @param nc.path path to netcdf file containing standard dimensions and variables; currently supports these variables: TotLivBiom, leaf_carbon_content, LAI, AbvGrndWood, root_carbon_content, fine_root_carbon_content, coarse_root_carbon_content, litter_carbon_content, soil_organic_carbon_content, soil_carbon_content, wood_debris_carbon_content +##' @param sla SLA in m2 / kg C if providing LAI for leaf carbon +##' @return list of pool values in kg C / m2 with generic names +##' @author Anne Thomas +align_pools <- function(nc.path, sla = NULL){ + #function to check that var was loaded (numeric) and has a valid value (not NA or negative) is.valid <- function(var){ return(all(is.numeric(var) && !is.na(var) && var >= 0)) } - default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC"), header = TRUE) IC.params <- list() - if (!is.null(settings$run$inputs$poolinitcond$path)) { + if (!is.null(nc.path)) { IC.list <- PEcAn.data.land::pool_ic_netcdf2list(nc.path) if(!is.null(IC.list)){ ### load biomass variables from IC list; will be NULL if not present (checked for later) @@ -25,10 +32,6 @@ align_pools <- function(nc.path,sla=NULL){ soil <- IC.list$vals$soil_organic_carbon_content wood.debris <- IC.list$vals$wood_debris_carbon_content - if(!all(sapply(c(TotLivBiom,leaf,LAI,AbvGrndWood,roots,fine.roots,coarse.roots),is.numeric))){ - PEcAn.utils::logger.info("DALEC IC: Any missing vars will be calculated from those provided or replaced by DALEC's defaults") - } - # check if total roots are partitionable # note: if roots are partitionable, they will override fine_ and/or coarse_root_carbon_content if loaded if(is.valid(roots)){ From c2d7866e840a7d4ba0d1bc0a5877089184d6b7ec Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 14:55:16 -0400 Subject: [PATCH 211/771] add return statements --- modules/data.land/R/align_pools.R | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/modules/data.land/R/align_pools.R b/modules/data.land/R/align_pools.R index 30a95a31ff5..59f1b57dbe5 100644 --- a/modules/data.land/R/align_pools.R +++ b/modules/data.land/R/align_pools.R @@ -122,6 +122,16 @@ align_pools <- function(nc.path, sla = NULL){ if(is.valid(wood.debris)){ IC.params[["wood.debris"]] <-sum(wood.debris) } + + return(IC.params) + } + else{ + PEcAn.utils::logger.severe("Could not load initial conditions: output list is null") + return(NULL) } } + else{ + PEcAn.utils::logger.severe("Could not load initial conditions: filepath is null") + return(NULL) + } } \ No newline at end of file From 99bb0d3cbd7575e5638443b136c91b793ebcd98c Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 15:24:19 -0400 Subject: [PATCH 212/771] retrofit write.configs.dalec to use align_pools --- models/dalec/R/write.configs.dalec.R | 143 ++++++--------------------- 1 file changed, 31 insertions(+), 112 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 75e183337cc..fff741c4065 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -114,135 +114,54 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { return(all(is.numeric(var) && !is.na(var) && var >= 0)) } - default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC"), header = TRUE) + IC.params <- list() - if (!is.null(settings$run$inputs$poolinitcond$path)) { + if(!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path - IC.nc <- try(ncdf4::nc_open(IC.path)) - if(class(IC.nc) != "try-error"){ - #check/load biomass netcdf variables - TotLivBiom <- try(ncdf4::ncvar_get(IC.nc,"TotLivBiom"),silent = TRUE) - leaf <- try(ncdf4::ncvar_get(IC.nc,"leaf_carbon_content"),silent = TRUE) - LAI <- try(ncdf4::ncvar_get(IC.nc,"LAI"),silent = TRUE) - AbvGrndWood <- try(ncdf4::ncvar_get(IC.nc,"AbvGrndWood"),silent = TRUE) - roots <- try(ncdf4::ncvar_get(IC.nc,"root_carbon_content"),silent = TRUE) - fine.roots <- try(ncdf4::ncvar_get(IC.nc,"fine_root_carbon_content"),silent = TRUE) - coarse.roots <- try(ncdf4::ncvar_get(IC.nc,"coarse_root_carbon_content"),silent = TRUE) - - if(!all(sapply(c(TotLivBiom,leaf,LAI,AbvGrndWood,roots,fine.roots,coarse.roots),is.numeric))){ - PEcAn.utils::logger.info("DALEC IC: Any missing vars will be calculated from those provided or replaced by DALEC's defaults") - } - - #check if total roots are partitionable - #note: if roots are patritionable, they will override fine_ and/or coarse_root_carbon_content if loaded - if(is.valid(roots)){ - if("rtsize" %in% names(IC.nc$dim)){ - PEcAn.utils::logger.info("DALEC IC: Attempting to partition root_carbon_content") - rtsize <- IC.nc$dim$rtsize$vals - part_roots <- PEcAn.data.land::partition_roots(roots, rtsize) - if(!is.null(part_roots)){ - fine.roots <- part_roots$fine.roots - coarse.roots <- part_roots$coarse.roots - } else{ - PEcAn.utils::logger.error("DALEC IC: could not partition roots; please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") - } - } else{ - PEcAn.utils::logger.error("DALEC IC: Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") - } - } else{ - #proceed without error message - } - - - ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) + sla <- NULL + if("SLA" %in% names(params)){ + sla <- params[1,"SLA"] * 1000 #convert SLA to m2/kgC from m2/gC (convert.samples) + } else{ + default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC"), header = TRUE) + sla <- default.param[which(default.param$cmdFlag == "SLA"),"val"] * 1000 #convert SLA to m2/kgC from m2/gC (dalec default) + } + + IC.pools <- align_pools(IC.path, sla) + + if(!is.null(IC.pools)){ + ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) # cf0 initial canopy foliar carbon (g/m2) - if (is.valid(leaf)) { - IC.params[["cf0"]] <- leaf * 1000 #from standard kg C m-2 - } else if(is.valid(LAI)){ - if("SLA" %in% names(params)){ - leaf <- LAI * 1/params[1,"SLA"] #SLA converted to m2/gC in convert.samples - IC.params[["cf0"]] <- leaf - } else{ - SLA <- default.param[which(default.param$cmdFlag == "SLA"),"val"] - leaf <- LAI * 1/SLA #check that leaf isn't higher than total biomass if given? - IC.params[["cf0"]] <- leaf - } - } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && - is.valid(fine.roots) && is.valid(coarse.roots)){ - leaf <- (TotLivBiom - AbvGrndWood - fine.roots - coarse.roots) * 1000 #from standard kg C m-2 - if(leaf >= 0){ - IC.params[["cf0"]] <- leaf - } else{ - PEcAn.utils::logger.error("TotLivBiom is less than sum of AbvGrndWood and roots; using default for leaf biomass") - } - } + if ("leaf" %in% names(IC.pools)) { + IC.params[["cf0"]] <- IC.pools$leaf * 1000 #from standard kg C m-2 + } # cw0 initial pool of woody carbon (g/m2) - if (is.valid(AbvGrndWood)) { - if(is.valid(coarse.roots)){ - IC.params[["cw0"]] <- (AbvGrndWood + coarse.roots) * 1000 #from standard kg C m-2 - } else{ - PEcAn.utils::logger.error("write.configs.DALEC IC can't calculate total woody biomass with only AbvGrndWood; checking for total biomass.") - } - } else if (is.valid(TotLivBiom) && is.valid(leaf) && is.valid(fine.roots)){ - if(is.valid(LAI)){ - wood <- (1000*(TotLivBiom - fine.roots)) - leaf #convert TotLivBiom and fine.roots to g C m-2 from standard kg C m-2; leaf already converted via SLA - } - else{ - wood <- (TotLivBiom - leaf - fine.roots) * 1000 #from standard kg C m-2 - } - if (wood >= 0){ - IC.params[["cw0"]] <- wood - }else{ - PEcAn.utils::logger.error(paste("TotLivBiom (", TotLivBiom, ") is less than sum of leaf (", leaf, ") and fine roots(",fine.roots,"); using default for woody biomass.")) - } - } else{ - PEcAn.utils::logger.error("write.configs.DALEC IC could not calculate woody biomass; using defaults. Please provide AbvGrndWood and coarse_root_carbon OR leaf_carbon_content/LAI, fine_root_carbon_content, and TotLivBiom in netcdf.") - } + if ("wood" %in% names(IC.pools)) { + IC.params[["cw0"]] <- IC.pools$wood * 1000 #from standard kg C m-2 + } # cr0 initial pool of fine root carbon (g/m2) - if (is.valid(fine.roots)) { - IC.params[["cr0"]] <- fine.roots * 1000 #from standard kg C m-2 - } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && - is.valid(leaf) && is.valid(coarse.roots)){ - if(is.valid(LAI)){ - fine.roots <- ((TotLivBiom - AbvGrndWood - coarse.roots) * 1000) - leaf #from standard kg C m-2; leaf already converted - }else{ - fine.roots <- (TotLivBiom - AbvGrndWood - leaf - coarse.roots) * 1000 #from standard kg C m-2 - } - if(fine.roots >= 0){ - IC.params[["cr0"]] <- fine.roots - } else{ - PEcAn.utils::logger.error("TotLivBiom is less than sum of AbvGrndWood, coarse roots, and leaf; using default for fine.roots biomass") - } - } + if ("fine.roots" %in% names(IC.pools)) { + IC.params[["cr0"]] <- IC.pools$fine.roots * 1000 #from standard kg C m-2 + } ###non-living variables # cl0 initial pool of litter carbon (g/m2) - litter <- try(ncdf4::ncvar_get(IC.nc,"litter_carbon_content"),silent = TRUE) - if (is.valid(litter)) { - IC.params[["cl0"]] <- litter * 1000 #from standard kg C m-2 + if ("litter" %in% names(IC.pools)) { + IC.params[["cl0"]] <- IC.pools$litter * 1000 #from standard kg C m-2 } # cs0 initial pool of soil organic matter and woody debris carbon (g/m2) - soil <- try(ncdf4::ncvar_get(IC.nc,"soil_organic_carbon_content"),silent = TRUE) - wood.debris <- try(ncdf4::ncvar_get(IC.nc,"wood_debris_carbon_content"),silent = TRUE) - - if(is.valid(soil) && is.valid(wood.debris)){ - IC.params[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #from standard kg C m-2 - } else if(!is.valid(soil) && is.valid(wood.debris)){ - soil <- try(ncdf4::ncvar_get(IC.nc,"soil_carbon_content"),silent = TRUE) - if(is.valid(soil)){ - IC.params[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #from standard kg C m-2 - } else{ - PEcAn.utils::logger.error("write.configs.DALEC IC can't calculate soil matter pool without soil carbon; using default. Please provide soil_organic_carbon_content in netcdf.") + if("soil" %in% names(IC.pools)){ + if("wood.debris" %in% names(IC.pools)){ + IC.params[["cs0"]] <- (IC.pools$soil + sum(IC.pools$wood.debris)) * 1000 #from standard kg C m-2 + } else { + IC.params[["cs0"]] <- soil * 1000 #from standard kg C m-2 + PEcAn.utils::logger.warn("write.configs.DALEC IC: Loading soil carbon pool without woody debris.") } - } else if(is.valid(soil) && !is.valid(wood.debris)){ - IC.params[["cs0"]] <- soil * 1000 #from standard kg C m-2 - PEcAn.utils::logger.warn("write.configs.DALEC IC: Loading soil carbon pool without woody debris.") } ###Write to command line file From 1997a8f327ce1100802987ef9f955006cfff7b10 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 15:57:36 -0400 Subject: [PATCH 213/771] cleanup and fix stray SLA --- models/dalec/R/write.configs.dalec.R | 7 ------- modules/data.land/R/align_pools.R | 3 ++- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index fff741c4065..989901c9ed2 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -108,13 +108,6 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } ### INITIAL CONDITIONS - - #function to check that ncvar was loaded (numeric) and has a valid value (not NA or negative) - is.valid <- function(var){ - return(all(is.numeric(var) && !is.na(var) && var >= 0)) - } - - IC.params <- list() if(!is.null(settings$run$inputs$poolinitcond$path)) { diff --git a/modules/data.land/R/align_pools.R b/modules/data.land/R/align_pools.R index 59f1b57dbe5..e66af2485c0 100644 --- a/modules/data.land/R/align_pools.R +++ b/modules/data.land/R/align_pools.R @@ -59,7 +59,8 @@ align_pools <- function(nc.path, sla = NULL){ if (is.valid(leaf)) { IC.params[["leaf"]] <- leaf } else if(is.valid(LAI) && !is.null(sla)){ - leaf <- LAI * 1/SLA + leaf <- LAI * 1/sla + print(paste("using LAI", LAI, "and sla", sla, "to get", leaf)) IC.params[["leaf"]] <- leaf } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && is.valid(fine.roots) && is.valid(coarse.roots)){ From 25b492c9d6e7ce20dba91d471a9ecf4d4720e875 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 16:01:30 -0400 Subject: [PATCH 214/771] align_pools documentation --- modules/data.land/NAMESPACE | 1 + modules/data.land/man/align_pools.Rd | 22 ++++++++++++++++++++++ 2 files changed, 23 insertions(+) create mode 100644 modules/data.land/man/align_pools.Rd diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index 48d5c6a8761..084242db832 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -4,6 +4,7 @@ export(Clean_Tucson) export(InventoryGrowthFusion) export(InventoryGrowthFusionDiagnostics) export(Read_Tucson) +export(align_pools) export(buildJAGSdata_InventoryRings) export(download_package_rm) export(extract.stringCode) diff --git a/modules/data.land/man/align_pools.Rd b/modules/data.land/man/align_pools.Rd new file mode 100644 index 00000000000..c20780a7ecd --- /dev/null +++ b/modules/data.land/man/align_pools.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/align_pools.R +\name{align_pools} +\alias{align_pools} +\title{align_pools} +\usage{ +align_pools(nc.path, sla = NULL) +} +\arguments{ +\item{nc.path}{path to netcdf file containing standard dimensions and variables; currently supports these variables: TotLivBiom, leaf_carbon_content, LAI, AbvGrndWood, root_carbon_content, fine_root_carbon_content, coarse_root_carbon_content, litter_carbon_content, soil_organic_carbon_content, soil_carbon_content, wood_debris_carbon_content} + +\item{sla}{SLA in m2 / kg C if providing LAI for leaf carbon} +} +\value{ +list of pool values in kg C / m2 with generic names +} +\description{ +Calculates pools from given initial condition values, deriving complements where necessary/possible if given TotLivBiomass +} +\author{ +Anne Thomas +} From 7a390e38c910bb5c3aaacde2585ae03b515bc24e Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 16:02:53 -0400 Subject: [PATCH 215/771] LAI logger message --- modules/data.land/R/align_pools.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/R/align_pools.R b/modules/data.land/R/align_pools.R index e66af2485c0..1968fca1e69 100644 --- a/modules/data.land/R/align_pools.R +++ b/modules/data.land/R/align_pools.R @@ -60,7 +60,7 @@ align_pools <- function(nc.path, sla = NULL){ IC.params[["leaf"]] <- leaf } else if(is.valid(LAI) && !is.null(sla)){ leaf <- LAI * 1/sla - print(paste("using LAI", LAI, "and sla", sla, "to get", leaf)) + PEcAn.utils::logger.info(paste("using LAI", LAI, "and SLA", sla, "to get leafs", leaf)) IC.params[["leaf"]] <- leaf } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && is.valid(fine.roots) && is.valid(coarse.roots)){ From 82a0efd5fc61decf0c60392d37daaf67a8bcde53 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 16:05:14 -0400 Subject: [PATCH 216/771] use namespace --- models/dalec/R/write.configs.dalec.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 989901c9ed2..bac64fe9b1a 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -121,7 +121,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { sla <- default.param[which(default.param$cmdFlag == "SLA"),"val"] * 1000 #convert SLA to m2/kgC from m2/gC (dalec default) } - IC.pools <- align_pools(IC.path, sla) + IC.pools <- PEcAn.data.land::align_pools(IC.path, sla) if(!is.null(IC.pools)){ ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) From 9b4005ee7490f56389119b6ee52ae8dbb3e0c970 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 31 Jul 2017 16:15:15 -0400 Subject: [PATCH 217/771] fix soil var name --- models/dalec/R/write.configs.dalec.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index bac64fe9b1a..95c81203672 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -152,7 +152,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { if("wood.debris" %in% names(IC.pools)){ IC.params[["cs0"]] <- (IC.pools$soil + sum(IC.pools$wood.debris)) * 1000 #from standard kg C m-2 } else { - IC.params[["cs0"]] <- soil * 1000 #from standard kg C m-2 + IC.params[["cs0"]] <- IC.pools$soil * 1000 #from standard kg C m-2 PEcAn.utils::logger.warn("write.configs.DALEC IC: Loading soil carbon pool without woody debris.") } } From d7ee4b831d4398cc4f39acb7a6d222a08ad9023c Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Mon, 31 Jul 2017 17:04:53 -0400 Subject: [PATCH 218/771] delete siteid of gfdl and add GFDL string to outfolder name --- modules/data.atmosphere/R/download.GFDL.R | 2 +- modules/data.atmosphere/inst/registration/register.GFDL.xml | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/modules/data.atmosphere/R/download.GFDL.R b/modules/data.atmosphere/R/download.GFDL.R index 3c00f6daeb5..411b45d28ad 100644 --- a/modules/data.atmosphere/R/download.GFDL.R +++ b/modules/data.atmosphere/R/download.GFDL.R @@ -29,7 +29,7 @@ download.GFDL <- function(outfolder, start_date, end_date, site_id, lat.in, lon. model <- paste0(model) scenario <- paste0(scenario) ensemble_member <- paste0(ensemble_member) - outfolder <- paste0(outfolder, "_site_", paste0(site_id%/%1e+09, "-", site_id%%1e+09)) + outfolder <- paste0(outfolder, "GFDL_site_", paste0(site_id%/%1e+09, "-", site_id%%1e+09)) lat.in <- as.numeric(lat.in) lat_floor <- floor(lat.in) diff --git a/modules/data.atmosphere/inst/registration/register.GFDL.xml b/modules/data.atmosphere/inst/registration/register.GFDL.xml index 7820c25c2db..017616f3715 100644 --- a/modules/data.atmosphere/inst/registration/register.GFDL.xml +++ b/modules/data.atmosphere/inst/registration/register.GFDL.xml @@ -1,7 +1,6 @@ regional -1160 33 CF Meteorology From cbd4c574ac1a0d8b869ad77c24b3e8e51fd23d5c Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Mon, 31 Jul 2017 17:39:31 -0400 Subject: [PATCH 219/771] get rid of library call --- modules/data.atmosphere/R/download.GFDL.R | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/modules/data.atmosphere/R/download.GFDL.R b/modules/data.atmosphere/R/download.GFDL.R index 411b45d28ad..52f436da2f0 100644 --- a/modules/data.atmosphere/R/download.GFDL.R +++ b/modules/data.atmosphere/R/download.GFDL.R @@ -10,13 +10,11 @@ ##' @param model , select which GFDL model to run (options are CM3, ESM2M, ESM2G) ##' @param scenario , select which scenario to run (options are rcp26, rcp45, rcp60, rcp85) ##' @param ensemble_member , select which ensemble_member to initialize the run (options are r1i1p1, r3i1p1, r5i1p1) -##' ##' @author James Simkins download.GFDL <- function(outfolder, start_date, end_date, site_id, lat.in, lon.in, overwrite = FALSE, verbose = FALSE, model = "CM3", scenario = "rcp45", ensemble_member = "r1i1p1", ...) { - library(PEcAn.utils) - + if(is.null(model)) model <- "CM3" if(is.null(scenario)) scenario <- "rcp45" if(is.null(ensemble_member)) ensemble_member <- "r1i1p1" @@ -139,7 +137,7 @@ download.GFDL <- function(outfolder, start_date, end_date, site_id, lat.in, lon. ncdf4::nc_close(loc) results$file[i] <- loc.file - results$host[i] <- fqdn() + results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year, "-01-01 00:00:00") results$enddate[i] <- paste0(year, "-12-31 23:59:59") results$mimetype[i] <- "application/x-netcdf" From d0c634d82ecd5ceed9262c948546c79c353db26a Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Mon, 31 Jul 2017 19:42:17 -0400 Subject: [PATCH 220/771] added titles and MIT Liscence (temporary) --- web/drag.and.drop.upload | 28 ++++++++++++++++++++++++++-- 1 file changed, 26 insertions(+), 2 deletions(-) diff --git a/web/drag.and.drop.upload b/web/drag.and.drop.upload index 580410c874b..8c3301a53da 100644 --- a/web/drag.and.drop.upload +++ b/web/drag.and.drop.upload @@ -1,4 +1,4 @@ - +# authentication script $min_upload_level) { exit; } +# drag and drop window. I did not build this. Still looking for the liscence. Orignial can be found at: https://html5demos.com/dnd-upload/ + +*Copyright (c) 2010 Remy Sharp, http://html5demos.com + +*Permission is hereby granted, free of charge, to any person obtaining +*a copy of this software and associated documentation files (the +*"Software"), to deal in the Software without restriction, including +*without limitation the rights to use, copy, modify, merge, publish, +*distribute, sublicense, and/or sell copies of the Software, and to +*permit persons to whom the Software is furnished to do so, subject to +*the following conditions: + +*The above copyright notice and this permission notice shall be +*included in all copies or substantial portions of the Software. + +*THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +*EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +*MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +*NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +*LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +*OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +*WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + Drag and drop, automatic upload -
    -
    -
    - -

    File API & FileReader API not supported

    -

    XHR2's FormData is not supported

    -

    XHR2's upload progress isn't supported

    -

    Upload progress: 0

    -

    Drag an image from your desktop on to the drop zone above to see the browser both render the preview, but also upload automatically to this server.

    -
    - From 329f63c7ff80614049aed810136442f54ab3733c Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 1 Aug 2017 17:19:30 -0400 Subject: [PATCH 235/771] rename file to .php --- web/drag.and.drop.upload.php | 165 +++++++++++++++++++++++++++++++++++ 1 file changed, 165 insertions(+) create mode 100644 web/drag.and.drop.upload.php diff --git a/web/drag.and.drop.upload.php b/web/drag.and.drop.upload.php new file mode 100644 index 00000000000..d8c1bd6ed19 --- /dev/null +++ b/web/drag.and.drop.upload.php @@ -0,0 +1,165 @@ +# authentication script + $min_upload_level) { + header( "Location: index.php"); + close_database(); + exit; +} + +# drag and drop window. +*Copyright (c) 2010 Remy Sharp, http://html5demos.com + +*Permission is hereby granted, free of charge, to any person obtaining +*a copy of this software and associated documentation files (the +*"Software"), to deal in the Software without restriction, including +*without limitation the rights to use, copy, modify, merge, publish, +*distribute, sublicense, and/or sell copies of the Software, and to +*permit persons to whom the Software is furnished to do so, subject to +*the following conditions: + +*The above copyright notice and this permission notice shall be +*included in all copies or substantial portions of the Software. + +*THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +*EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +*MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +*NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +*LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +*OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +*WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + + +Drag and drop, automatic upload + +
    +
    +
    + +

    File API & FileReader API not supported

    +

    XHR2's FormData is not supported

    +

    XHR2's upload progress isn't supported

    +

    Upload progress: 0

    +

    Drag a file from your desktop on to the drop zone above to begin uploading to betyDB.

    +
    + From 7528d4152b7afe9169fa93a4aa03fcb251007362 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 1 Aug 2017 17:50:58 -0400 Subject: [PATCH 236/771] Added comments to make code more comprehensible --- web/drag.and.drop.upload.php | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/web/drag.and.drop.upload.php b/web/drag.and.drop.upload.php index d8c1bd6ed19..deb327cec1e 100644 --- a/web/drag.and.drop.upload.php +++ b/web/drag.and.drop.upload.php @@ -80,6 +80,7 @@ formdata: document.getElementById('formdata'), progress: document.getElementById('progress') }, + # This could be problematic: What generic mimetypes should we include? acceptedTypes = { 'image/png': true, @@ -101,7 +102,7 @@ } }); -function previewfile(file) { +function previewfile(file) { # don't know if we need to display a preview of the file... It could just display the progress bar then, 'done' if (tests.filereader === true && acceptedTypes[file.type] === true) { var reader = new FileReader(); reader.onload = function (event) { @@ -129,7 +130,7 @@ function readfiles(files) { // now post a new XHR request if (tests.formdata) { var xhr = new XMLHttpRequest(); - xhr.open('POST', '/devnull.php'); + xhr.open('POST', '/devnull.php'); # @robkooper says this fetches the file from the server side xhr.onload = function() { progress.value = progress.innerHTML = 100; }; @@ -143,7 +144,7 @@ function readfiles(files) { } } - xhr.send(formData); + xhr.send(formData); } } From 0e07987f33f17261a6618a66aee218363d1cbe19 Mon Sep 17 00:00:00 2001 From: kragosta Date: Tue, 1 Aug 2017 22:01:44 -0400 Subject: [PATCH 237/771] Quotes in file name --- models/cable/R/write.config.CABLE.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/cable/R/write.config.CABLE.R b/models/cable/R/write.config.CABLE.R index ceb8856b640..2599443f6e0 100644 --- a/models/cable/R/write.config.CABLE.R +++ b/models/cable/R/write.config.CABLE.R @@ -120,6 +120,6 @@ write.config.CABLE <- function(defaults, trait.values, settings, run.id) { config.text <- gsub("@OUTFILE@", paste0("out", run.id), config.text) #----------------------------------------------------------------------- - config.file.name <- cable.nml + config.file.name <- "cable.nml" writeLines(config.text, con = paste(outdir, config.file.name, sep = "")) } # write.config.CABLE From de5845068144168eef91158053233459693f7180 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Wed, 2 Aug 2017 06:53:38 -0500 Subject: [PATCH 238/771] Subset input id based on vm machine --- shiny/workflowPlot/server.R | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index c0edc16f98f..4d3845585b2 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -16,6 +16,7 @@ options(shiny.maxRequestSize=100*1024^2) # Define server logic server <- shinyServer(function(input, output, session) { bety <- betyConnect() + # bety <- betyConnect('/home/carya/pecan/web/config.php') # Update all workflow ids observe({ # Ideally get_workflow_ids function (line 137) in db/R/query.dplyr.R should take a flag to check @@ -117,7 +118,7 @@ server <- shinyServer(function(input, output, session) { getSettingsFromWorkflowId <- function(bety,workflowID){ basePath <- tbl(bety, 'workflows') %>% filter(id %in% workflowID) %>% pull(folder) configPath <- file.path(basePath, 'pecan.CONFIGS.xml') - # Second way of proving configPath. More of a hack + # Second way of providing configPath. More of a hack # configPath <- paste0("~/output/PEcAn_",workflowID,"/pecan.CONFIGS.xml") settings<-PEcAn.settings::read.settings(configPath) return(settings) @@ -136,14 +137,24 @@ server <- shinyServer(function(input, output, session) { }) # Get input id from selected site id getInputs <- function(bety,site_Id){ - inputIds <- tbl(bety, 'inputs') %>% filter(site_id %in% site_Id) %>% distinct(id) %>% pull(id) - inputIds <- sort(inputIds) - return(inputIds) + # site_Id <- c(772) + # inputIds <- tbl(bety, 'inputs') %>% filter(site_id %in% site_Id) %>% distinct(id) %>% pull(id) + # inputIds <- sort(inputIds) + my_hostname <- PEcAn.utils::fqdn() + my_machine_id <- tbl(bety, 'machines') %>% filter(hostname == my_hostname) %>% pull(id) + inputs_df <- tbl(bety, 'dbfiles') %>% + filter(container_type == 'Input', machine_id == my_machine_id) %>% + left_join(tbl(bety, 'inputs') %>% filter(site_id %in% site_Id), by = c('container_id' = 'id')) %>% + collect() + inputs_df <- inputs_df[order(inputs_df$container_id),] + input_selection_list <- paste(inputs_df$container_id, inputs_df$name) + return(input_selection_list) } observe({ req(input$all_site_id) updateSelectizeInput(session, "all_input_id", choices=getInputs(bety,input$all_site_id)) }) + # Renders ggplotly output$outputPlot <- renderPlotly({ # Error messages @@ -187,13 +198,14 @@ server <- shinyServer(function(input, output, session) { # Check if user wants to load external data # Similar to using event reactive if (input$load_data>0) { - # File_format <- getFileFormat(bety,input$formatID) # Retaining the code for getting file format using inputRecordID - File_format <- getFileFormat(bety,input$all_input_id) + # File_format <- getFileFormat(bety,input$formatID) + # Input ID is of the form (ID Name). Split by space and use the first element + input_ID <- strsplit(input$all_input_id,' ')[[1]][1] + File_format <- getFileFormat(bety,input_ID) ids_DF <- parse_ids_from_input_runID(input$all_run_id) settings <- getSettingsFromWorkflowId(bety,ids_DF$wID[1]) - inFile <- input$fileUploaded - filePath <- PEcAn.DB::dbfile.file(type = 'Input', id = input$all_input_id,con = bety$con) + filePath <- PEcAn.DB::dbfile.file(type = 'Input', id = input_ID,con = bety$con) externalData <- loadObservationData(bety,settings,filePath,File_format) # If variable found in the uploaded file if (input$variable_name %in% names(externalData)){ From a1f7c41b4e4f6e0c227ac83814714e773cfc95f5 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 2 Aug 2017 09:24:46 -0400 Subject: [PATCH 239/771] Remove deprecated Fortran inversion For now, it lives on in the Git history. It may be resurrected at some point, though I'd probably rather just call the Fortran RTMs via Rcpp instead if I want to speed up the inversion with compiled code. --- modules/rtm/R/invert.fast.R | 77 - modules/rtm/R/invert.fast.re.R | 89 - modules/rtm/man/invert.fast.Rd | 54 - modules/rtm/man/invert.fast.re.Rd | 57 - modules/rtm/src/Makevars | 12 +- modules/rtm/src/RTM/modules/mod_combine.f90 | 18 - modules/rtm/src/RTM/modules/mod_rtm.f90 | 105 -- .../rtm/src/RTM/modules/mod_selectmodel.f90 | 28 - .../rtm/src/RTM/modules/mod_statistics.f90 | 46 - modules/rtm/src/RTM/modules/random.f90 | 1592 ----------------- modules/rtm/src/RTM/statistics/inversion.f90 | 64 - .../rtm/src/RTM/statistics/inversion.re.f90 | 89 - modules/rtm/src/RTM/statistics/prior.f90 | 33 - modules/rtm/src/RTM/statistics/re.model.f90 | 28 - modules/rtm/src/RTM/statistics/samplers.f90 | 56 - .../rtm/src/RTM/statistics/samplers.re.f90 | 95 - 16 files changed, 3 insertions(+), 2440 deletions(-) delete mode 100644 modules/rtm/R/invert.fast.R delete mode 100644 modules/rtm/R/invert.fast.re.R delete mode 100644 modules/rtm/man/invert.fast.Rd delete mode 100644 modules/rtm/man/invert.fast.re.Rd delete mode 100644 modules/rtm/src/RTM/modules/mod_combine.f90 delete mode 100644 modules/rtm/src/RTM/modules/mod_rtm.f90 delete mode 100644 modules/rtm/src/RTM/modules/mod_selectmodel.f90 delete mode 100644 modules/rtm/src/RTM/modules/mod_statistics.f90 delete mode 100644 modules/rtm/src/RTM/modules/random.f90 delete mode 100644 modules/rtm/src/RTM/statistics/inversion.f90 delete mode 100644 modules/rtm/src/RTM/statistics/inversion.re.f90 delete mode 100644 modules/rtm/src/RTM/statistics/prior.f90 delete mode 100644 modules/rtm/src/RTM/statistics/re.model.f90 delete mode 100644 modules/rtm/src/RTM/statistics/samplers.f90 delete mode 100644 modules/rtm/src/RTM/statistics/samplers.re.f90 diff --git a/modules/rtm/R/invert.fast.R b/modules/rtm/R/invert.fast.R deleted file mode 100644 index 84ddf96bde0..00000000000 --- a/modules/rtm/R/invert.fast.R +++ /dev/null @@ -1,77 +0,0 @@ -#' Bayesian RTM inversion: Fortran implementation -#' -#' Performs a Bayesian inversion of a Radiative Transfer Model. -#' -#' @details Sampling is performed using an adaptive Metropolis-Hastings -#' algorithm operating independently on each parameter. The model takes both -#' paramters and constants as an argument -- parameters (`inits`) are sampled -#' and treated as random (unknown) while constants (`cons`) are fixed. Normal -#' or log-normal priors are be specified by passing a vector of means (`pmu`), -#' standard deviations (`psd`), and a logical of whether or not to use the -#' lognorml (`plog`). Minimum values for the parameters must be given as a -#' vector (`minp`). -#' @author Alexey Shiklomanov -#' @param modname Name of the model to invert (character). -#' Refer to `data/model.list.csv` -#' @param observed Observed reflectance. Can be a vector, matrix, -#' or data.frame; BUT NOTE: all are coerced via 'as.matrix' -#' @param inits Named vector of parameters to invert. Names are required! -#' @param cons Named vector of constants. Names are required! -#' @param pmu Numeric vector of prior means for inversion parameters. -#' Must line up with `inits` -#' @param psd Numeric vector of prior standard deviations for inversion -#' parameters. Must line up with `inits`. -#' @param plog Logical vector. Whether or not to use lognormal -#' distribution for the prior. NOTE: `pmu` and `psd` are -#' the distribution parameters, NOT the distribution's actual -#' mean and standard deviation. -#' @param minp Numeric vector of minimum values for parameters. -#' @param ngibbs Number of iterations for MCMC -#' @return Matrix (ngibbs x (length(inits) + 1)) of MCMC samples -#' of parameters. -invert.fast <- function(modname, observed, inits, cons, pmu, psd, plog, minp, ngibbs) { - stop('This function is deprecated. Please use `invert.auto`.') - data(model.list) - model.set <- model.list[model.list$modname == modname, ] - if (nrow(model.set) < 1) { - stop(sprintf("Error: Model '%s' not found", modname)) - } - modcode <- as.integer(model.set$modcode) - print(sprintf("Model: %s; Code: %d", model.set$fullname, modcode)) - - names.all <- unlist(strsplit(model.set$par.names, " ")) - names.inits <- names(inits) - stopifnot(!is.null(names.inits)) - npars <- length(inits) - ipars <- match(names.inits, names.all) - - if (length(cons) > 0) { - names.cons <- names(cons) - stopifnot(!is.null(names.cons)) - ncons <- length(cons) - icons <- match(names.cons, names.all) - } else { - cons <- numeric(0) - ncons <- as.integer(0) - icons <- numeric(0) - } - - observed <- as.matrix(observed) - nspec <- ncol(observed) - - ngibbs <- as.integer(ngibbs) - results <- matrix(0, ngibbs, npars + 1) - seed <- round(1e+08 * runif(100)) - seed <- as.integer(seed) - - in.list <- list("invert_basic", observed, nspec, modcode, inits, npars, ipars, - cons, ncons, icons, pmu, psd, plog, minp, ngibbs, results, seed) - - t1 <- proc.time() - out.list <- do.call(.Fortran, in.list) - t2 <- proc.time() - print(t2 - t1) - outmat <- out.list[[length(out.list) - 1]] - colnames(outmat) <- c(names.inits, "rsd") - return(outmat) -} # invert.fast diff --git a/modules/rtm/R/invert.fast.re.R b/modules/rtm/R/invert.fast.re.R deleted file mode 100644 index 9fc1c45c821..00000000000 --- a/modules/rtm/R/invert.fast.re.R +++ /dev/null @@ -1,89 +0,0 @@ -#' Bayesian inversion with random effects -#' -#' Performs a Bayesian inversion of a Radiative -#' Transfer model with individual random effects. Sampling -#' is performed using an adaptive Metropolis-Hastings -#' algorithm operating independently on each parameter. See -#' also: `invert.fast`. -#' @author Alexey Shiklomanov -#' @param modname Name of the model to invert (character). -#' Refer to `model.list` -#' @param observed Observed reflectance. Can be a vector, -#' matrix, or data.frame; BUT NOTE: all are coerced to -#' matrix via `as.matrix`. -#' @param inits Named vector of parameters to invert. Names -#' are required! -#' @param cons Numeric vector of constants. Names are -#' required! -#' @param rand Numeric matrix of initial values for random -#' effects, with dimensions (npars x nspec), where npars is -#' the number of parameters and nspec is the number of -#' spectra. -#' @param pmu Numeric vector of prior means for inversion -#' parameters. Must line up with `inits` -#' @param psd Numeric vector of prior standard deviations -#' for inversion parameters. Must line up with `inits`. -#' @param plog Logical vector. Whether or not to use -#' lognormal distribution for the prior. NOTE: `pmu` and `psd` -#' are the distribution parameters, NOT the distribution's -#' actual mean and standard deviation. -#' @param minp Numeric vector of minimum values for parameters. -#' @param ngibbs Number of iterations for MCMC -#' @return Matrix (ngibbs x (npars*(nspec+2)+1)) of MCMC -#' samples of parameters. -invert.fast.re <- function(modname, observed, inits, rand, cons, pmu, psd, plog, - minp, ngibbs) { - stop('This function is deprecated. Please use `invert.auto`.') - # Get model code number - data(model.list) - model.set <- model.list[model.list$modname == modname, ] - if (all(is.na(model.set[, -1, with = FALSE]))) { - stop(sprintf("Error: Model '%s' not found", modname)) - } - modcode <- as.integer(model.set$modcode) - print(sprintf("Model: %s; Code: %d", model.set$fullname, modcode)) - - # Setup initial conditions and constants - names.all <- unlist(strsplit(model.set$par.names, " ")) - names.inits <- names(inits) - stopifnot(!is.null(names.inits)) - npars <- length(inits) - ipars <- match(names.inits, names.all) - if (length(cons) > 0) { - names.cons <- names(cons) - stopifnot(!is.null(names.cons)) - ncons <- length(cons) - icons <- match(names.cons, names.all) - } else { - cons <- numeric(0) - ncons <- as.integer(0) - icons <- numeric(0) - } - - # Set up random effects - names.rand <- rownames(rand) - stopifnot(!is.null(names.rand) && length(names.rand) == length(inits)) - ord.rand <- match(names.rand, names.inits) - rand <- rand[ord.rand, ] - - # Force correct types for other parameters - observed <- as.matrix(observed) - nspec <- ncol(observed) - ngibbs <- as.integer(ngibbs) - results <- matrix(0, ngibbs, npars * (nspec + 2) + 1) - seed <- round(1e+08 * runif(100)) - seed <- as.integer(seed) - - # Group parameters and execute - in.list <- list("invert_re", observed, nspec, modcode, inits, npars, ipars, rand, - cons, ncons, icons, pmu, psd, plog, minp, ngibbs, results, seed) - t1 <- proc.time() - out.list <- do.call(.Fortran, in.list) - t2 <- proc.time() - print(t2 - t1) - outmat <- out.list[[length(out.list) - 1]] - colnames(outmat) <- c(names.inits, - sprintf("RE_%s_%d", names.rand, rep(1:nspec, each = npars)), - sprintf("Tau_%s", names.rand), "rsd") - return(outmat) -} # invert.fast.re diff --git a/modules/rtm/man/invert.fast.Rd b/modules/rtm/man/invert.fast.Rd deleted file mode 100644 index 9f463a51811..00000000000 --- a/modules/rtm/man/invert.fast.Rd +++ /dev/null @@ -1,54 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/invert.fast.R -\name{invert.fast} -\alias{invert.fast} -\title{Bayesian RTM inversion: Fortran implementation} -\usage{ -invert.fast(modname, observed, inits, cons, pmu, psd, plog, minp, ngibbs) -} -\arguments{ -\item{modname}{Name of the model to invert (character). -Refer to \code{data/model.list.csv}} - -\item{observed}{Observed reflectance. Can be a vector, matrix, -or data.frame; BUT NOTE: all are coerced via 'as.matrix'} - -\item{inits}{Named vector of parameters to invert. Names are required!} - -\item{cons}{Named vector of constants. Names are required!} - -\item{pmu}{Numeric vector of prior means for inversion parameters. -Must line up with \code{inits}} - -\item{psd}{Numeric vector of prior standard deviations for inversion -parameters. Must line up with \code{inits}.} - -\item{plog}{Logical vector. Whether or not to use lognormal -distribution for the prior. NOTE: \code{pmu} and \code{psd} are -the distribution parameters, NOT the distribution's actual -mean and standard deviation.} - -\item{minp}{Numeric vector of minimum values for parameters.} - -\item{ngibbs}{Number of iterations for MCMC} -} -\value{ -Matrix (ngibbs x (length(inits) + 1)) of MCMC samples -of parameters. -} -\description{ -Performs a Bayesian inversion of a Radiative Transfer Model. -} -\details{ -Sampling is performed using an adaptive Metropolis-Hastings -algorithm operating independently on each parameter. The model takes both -paramters and constants as an argument -- parameters (\code{inits}) are sampled -and treated as random (unknown) while constants (\code{cons}) are fixed. Normal -or log-normal priors are be specified by passing a vector of means (\code{pmu}), -standard deviations (\code{psd}), and a logical of whether or not to use the -lognorml (\code{plog}). Minimum values for the parameters must be given as a -vector (\code{minp}). -} -\author{ -Alexey Shiklomanov -} diff --git a/modules/rtm/man/invert.fast.re.Rd b/modules/rtm/man/invert.fast.re.Rd deleted file mode 100644 index bc075011b95..00000000000 --- a/modules/rtm/man/invert.fast.re.Rd +++ /dev/null @@ -1,57 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/invert.fast.re.R -\name{invert.fast.re} -\alias{invert.fast.re} -\title{Bayesian inversion with random effects} -\usage{ -invert.fast.re(modname, observed, inits, rand, cons, pmu, psd, plog, minp, - ngibbs) -} -\arguments{ -\item{modname}{Name of the model to invert (character). -Refer to \code{model.list}} - -\item{observed}{Observed reflectance. Can be a vector, -matrix, or data.frame; BUT NOTE: all are coerced to -matrix via \code{as.matrix}.} - -\item{inits}{Named vector of parameters to invert. Names -are required!} - -\item{rand}{Numeric matrix of initial values for random -effects, with dimensions (npars x nspec), where npars is -the number of parameters and nspec is the number of -spectra.} - -\item{cons}{Numeric vector of constants. Names are -required!} - -\item{pmu}{Numeric vector of prior means for inversion -parameters. Must line up with \code{inits}} - -\item{psd}{Numeric vector of prior standard deviations -for inversion parameters. Must line up with \code{inits}.} - -\item{plog}{Logical vector. Whether or not to use -lognormal distribution for the prior. NOTE: \code{pmu} and \code{psd} -are the distribution parameters, NOT the distribution's -actual mean and standard deviation.} - -\item{minp}{Numeric vector of minimum values for parameters.} - -\item{ngibbs}{Number of iterations for MCMC} -} -\value{ -Matrix (ngibbs x (npars*(nspec+2)+1)) of MCMC -samples of parameters. -} -\description{ -Performs a Bayesian inversion of a Radiative -Transfer model with individual random effects. Sampling -is performed using an adaptive Metropolis-Hastings -algorithm operating independently on each parameter. See -also: \code{invert.fast}. -} -\author{ -Alexey Shiklomanov -} diff --git a/modules/rtm/src/Makevars b/modules/rtm/src/Makevars index 3faeac698ea..a59b0921034 100755 --- a/modules/rtm/src/Makevars +++ b/modules/rtm/src/Makevars @@ -15,19 +15,13 @@ clean : md = RTM/modules/ -m1 : $(md)mod_types.o \ - $(md)random.o +m1 : $(md)mod_types.o m2 : m1 \ - $(md)dataSpec/dataSpec_wavelength.o \ - $(md)mod_combine.o \ - $(md)mod_statistics.o + $(md)dataSpec/dataSpec_wavelength.o -m3 : m2 $(md)mod_rtm.o - -modules : m3 \ +modules : m2 \ $(md)dataSpec/dataSpec_sun.o \ - $(md)mod_selectmodel.o \ $(md)dataSpec/dataSpec_refractive.o \ $(md)dataSpec/dataSpec_prospectd.o \ $(md)dataSpec/dataSpec_prospect5b.o \ diff --git a/modules/rtm/src/RTM/modules/mod_combine.f90 b/modules/rtm/src/RTM/modules/mod_combine.f90 deleted file mode 100644 index efefe3d7330..00000000000 --- a/modules/rtm/src/RTM/modules/mod_combine.f90 +++ /dev/null @@ -1,18 +0,0 @@ -module mod_combine - use mod_types - contains - subroutine combine_params(params, np, indp, & - constants, nc, indc, allparams) - - ! Inputs - integer(kind=i2), intent(in) :: np, nc, indp(np), indc(nc) - real(kind=r2), intent(in) :: params(np), constants(nc) - - ! Internals - real(kind=r2) :: allparams(np+nc) - - allparams(indp) = params - if(nc > 0) allparams(indc) = constants - return - end subroutine -end module diff --git a/modules/rtm/src/RTM/modules/mod_rtm.f90 b/modules/rtm/src/RTM/modules/mod_rtm.f90 deleted file mode 100644 index ee7a76a2ec7..00000000000 --- a/modules/rtm/src/RTM/modules/mod_rtm.f90 +++ /dev/null @@ -1,105 +0,0 @@ -module mod_rtm - use mod_types - use mod_dataspec_wavelength - use mod_combine - contains - - !!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!!! PROSPECT family !!!!! - !!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine prospect5b_inv(params, np, indp, & - constants, nc, indc, Refl) - implicit none - - ! Inputs - integer(kind=i2), intent(in) :: np, nc, indp(np), indc(nc) - real(kind=r2), intent(in) :: params(np), constants(nc) - - ! Outputs - real(kind=r2), intent(out) :: Refl(nw) - - ! Internals - real(kind=r2) :: RT(nw,2), allparams(np+nc) - - call combine_params(params, np, indp, constants, nc, indc, & - allparams) - call prospect_5b(allparams(1), allparams(2), allparams(3), & - allparams(4), allparams(5), allparams(6), RT) - Refl = RT(:,1) - return - end subroutine - subroutine prospect5_inv(params, np, indp, & - constants, nc, indc, Refl) - implicit none - - ! Inputs - integer(kind=i2), intent(in) :: np, nc, indp(np), indc(nc) - real(kind=r2), intent(in) :: params(np), constants(nc) - - ! Outputs - real(kind=r2), intent(out) :: Refl(nw) - - ! Internals - real(kind=r2) :: RT(nw,2), allparams(np+nc) - - call combine_params(params, np, indp, constants, nc, indc, & - allparams) - call prospect_5(allparams(1), allparams(2), allparams(3), & - allparams(4), allparams(5), RT) - Refl = RT(:,1) - return - end subroutine - subroutine prospect4_inv(params, np, indp, & - constants, nc, indc, Refl) - implicit none - - ! Inputs - integer(kind=i2), intent(in) :: np, nc, indp(np), indc(nc) - real(kind=r2), intent(in) :: params(np), constants(nc) - - ! Outputs - real(kind=r2), intent(out) :: Refl(nw) - - ! Internals - real(kind=r2) :: RT(nw,2), allparams(np+nc) - - call combine_params(params, np, indp, constants, nc, indc, & - allparams) - call prospect_4(allparams(1), allparams(2), allparams(3), & - allparams(4), RT) - Refl = RT(:,1) - return - end subroutine - - !!!!!!!!!!!!!!!!!!!!!!! - !!!!! Sail family !!!!! - !!!!!!!!!!!!!!!!!!!!!!! - subroutine pro4sail_inv(params, np, indp, & - constants, nc, indc, Refl) - implicit none - - ! Inputs - integer(kind=i2), intent(in) :: np, nc, indp(np), indc(nc) - real(kind=r2), intent(in) :: params(np), constants(nc) - - ! Outputs - real(kind=r2), intent(out) :: Refl(nw) - - ! Internals - real(kind=r2) :: rddt(nw), rsdt(nw), rdot(nw), rsot(nw) - real(kind=r2) :: allparams(np+nc) - - call combine_params(params, np, indp, constants, nc, indc, & - allparams) - call pro4sail(allparams(1), allparams(2), allparams(3), & - allparams(4), allparams(5), allparams(6), & - allparams(7), allparams(8), allparams(9), & - allparams(10), allparams(11), allparams(12), & - allparams(13), allparams(14), allparams(15), & - rddt, rsdt, rdot, rsot) - Refl = rddt - return - end subroutine - -end module diff --git a/modules/rtm/src/RTM/modules/mod_selectmodel.f90 b/modules/rtm/src/RTM/modules/mod_selectmodel.f90 deleted file mode 100644 index d02c03c937b..00000000000 --- a/modules/rtm/src/RTM/modules/mod_selectmodel.f90 +++ /dev/null @@ -1,28 +0,0 @@ -module mod_selectmodel - use mod_types - use mod_rtm - contains - subroutine model_select(modcode, model) - implicit none - integer(kind=i2) :: modcode - procedure(), pointer :: model => null() - - select case (modcode) - case(1152) - print *, "FORTRAN model: PROSPECT 5B" - model => prospect5b_inv - case(1151) - print *, "Fortran model: PROSPECT 5" - model => prospect5_inv - case(1141) - print *, "Fortran model: PROSPECT 4" - model => prospect4_inv - case(2111) - print *, "Fortran model: PRO4SAIL" - model => pro4sail_inv - case default - print *, "!!! ERROR: Invalid function name !!!" - stop - end select - end subroutine -end module diff --git a/modules/rtm/src/RTM/modules/mod_statistics.f90 b/modules/rtm/src/RTM/modules/mod_statistics.f90 deleted file mode 100644 index dbc7683c030..00000000000 --- a/modules/rtm/src/RTM/modules/mod_statistics.f90 +++ /dev/null @@ -1,46 +0,0 @@ -module mod_statistics - use mod_types - use random - implicit none - - contains - - ! Random number generation - function rnorm(mu, sigma) - real(kind=r2), intent(in) :: mu, sigma - real(kind=r2) :: z - real(kind=r2) :: rnorm - - rnorm = mu + random_normal() * sigma - return - end function - - function rgamma(shp, scl) - ! NOTE: random_gamma takes real(4) as argument for shape. - ! Therefore, coerce real(8) (r2) argument `shp` to real(4) (r1) - ! by copying. - real(kind=r2), intent(in) :: shp, scl - real(kind=r1) :: shp2 - real(kind=r2) :: rgamma - - shp2 = shp - rgamma = random_gamma(shp2, .true.) * scl - return - end function - - ! Density calculation - function ldnorm(x, mu, sigma) - real(kind=r2), intent(in) :: x, mu, sigma - real(kind=r2) :: hlog2pi, lsig, xm, s2, ex - real(kind=r2) :: ldnorm - - hlog2pi = -0.39908993417 !! -0.5 * log(2pi) - lsig = -log(sigma) - xm = x - mu - s2 = 2 * sigma * sigma - ex = -xm * xm / s2 - ldnorm = hlog2pi + lsig + ex - return - end function - -end module diff --git a/modules/rtm/src/RTM/modules/random.f90 b/modules/rtm/src/RTM/modules/random.f90 deleted file mode 100644 index 5c059373292..00000000000 --- a/modules/rtm/src/RTM/modules/random.f90 +++ /dev/null @@ -1,1592 +0,0 @@ -MODULE random -! Source: http://jblevins.org/mirror/amiller/ -! A module for random number generation from the following distributions: -! -! Distribution Function/subroutine name -! -! Normal (Gaussian) random_normal -! Gamma random_gamma -! Chi-squared random_chisq -! Exponential random_exponential -! Weibull random_Weibull -! Beta random_beta -! t random_t -! Multivariate normal random_mvnorm -! Generalized inverse Gaussian random_inv_gauss -! Poisson random_Poisson -! Binomial random_binomial1 * -! random_binomial2 * -! Negative binomial random_neg_binomial -! von Mises random_von_Mises -! Cauchy random_Cauchy -! -! Generate a random ordering of the integers 1 .. N -! random_order -! Initialize (seed) the uniform random number generator for ANY compiler -! seed_random_number - -! Lognormal - see note below. - -! ** Two functions are provided for the binomial distribution. -! If the parameter values remain constant, it is recommended that the -! first function is used (random_binomial1). If one or both of the -! parameters change, use the second function (random_binomial2). - -! The compilers own random number generator, SUBROUTINE RANDOM_NUMBER(r), -! is used to provide a source of uniformly distributed random numbers. - -! N.B. At this stage, only one random number is generated at each call to -! one of the functions above. - -! The module uses the following functions which are included here: -! bin_prob to calculate a single binomial probability -! lngamma to calculate the logarithm to base e of the gamma function - -! Some of the code is adapted from Dagpunar's book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 -! -! In most of Dagpunar's routines, there is a test to see whether the value -! of one or two floating-point parameters has changed since the last call. -! These tests have been replaced by using a logical variable FIRST. -! This should be set to .TRUE. on the first call using new values of the -! parameters, and .FALSE. if the parameter values are the same as for the -! previous call. - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Lognormal distribution -! If X has a lognormal distribution, then log(X) is normally distributed. -! Here the logarithm is the natural logarithm, that is to base e, sometimes -! denoted as ln. To generate random variates from this distribution, generate -! a random deviate from the normal distribution with mean and variance equal -! to the mean and variance of the logarithms of X, then take its exponential. - -! Relationship between the mean & variance of log(X) and the mean & variance -! of X, when X has a lognormal distribution. -! Let m = mean of log(X), and s^2 = variance of log(X) -! Then -! mean of X = exp(m + 0.5s^2) -! variance of X = (mean(X))^2.[exp(s^2) - 1] - -! In the reverse direction (rarely used) -! variance of log(X) = log[1 + var(X)/(mean(X))^2] -! mean of log(X) = log(mean(X) - 0.5var(log(X)) - -! N.B. The above formulae relate to population parameters; they will only be -! approximate if applied to sample values. -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Version 1.13, 2 October 2000 -! Changes from version 1.01 -! 1. The random_order, random_Poisson & random_binomial routines have been -! replaced with more efficient routines. -! 2. A routine, seed_random_number, has been added to seed the uniform random -! number generator. This requires input of the required number of seeds -! for the particular compiler from a specified I/O unit such as a keyboard. -! 3. Made compatible with Lahey's ELF90. -! 4. Marsaglia & Tsang algorithm used for random_gamma when shape parameter > 1. -! 5. INTENT for array f corrected in random_mvnorm. - -! Author: Alan Miller -! e-mail: amiller @ bigpond.net.au - -IMPLICIT NONE -REAL, PRIVATE :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0, & - vsmall = TINY(1.0), vlarge = HUGE(1.0) -PRIVATE :: integral -INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) - - -CONTAINS - - -FUNCTION random_normal() RESULT(fn_val) - -! Adapted from the following Fortran 77 code -! ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM. -! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, -! VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435. - -! The function random_normal() returns a normally distributed pseudo-random -! number with zero mean and unit variance. - -! The algorithm uses the ratio of uniforms method of A.J. Kinderman -! and J.F. Monahan augmented with quadratic bounding curves. - -REAL :: fn_val - -! Local variables -REAL :: s = 0.449871, t = -0.386595, a = 0.19600, b = 0.25472, & - r1 = 0.27597, r2 = 0.27846, u, v, x, y, q - -! Generate P = (u,v) uniform in rectangle enclosing acceptance region - -DO - CALL RANDOM_NUMBER(u) - CALL RANDOM_NUMBER(v) - v = 1.7156 * (v - half) - -! Evaluate the quadratic form - x = u - s - y = ABS(v) - t - q = x**2 + y*(a*y - b*x) - -! Accept P if inside inner ellipse - IF (q < r1) EXIT -! Reject P if outside outer ellipse - IF (q > r2) CYCLE -! Reject P if outside acceptance region - IF (v**2 < -4.0*LOG(u)*u**2) EXIT -END DO - -! Return ratio of P's coordinates as the normal deviate -fn_val = v/u -RETURN - -END FUNCTION random_normal - - - -FUNCTION random_gamma(s, first) RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM GAMMA VARIATE. -! CALLS EITHER random_gamma1 (S > 1.0) -! OR random_exponential (S = 1.0) -! OR random_gamma2 (S < 1.0). - -! S = SHAPE PARAMETER OF DISTRIBUTION (0 < REAL). - -REAL, INTENT(IN) :: s -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -IF (s <= zero) THEN - WRITE(*, *) 'SHAPE PARAMETER VALUE MUST BE POSITIVE' - STOP -END IF - -IF (s > one) THEN - fn_val = random_gamma1(s, first) -ELSE IF (s < one) THEN - fn_val = random_gamma2(s, first) -ELSE - fn_val = random_exponential() -END IF - -RETURN -END FUNCTION random_gamma - - - -FUNCTION random_gamma1(s, first) RESULT(fn_val) - -! Uses the algorithm in -! Marsaglia, G. and Tsang, W.W. (2000) `A simple method for generating -! gamma variables', Trans. om Math. Software (TOMS), vol.26(3), pp.363-372. - -! Generates a random gamma deviate for shape parameter s >= 1. - -REAL, INTENT(IN) :: s -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -! Local variables -REAL, SAVE :: c, d -REAL :: u, v, x - -IF (first) THEN - d = s - one/3. - c = one/SQRT(9.0*d) -END IF - -! Start of main loop -DO - -! Generate v = (1+cx)^3 where x is random normal; repeat if v <= 0. - - DO - x = random_normal() - v = (one + c*x)**3 - IF (v > zero) EXIT - END DO - -! Generate uniform variable U - - CALL RANDOM_NUMBER(u) - IF (u < one - 0.0331*x**4) THEN - fn_val = d*v - EXIT - ELSE IF (LOG(u) < half*x**2 + d*(one - v + LOG(v))) THEN - fn_val = d*v - EXIT - END IF -END DO - -RETURN -END FUNCTION random_gamma1 - - - -FUNCTION random_gamma2(s, first) RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM -! A GAMMA DISTRIBUTION WITH DENSITY PROPORTIONAL TO -! GAMMA2**(S-1) * EXP(-GAMMA2), -! USING A SWITCHING METHOD. - -! S = SHAPE PARAMETER OF DISTRIBUTION -! (REAL < 1.0) - -REAL, INTENT(IN) :: s -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -! Local variables -REAL :: r, x, w -REAL, SAVE :: a, p, c, uf, vr, d - -IF (s <= zero .OR. s >= one) THEN - WRITE(*, *) 'SHAPE PARAMETER VALUE OUTSIDE PERMITTED RANGE' - STOP -END IF - -IF (first) THEN ! Initialization, if necessary - a = one - s - p = a/(a + s*EXP(-a)) - IF (s < vsmall) THEN - WRITE(*, *) 'SHAPE PARAMETER VALUE TOO SMALL' - STOP - END IF - c = one/s - uf = p*(vsmall/a)**s - vr = one - vsmall - d = a*LOG(a) -END IF - -DO - CALL RANDOM_NUMBER(r) - IF (r >= vr) THEN - CYCLE - ELSE IF (r > p) THEN - x = a - LOG((one - r)/(one - p)) - w = a*LOG(x)-d - ELSE IF (r > uf) THEN - x = a*(r/p)**c - w = x - ELSE - fn_val = zero - RETURN - END IF - - CALL RANDOM_NUMBER(r) - IF (one-r <= w .AND. r > zero) THEN - IF (r*(w + one) >= one) CYCLE - IF (-LOG(r) <= w) CYCLE - END IF - EXIT -END DO - -fn_val = x -RETURN - -END FUNCTION random_gamma2 - - - -FUNCTION random_chisq(ndf, first) RESULT(fn_val) - -! Generates a random variate from the chi-squared distribution with -! ndf degrees of freedom - -INTEGER, INTENT(IN) :: ndf -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -fn_val = two * random_gamma(half*ndf, first) -RETURN - -END FUNCTION random_chisq - - - -FUNCTION random_exponential() RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM -! A NEGATIVE EXPONENTIAL DlSTRIBUTION WlTH DENSITY PROPORTIONAL -! TO EXP(-random_exponential), USING INVERSION. - -REAL :: fn_val - -! Local variable -REAL :: r - -DO - CALL RANDOM_NUMBER(r) - IF (r > zero) EXIT -END DO - -fn_val = -LOG(r) -RETURN - -END FUNCTION random_exponential - - - -FUNCTION random_Weibull(a) RESULT(fn_val) - -! Generates a random variate from the Weibull distribution with -! probability density: -! a -! a-1 -x -! f(x) = a.x e - -REAL, INTENT(IN) :: a -REAL :: fn_val - -! For speed, there is no checking that a is not zero or very small. - -fn_val = random_exponential() ** (one/a) -RETURN - -END FUNCTION random_Weibull - - - -FUNCTION random_beta(aa, bb, first) RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM VARIATE IN [0,1] -! FROM A BETA DISTRIBUTION WITH DENSITY -! PROPORTIONAL TO BETA**(AA-1) * (1-BETA)**(BB-1). -! USING CHENG'S LOG LOGISTIC METHOD. - -! AA = SHAPE PARAMETER FROM DISTRIBUTION (0 < REAL) -! BB = SHAPE PARAMETER FROM DISTRIBUTION (0 < REAL) - -REAL, INTENT(IN) :: aa, bb -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -! Local variables -REAL, PARAMETER :: aln4 = 1.3862944 -REAL :: a, b, g, r, s, x, y, z -REAL, SAVE :: d, f, h, t, c -LOGICAL, SAVE :: swap - -IF (aa <= zero .OR. bb <= zero) THEN - WRITE(*, *) 'IMPERMISSIBLE SHAPE PARAMETER VALUE(S)' - STOP -END IF - -IF (first) THEN ! Initialization, if necessary - a = aa - b = bb - swap = b > a - IF (swap) THEN - g = b - b = a - a = g - END IF - d = a/b - f = a+b - IF (b > one) THEN - h = SQRT((two*a*b - f)/(f - two)) - t = one - ELSE - h = b - t = one/(one + (a/(vlarge*b))**b) - END IF - c = a+h -END IF - -DO - CALL RANDOM_NUMBER(r) - CALL RANDOM_NUMBER(x) - s = r*r*x - IF (r < vsmall .OR. s <= zero) CYCLE - IF (r < t) THEN - x = LOG(r/(one - r))/h - y = d*EXP(x) - z = c*x + f*LOG((one + d)/(one + y)) - aln4 - IF (s - one > z) THEN - IF (s - s*z > one) CYCLE - IF (LOG(s) > z) CYCLE - END IF - fn_val = y/(one + y) - ELSE - IF (4.0*s > (one + one/d)**f) CYCLE - fn_val = one - END IF - EXIT -END DO - -IF (swap) fn_val = one - fn_val -RETURN -END FUNCTION random_beta - - - -FUNCTION random_t(m) RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM VARIATE FROM A -! T DISTRIBUTION USING KINDERMAN AND MONAHAN'S RATIO METHOD. - -! M = DEGREES OF FREEDOM OF DISTRIBUTION -! (1 <= 1NTEGER) - -INTEGER, INTENT(IN) :: m -REAL :: fn_val - -! Local variables -REAL, SAVE :: s, c, a, f, g -REAL :: r, x, v - -REAL, PARAMETER :: three = 3.0, four = 4.0, quart = 0.25, & - five = 5.0, sixteen = 16.0 -INTEGER :: mm = 0 - -IF (m < 1) THEN - WRITE(*, *) 'IMPERMISSIBLE DEGREES OF FREEDOM' - STOP -END IF - -IF (m /= mm) THEN ! Initialization, if necessary - s = m - c = -quart*(s + one) - a = four/(one + one/s)**c - f = sixteen/a - IF (m > 1) THEN - g = s - one - g = ((s + one)/g)**c*SQRT((s+s)/g) - ELSE - g = one - END IF - mm = m -END IF - -DO - CALL RANDOM_NUMBER(r) - IF (r <= zero) CYCLE - CALL RANDOM_NUMBER(v) - x = (two*v - one)*g/r - v = x*x - IF (v > five - a*r) THEN - IF (m >= 1 .AND. r*(v + three) > f) CYCLE - IF (r > (one + v/s)**c) CYCLE - END IF - EXIT -END DO - -fn_val = x -RETURN -END FUNCTION random_t - - - -SUBROUTINE random_mvnorm(n, h, d, f, first, x, ier) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! N.B. An extra argument, ier, has been added to Dagpunar's routine - -! SUBROUTINE GENERATES AN N VARIATE RANDOM NORMAL -! VECTOR USING A CHOLESKY DECOMPOSITION. - -! ARGUMENTS: -! N = NUMBER OF VARIATES IN VECTOR -! (INPUT,INTEGER >= 1) -! H(J) = J'TH ELEMENT OF VECTOR OF MEANS -! (INPUT,REAL) -! X(J) = J'TH ELEMENT OF DELIVERED VECTOR -! (OUTPUT,REAL) -! -! D(J*(J-1)/2+I) = (I,J)'TH ELEMENT OF VARIANCE MATRIX (J> = I) -! (INPUT,REAL) -! F((J-1)*(2*N-J)/2+I) = (I,J)'TH ELEMENT OF LOWER TRIANGULAR -! DECOMPOSITION OF VARIANCE MATRIX (J <= I) -! (OUTPUT,REAL) - -! FIRST = .TRUE. IF THIS IS THE FIRST CALL OF THE ROUTINE -! OR IF THE DISTRIBUTION HAS CHANGED SINCE THE LAST CALL OF THE ROUTINE. -! OTHERWISE SET TO .FALSE. -! (INPUT,LOGICAL) - -! ier = 1 if the input covariance matrix is not +ve definite -! = 0 otherwise - -INTEGER, INTENT(IN) :: n -REAL, INTENT(IN) :: h(:), d(:) ! d(n*(n+1)/2) -REAL, INTENT(IN OUT) :: f(:) ! f(n*(n+1)/2) -REAL, INTENT(OUT) :: x(:) -LOGICAL, INTENT(IN) :: first -INTEGER, INTENT(OUT) :: ier - -! Local variables -INTEGER :: j, i, m -REAL :: y, v -INTEGER, SAVE :: n2 - -IF (n < 1) THEN - WRITE(*, *) 'SIZE OF VECTOR IS NON POSITIVE' - STOP -END IF - -ier = 0 -IF (first) THEN ! Initialization, if necessary - n2 = 2*n - IF (d(1) < zero) THEN - ier = 1 - RETURN - END IF - - f(1) = SQRT(d(1)) - y = one/f(1) - DO j = 2,n - f(j) = d(1+j*(j-1)/2) * y - END DO - - DO i = 2,n - v = d(i*(i-1)/2+i) - DO m = 1,i-1 - v = v - f((m-1)*(n2-m)/2+i)**2 - END DO - - IF (v < zero) THEN - ier = 1 - RETURN - END IF - - v = SQRT(v) - y = one/v - f((i-1)*(n2-i)/2+i) = v - DO j = i+1,n - v = d(j*(j-1)/2+i) - DO m = 1,i-1 - v = v - f((m-1)*(n2-m)/2+i)*f((m-1)*(n2-m)/2 + j) - END DO ! m = 1,i-1 - f((i-1)*(n2-i)/2 + j) = v*y - END DO ! j = i+1,n - END DO ! i = 2,n -END IF - -x(1:n) = h(1:n) -DO j = 1,n - y = random_normal() - DO i = j,n - x(i) = x(i) + f((j-1)*(n2-j)/2 + i) * y - END DO ! i = j,n -END DO ! j = 1,n - -RETURN -END SUBROUTINE random_mvnorm - - - -FUNCTION random_inv_gauss(h, b, first) RESULT(fn_val) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY] FROM -! A REPARAMETERISED GENERALISED INVERSE GAUSSIAN (GIG) DISTRIBUTION -! WITH DENSITY PROPORTIONAL TO GIG**(H-1) * EXP(-0.5*B*(GIG+1/GIG)) -! USING A RATIO METHOD. - -! H = PARAMETER OF DISTRIBUTION (0 <= REAL) -! B = PARAMETER OF DISTRIBUTION (0 < REAL) - -REAL, INTENT(IN) :: h, b -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -! Local variables -REAL :: ym, xm, r, w, r1, r2, x -REAL, SAVE :: a, c, d, e -REAL, PARAMETER :: quart = 0.25 - -IF (h < zero .OR. b <= zero) THEN - WRITE(*, *) 'IMPERMISSIBLE DISTRIBUTION PARAMETER VALUES' - STOP -END IF - -IF (first) THEN ! Initialization, if necessary - IF (h > quart*b*SQRT(vlarge)) THEN - WRITE(*, *) 'THE RATIO H:B IS TOO SMALL' - STOP - END IF - e = b*b - d = h + one - ym = (-d + SQRT(d*d + e))/b - IF (ym < vsmall) THEN - WRITE(*, *) 'THE VALUE OF B IS TOO SMALL' - STOP - END IF - - d = h - one - xm = (d + SQRT(d*d + e))/b - d = half*d - e = -quart*b - r = xm + one/xm - w = xm*ym - a = w**(-half*h) * SQRT(xm/ym) * EXP(-e*(r - ym - one/ym)) - IF (a < vsmall) THEN - WRITE(*, *) 'THE VALUE OF H IS TOO LARGE' - STOP - END IF - c = -d*LOG(xm) - e*r -END IF - -DO - CALL RANDOM_NUMBER(r1) - IF (r1 <= zero) CYCLE - CALL RANDOM_NUMBER(r2) - x = a*r2/r1 - IF (x <= zero) CYCLE - IF (LOG(r1) < d*LOG(x) + e*(x + one/x) + c) EXIT -END DO - -fn_val = x - -RETURN -END FUNCTION random_inv_gauss - - - -FUNCTION random_Poisson(mu, first) RESULT(ival) -!********************************************************************** -! Translated to Fortran 90 by Alan Miller from: -! RANLIB -! -! Library of Fortran Routines for Random Number Generation -! -! Compiled and Written by: -! -! Barry W. Brown -! James Lovato -! -! Department of Biomathematics, Box 237 -! The University of Texas, M.D. Anderson Cancer Center -! 1515 Holcombe Boulevard -! Houston, TX 77030 -! -! This work was supported by grant CA-16672 from the National Cancer Institute. - -! GENerate POIsson random deviate - -! Function - -! Generates a single random deviate from a Poisson distribution with mean mu. - -! Arguments - -! mu --> The mean of the Poisson distribution from which -! a random deviate is to be generated. -! REAL mu - -! Method - -! For details see: - -! Ahrens, J.H. and Dieter, U. -! Computer Generation of Poisson Deviates -! From Modified Normal Distributions. -! ACM Trans. Math. Software, 8, 2 -! (June 1982),163-179 - -! TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT -! COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL - -! SEPARATION OF CASES A AND B - -! .. Scalar Arguments .. -REAL, INTENT(IN) :: mu -LOGICAL, INTENT(IN) :: first -INTEGER :: ival -! .. -! .. Local Scalars .. -REAL :: b1, b2, c, c0, c1, c2, c3, del, difmuk, e, fk, fx, fy, g, & - omega, px, py, t, u, v, x, xx -REAL, SAVE :: s, d, p, q, p0 -INTEGER :: j, k, kflag -LOGICAL, SAVE :: full_init -INTEGER, SAVE :: l, m -! .. -! .. Local Arrays .. -REAL, SAVE :: pp(35) -! .. -! .. Data statements .. -REAL, PARAMETER :: a0 = -.5, a1 = .3333333, a2 = -.2500068, a3 = .2000118, & - a4 = -.1661269, a5 = .1421878, a6 = -.1384794, & - a7 = .1250060 - -REAL, PARAMETER :: fact(10) = (/ 1., 1., 2., 6., 24., 120., 720., 5040., & - 40320., 362880. /) - -! .. -! .. Executable Statements .. -IF (mu > 10.0) THEN -! C A S E A. (RECALCULATION OF S, D, L IF MU HAS CHANGED) - - IF (first) THEN - s = SQRT(mu) - d = 6.0*mu*mu - -! THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL -! PROBABILITIES FK WHENEVER K >= M(MU). L=IFIX(MU-1.1484) -! IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 . - - l = mu - 1.1484 - full_init = .false. - END IF - - -! STEP N. NORMAL SAMPLE - random_normal() FOR STANDARD NORMAL DEVIATE - - g = mu + s*random_normal() - IF (g > 0.0) THEN - ival = g - -! STEP I. IMMEDIATE ACCEPTANCE IF ival IS LARGE ENOUGH - - IF (ival>=l) RETURN - -! STEP S. SQUEEZE ACCEPTANCE - SAMPLE U - - fk = ival - difmuk = mu - fk - CALL RANDOM_NUMBER(u) - IF (d*u >= difmuk*difmuk*difmuk) RETURN - END IF - -! STEP P. PREPARATIONS FOR STEPS Q AND H. -! (RECALCULATIONS OF PARAMETERS IF NECESSARY) -! .3989423=(2*PI)**(-.5) .416667E-1=1./24. .1428571=1./7. -! THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE -! APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK. -! C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION. - - IF (.NOT. full_init) THEN - omega = .3989423/s - b1 = .4166667E-1/mu - b2 = .3*b1*b1 - c3 = .1428571*b1*b2 - c2 = b2 - 15.*c3 - c1 = b1 - 6.*b2 + 45.*c3 - c0 = 1. - b1 + 3.*b2 - 15.*c3 - c = .1069/mu - full_init = .true. - END IF - - IF (g < 0.0) GO TO 50 - -! 'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN) - - kflag = 0 - GO TO 70 - -! STEP Q. QUOTIENT ACCEPTANCE (RARE CASE) - - 40 IF (fy-u*fy <= py*EXP(px-fx)) RETURN - -! STEP E. EXPONENTIAL SAMPLE - random_exponential() FOR STANDARD EXPONENTIAL -! DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT' -! (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.) - - 50 e = random_exponential() - CALL RANDOM_NUMBER(u) - u = u + u - one - t = 1.8 + SIGN(e, u) - IF (t <= (-.6744)) GO TO 50 - ival = mu + s*t - fk = ival - difmuk = mu - fk - -! 'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN) - - kflag = 1 - GO TO 70 - -! STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION) - - 60 IF (c*ABS(u) > py*EXP(px+e) - fy*EXP(fx+e)) GO TO 50 - RETURN - -! STEP F. 'SUBROUTINE' F. CALCULATION OF PX, PY, FX, FY. -! CASE ival < 10 USES FACTORIALS FROM TABLE FACT - - 70 IF (ival>=10) GO TO 80 - px = -mu - py = mu**ival/fact(ival+1) - GO TO 110 - -! CASE ival >= 10 USES POLYNOMIAL APPROXIMATION -! A0-A7 FOR ACCURACY WHEN ADVISABLE -! .8333333E-1=1./12. .3989423=(2*PI)**(-.5) - - 80 del = .8333333E-1/fk - del = del - 4.8*del*del*del - v = difmuk/fk - IF (ABS(v)>0.25) THEN - px = fk*LOG(one + v) - difmuk - del - ELSE - px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0) - del - END IF - py = .3989423/SQRT(fk) - 110 x = (half - difmuk)/s - xx = x*x - fx = -half*xx - fy = omega* (((c3*xx + c2)*xx + c1)*xx + c0) - IF (kflag <= 0) GO TO 40 - GO TO 60 - -!--------------------------------------------------------------------------- -! C A S E B. mu < 10 -! START NEW TABLE AND CALCULATE P0 IF NECESSARY - -ELSE - IF (first) THEN - m = MAX(1, INT(mu)) - l = 0 - p = EXP(-mu) - q = p - p0 = p - END IF - -! STEP U. UNIFORM SAMPLE FOR INVERSION METHOD - - DO - CALL RANDOM_NUMBER(u) - ival = 0 - IF (u <= p0) RETURN - -! STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE -! PP-TABLE OF CUMULATIVE POISSON PROBABILITIES -! (0.458=PP(9) FOR MU=10) - - IF (l == 0) GO TO 150 - j = 1 - IF (u > 0.458) j = MIN(l, m) - DO k = j, l - IF (u <= pp(k)) GO TO 180 - END DO - IF (l == 35) CYCLE - -! STEP C. CREATION OF NEW POISSON PROBABILITIES P -! AND THEIR CUMULATIVES Q=PP(K) - - 150 l = l + 1 - DO k = l, 35 - p = p*mu / k - q = q + p - pp(k) = q - IF (u <= q) GO TO 170 - END DO - l = 35 - END DO - - 170 l = k - 180 ival = k - RETURN -END IF - -RETURN -END FUNCTION random_Poisson - - - -FUNCTION random_binomial1(n, p, first) RESULT(ival) - -! FUNCTION GENERATES A RANDOM BINOMIAL VARIATE USING C.D.Kemp's method. -! This algorithm is suitable when many random variates are required -! with the SAME parameter values for n & p. - -! P = BERNOULLI SUCCESS PROBABILITY -! (0 <= REAL <= 1) -! N = NUMBER OF BERNOULLI TRIALS -! (1 <= INTEGER) -! FIRST = .TRUE. for the first call using the current parameter values -! = .FALSE. if the values of (n,p) are unchanged from last call - -! Reference: Kemp, C.D. (1986). `A modal method for generating binomial -! variables', Commun. Statist. - Theor. Meth. 15(3), 805-813. - -INTEGER, INTENT(IN) :: n -REAL, INTENT(IN) :: p -LOGICAL, INTENT(IN) :: first -INTEGER :: ival - -! Local variables - -INTEGER :: ru, rd -INTEGER, SAVE :: r0 -REAL :: u, pd, pu -REAL, SAVE :: odds_ratio, p_r -REAL, PARAMETER :: zero = 0.0, one = 1.0 - -IF (first) THEN - r0 = (n+1)*p - p_r = bin_prob(n, p, r0) - odds_ratio = p / (one - p) -END IF - -CALL RANDOM_NUMBER(u) -u = u - p_r -IF (u < zero) THEN - ival = r0 - RETURN -END IF - -pu = p_r -ru = r0 -pd = p_r -rd = r0 -DO - rd = rd - 1 - IF (rd >= 0) THEN - pd = pd * (rd+1) / (odds_ratio * (n-rd)) - u = u - pd - IF (u < zero) THEN - ival = rd - RETURN - END IF - END IF - - ru = ru + 1 - IF (ru <= n) THEN - pu = pu * (n-ru+1) * odds_ratio / ru - u = u - pu - IF (u < zero) THEN - ival = ru - RETURN - END IF - END IF -END DO - -! This point should not be reached, but just in case: - -ival = r0 -RETURN - -END FUNCTION random_binomial1 - - - -FUNCTION bin_prob(n, p, r) RESULT(fn_val) -! Calculate a binomial probability - -INTEGER, INTENT(IN) :: n, r -REAL, INTENT(IN) :: p -REAL :: fn_val - -! Local variable -REAL :: one = 1.0 - -fn_val = EXP( lngamma(DBLE(n+1)) - lngamma(DBLE(r+1)) - lngamma(DBLE(n-r+1)) & - + r*LOG(p) + (n-r)*LOG(one - p) ) -RETURN - -END FUNCTION bin_prob - - - -FUNCTION lngamma(x) RESULT(fn_val) - -! Logarithm to base e of the gamma function. -! -! Accurate to about 1.e-14. -! Programmer: Alan Miller - -! Latest revision of Fortran 77 version - 28 February 1988 - -REAL (dp), INTENT(IN) :: x -REAL (dp) :: fn_val - -! Local variables - -REAL (dp) :: a1 = -4.166666666554424D-02, a2 = 2.430554511376954D-03, & - a3 = -7.685928044064347D-04, a4 = 5.660478426014386D-04, & - temp, arg, product, lnrt2pi = 9.189385332046727D-1, & - pi = 3.141592653589793D0 -LOGICAL :: reflect - -! lngamma is not defined if x = 0 or a negative integer. - -IF (x > 0.d0) GO TO 10 -IF (x /= INT(x)) GO TO 10 -fn_val = 0.d0 -RETURN - -! If x < 0, use the reflection formula: -! gamma(x) * gamma(1-x) = pi * cosec(pi.x) - -10 reflect = (x < 0.d0) -IF (reflect) THEN - arg = 1.d0 - x -ELSE - arg = x -END IF - -! Increase the argument, if necessary, to make it > 10. - -product = 1.d0 -20 IF (arg <= 10.d0) THEN - product = product * arg - arg = arg + 1.d0 - GO TO 20 -END IF - -! Use a polynomial approximation to Stirling's formula. -! N.B. The real Stirling's formula is used here, not the simpler, but less -! accurate formula given by De Moivre in a letter to Stirling, which -! is the one usually quoted. - -arg = arg - 0.5D0 -temp = 1.d0/arg**2 -fn_val = lnrt2pi + arg * (LOG(arg) - 1.d0 + & - (((a4*temp + a3)*temp + a2)*temp + a1)*temp) - LOG(product) -IF (reflect) THEN - temp = SIN(pi * x) - fn_val = LOG(pi/temp) - fn_val -END IF -RETURN -END FUNCTION lngamma - - - -FUNCTION random_binomial2(n, pp, first) RESULT(ival) -!********************************************************************** -! Translated to Fortran 90 by Alan Miller from: -! RANLIB -! -! Library of Fortran Routines for Random Number Generation -! -! Compiled and Written by: -! -! Barry W. Brown -! James Lovato -! -! Department of Biomathematics, Box 237 -! The University of Texas, M.D. Anderson Cancer Center -! 1515 Holcombe Boulevard -! Houston, TX 77030 -! -! This work was supported by grant CA-16672 from the National Cancer Institute. - -! GENerate BINomial random deviate - -! Function - -! Generates a single random deviate from a binomial -! distribution whose number of trials is N and whose -! probability of an event in each trial is P. - -! Arguments - -! N --> The number of trials in the binomial distribution -! from which a random deviate is to be generated. -! INTEGER N - -! P --> The probability of an event in each trial of the -! binomial distribution from which a random deviate -! is to be generated. -! REAL P - -! FIRST --> Set FIRST = .TRUE. for the first call to perform initialization -! the set FIRST = .FALSE. for further calls using the same pair -! of parameter values (N, P). -! LOGICAL FIRST - -! random_binomial2 <-- A random deviate yielding the number of events -! from N independent trials, each of which has -! a probability of event P. -! INTEGER random_binomial - -! Method - -! This is algorithm BTPE from: - -! Kachitvichyanukul, V. and Schmeiser, B. W. -! Binomial Random Variate Generation. -! Communications of the ACM, 31, 2 (February, 1988) 216. - -!********************************************************************** - -!*****DETERMINE APPROPRIATE ALGORITHM AND WHETHER SETUP IS NECESSARY - -! .. -! .. Scalar Arguments .. -REAL, INTENT(IN) :: pp -INTEGER, INTENT(IN) :: n -LOGICAL, INTENT(IN) :: first -INTEGER :: ival -! .. -! .. Local Scalars .. -REAL :: alv, amaxp, f, f1, f2, u, v, w, w2, x, x1, x2, ynorm, z, z2 -REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0 -INTEGER :: i, ix, ix1, k, mp -INTEGER, SAVE :: m -REAL, SAVE :: p, q, xnp, ffm, fm, xnpq, p1, xm, xl, xr, c, al, xll, & - xlr, p2, p3, p4, qn, r, g - -! .. -! .. Executable Statements .. - -!*****SETUP, PERFORM ONLY WHEN PARAMETERS CHANGE - -IF (first) THEN - p = MIN(pp, one-pp) - q = one - p - xnp = n * p -END IF - -IF (xnp > 30.) THEN - IF (first) THEN - ffm = xnp + p - m = ffm - fm = m - xnpq = xnp * q - p1 = INT(2.195*SQRT(xnpq) - 4.6*q) + half - xm = fm + half - xl = xm - p1 - xr = xm + p1 - c = 0.134 + 20.5 / (15.3 + fm) - al = (ffm-xl) / (ffm - xl*p) - xll = al * (one + half*al) - al = (xr - ffm) / (xr*q) - xlr = al * (one + half*al) - p2 = p1 * (one + c + c) - p3 = p2 + c / xll - p4 = p3 + c / xlr - END IF - -!*****GENERATE VARIATE, Binomial mean at least 30. - - 20 CALL RANDOM_NUMBER(u) - u = u * p4 - CALL RANDOM_NUMBER(v) - -! TRIANGULAR REGION - - IF (u <= p1) THEN - ix = xm - p1 * v + u - GO TO 110 - END IF - -! PARALLELOGRAM REGION - - IF (u <= p2) THEN - x = xl + (u-p1) / c - v = v * c + one - ABS(xm-x) / p1 - IF (v > one .OR. v <= zero) GO TO 20 - ix = x - ELSE - -! LEFT TAIL - - IF (u <= p3) THEN - ix = xl + LOG(v) / xll - IF (ix < 0) GO TO 20 - v = v * (u-p2) * xll - ELSE - -! RIGHT TAIL - - ix = xr - LOG(v) / xlr - IF (ix > n) GO TO 20 - v = v * (u-p3) * xlr - END IF - END IF - -!*****DETERMINE APPROPRIATE WAY TO PERFORM ACCEPT/REJECT TEST - - k = ABS(ix-m) - IF (k <= 20 .OR. k >= xnpq/2-1) THEN - -! EXPLICIT EVALUATION - - f = one - r = p / q - g = (n+1) * r - IF (m < ix) THEN - mp = m + 1 - DO i = mp, ix - f = f * (g/i-r) - END DO - - ELSE IF (m > ix) THEN - ix1 = ix + 1 - DO i = ix1, m - f = f / (g/i-r) - END DO - END IF - - IF (v > f) THEN - GO TO 20 - ELSE - GO TO 110 - END IF - END IF - -! SQUEEZING USING UPPER AND LOWER BOUNDS ON LOG(F(X)) - - amaxp = (k/xnpq) * ((k*(k/3. + .625) + .1666666666666)/xnpq + half) - ynorm = -k * k / (2.*xnpq) - alv = LOG(v) - IF (alvynorm + amaxp) GO TO 20 - -! STIRLING'S (actually de Moivre's) FORMULA TO MACHINE ACCURACY FOR -! THE FINAL ACCEPTANCE/REJECTION TEST - - x1 = ix + 1 - f1 = fm + one - z = n + 1 - fm - w = n - ix + one - z2 = z * z - x2 = x1 * x1 - f2 = f1 * f1 - w2 = w * w - IF (alv - (xm*LOG(f1/x1) + (n-m+half)*LOG(z/w) + (ix-m)*LOG(w*p/(x1*q)) + & - (13860.-(462.-(132.-(99.-140./f2)/f2)/f2)/f2)/f1/166320. + & - (13860.-(462.-(132.-(99.-140./z2)/z2)/z2)/z2)/z/166320. + & - (13860.-(462.-(132.-(99.-140./x2)/x2)/x2)/x2)/x1/166320. + & - (13860.-(462.-(132.-(99.-140./w2)/w2)/w2)/w2)/w/166320.) > zero) THEN - GO TO 20 - ELSE - GO TO 110 - END IF - -ELSE -! INVERSE CDF LOGIC FOR MEAN LESS THAN 30 - IF (first) THEN - qn = q ** n - r = p / q - g = r * (n+1) - END IF - - 90 ix = 0 - f = qn - CALL RANDOM_NUMBER(u) - 100 IF (u >= f) THEN - IF (ix > 110) GO TO 90 - u = u - f - ix = ix + 1 - f = f * (g/ix - r) - GO TO 100 - END IF -END IF - -110 IF (pp > half) ix = n - ix -ival = ix -RETURN - -END FUNCTION random_binomial2 - - - - -FUNCTION random_neg_binomial(sk, p) RESULT(ival) - -! Adapted from Fortran 77 code from the book: -! Dagpunar, J. 'Principles of random variate generation' -! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 - -! FUNCTION GENERATES A RANDOM NEGATIVE BINOMIAL VARIATE USING UNSTORED -! INVERSION AND/OR THE REPRODUCTIVE PROPERTY. - -! SK = NUMBER OF FAILURES REQUIRED (Dagpunar's words!) -! = the `power' parameter of the negative binomial -! (0 < REAL) -! P = BERNOULLI SUCCESS PROBABILITY -! (0 < REAL < 1) - -! THE PARAMETER H IS SET SO THAT UNSTORED INVERSION ONLY IS USED WHEN P <= H, -! OTHERWISE A COMBINATION OF UNSTORED INVERSION AND -! THE REPRODUCTIVE PROPERTY IS USED. - -REAL, INTENT(IN) :: sk, p -INTEGER :: ival - -! Local variables -! THE PARAMETER ULN = -LOG(MACHINE'S SMALLEST REAL NUMBER). - -REAL, PARAMETER :: h = 0.7 -REAL :: q, x, st, uln, v, r, s, y, g -INTEGER :: k, i, n - -IF (sk <= zero .OR. p <= zero .OR. p >= one) THEN - WRITE(*, *) 'IMPERMISSIBLE DISTRIBUTION PARAMETER VALUES' - STOP -END IF - -q = one - p -x = zero -st = sk -IF (p > h) THEN - v = one/LOG(p) - k = st - DO i = 1,k - DO - CALL RANDOM_NUMBER(r) - IF (r > zero) EXIT - END DO - n = v*LOG(r) - x = x + n - END DO - st = st - k -END IF - -s = zero -uln = -LOG(vsmall) -IF (st > -uln/LOG(q)) THEN - WRITE(*, *) ' P IS TOO LARGE FOR THIS VALUE OF SK' - STOP -END IF - -y = q**st -g = st -CALL RANDOM_NUMBER(r) -DO - IF (y > r) EXIT - r = r - y - s = s + one - y = y*p*g/s - g = g + one -END DO - -ival = x + s + half -RETURN -END FUNCTION random_neg_binomial - - - -FUNCTION random_von_Mises(k, first) RESULT(fn_val) - -! Algorithm VMD from: -! Dagpunar, J.S. (1990) `Sampling from the von Mises distribution via a -! comparison of random numbers', J. of Appl. Statist., 17, 165-168. - -! Fortran 90 code by Alan Miller -! CSIRO Division of Mathematical & Information Sciences - -! Arguments: -! k (real) parameter of the von Mises distribution. -! first (logical) set to .TRUE. the first time that the function -! is called, or the first time with a new value -! for k. When first = .TRUE., the function sets -! up starting values and may be very much slower. - -REAL, INTENT(IN) :: k -LOGICAL, INTENT(IN) :: first -REAL :: fn_val - -! Local variables - -INTEGER :: j, n -INTEGER, SAVE :: nk -REAL, PARAMETER :: pi = 3.14159265 -REAL, SAVE :: p(20), theta(0:20) -REAL :: sump, r, th, lambda, rlast -REAL (dp) :: dk - -IF (first) THEN ! Initialization, if necessary - IF (k < zero) THEN - WRITE(*, *) '** Error: argument k for random_von_Mises = ', k - RETURN - END IF - - nk = k + k + one - IF (nk > 20) THEN - WRITE(*, *) '** Error: argument k for random_von_Mises = ', k - RETURN - END IF - - dk = k - theta(0) = zero - IF (k > half) THEN - -! Set up array p of probabilities. - - sump = zero - DO j = 1, nk - IF (j < nk) THEN - theta(j) = ACOS(one - j/k) - ELSE - theta(nk) = pi - END IF - -! Numerical integration of e^[k.cos(x)] from theta(j-1) to theta(j) - - CALL integral(theta(j-1), theta(j), p(j), dk) - sump = sump + p(j) - END DO - p(1:nk) = p(1:nk) / sump - ELSE - p(1) = one - theta(1) = pi - END IF ! if k > 0.5 -END IF ! if first - -CALL RANDOM_NUMBER(r) -DO j = 1, nk - r = r - p(j) - IF (r < zero) EXIT -END DO -r = -r/p(j) - -DO - th = theta(j-1) + r*(theta(j) - theta(j-1)) - lambda = k - j + one - k*COS(th) - n = 1 - rlast = lambda - - DO - CALL RANDOM_NUMBER(r) - IF (r > rlast) EXIT - n = n + 1 - rlast = r - END DO - - IF (n .NE. 2*(n/2)) EXIT ! is n even? - CALL RANDOM_NUMBER(r) -END DO - -fn_val = SIGN(th, (r - rlast)/(one - rlast) - half) -RETURN -END FUNCTION random_von_Mises - - - -SUBROUTINE integral(a, b, result, dk) - -! Gaussian integration of exp(k.cosx) from a to b. - -REAL (dp), INTENT(IN) :: dk -REAL, INTENT(IN) :: a, b -REAL, INTENT(OUT) :: result - -! Local variables - -REAL (dp) :: xmid, range, x1, x2, & - x(3) = (/0.238619186083197_dp, 0.661209386466265_dp, 0.932469514203152_dp/), & - w(3) = (/0.467913934572691_dp, 0.360761573048139_dp, 0.171324492379170_dp/) -INTEGER :: i - -xmid = (a + b)/2._dp -range = (b - a)/2._dp - -result = 0._dp -DO i = 1, 3 - x1 = xmid + x(i)*range - x2 = xmid - x(i)*range - result = result + w(i)*(EXP(dk*COS(x1)) + EXP(dk*COS(x2))) -END DO - -result = result * range -RETURN -END SUBROUTINE integral - - - -FUNCTION random_Cauchy() RESULT(fn_val) - -! Generate a random deviate from the standard Cauchy distribution - -REAL :: fn_val - -! Local variables -REAL :: v(2) - -DO - CALL RANDOM_NUMBER(v) - v = two*(v - half) - IF (ABS(v(2)) < vsmall) CYCLE ! Test for zero - IF (v(1)**2 + v(2)**2 < one) EXIT -END DO -fn_val = v(1) / v(2) - -RETURN -END FUNCTION random_Cauchy - - - -SUBROUTINE random_order(order, n) - -! Generate a random ordering of the integers 1 ... n. - -INTEGER, INTENT(IN) :: n -INTEGER, INTENT(OUT) :: order(n) - -! Local variables - -INTEGER :: i, j, k -REAL :: wk - -DO i = 1, n - order(i) = i -END DO - -! Starting at the end, swap the current last indicator with one -! randomly chosen from those preceeding it. - -DO i = n, 2, -1 - CALL RANDOM_NUMBER(wk) - j = 1 + i * wk - IF (j < i) THEN - k = order(i) - order(i) = order(j) - order(j) = k - END IF -END DO - -RETURN -END SUBROUTINE random_order - - - -SUBROUTINE seed_random_number(iounit) - -INTEGER, INTENT(IN) :: iounit - -! Local variables - -INTEGER :: k -INTEGER, ALLOCATABLE :: seed(:) - -CALL RANDOM_SEED(SIZE=k) -ALLOCATE( seed(k) ) - -WRITE(*, '(a, i2, a)')' Enter ', k, ' integers for random no. seeds: ' -READ(*, *) seed -WRITE(iounit, '(a, (7i10))') ' Random no. seeds: ', seed -CALL RANDOM_SEED(PUT=seed) - -DEALLOCATE( seed ) - -RETURN -END SUBROUTINE seed_random_number - - -END MODULE random diff --git a/modules/rtm/src/RTM/statistics/inversion.f90 b/modules/rtm/src/RTM/statistics/inversion.f90 deleted file mode 100644 index 50141b1fd16..00000000000 --- a/modules/rtm/src/RTM/statistics/inversion.f90 +++ /dev/null @@ -1,64 +0,0 @@ -subroutine invert_basic(observed, nspec, modcode, & - inits, npars, ipars, cons, ncons, icons, & - pmu, psd, plog, pmin, ngibbs, results, seed) - use mod_types - use mod_statistics - use mod_selectmodel - use mod_dataspec_wavelength - implicit none - - ! Inputs - integer(kind=i2), intent(in) :: nspec, npars, ncons, modcode, seed(100) - integer(kind=i2), intent(in) :: ipars(npars), icons(ncons) - real(kind=r2), intent(in) :: observed(nw,nspec), inits(npars), cons(ncons) - real(kind=r2), intent(in), dimension(npars) :: pmin, pmu, psd - logical, intent(in) :: plog(npars) - integer(kind=i2), intent(in) :: ngibbs - - ! Internals - integer(kind=i1) :: i, ng, adapt - integer(kind=i2) :: nseed - real(kind=r2) :: rp1, rp2, rinv, rsd - real(kind=r2) :: PrevError(nw,nspec), PrevSpec(nw) - real(kind=r2) :: Jump(npars) - real(kind=r1) :: adj_min - real(kind=r1), dimension(npars) :: adj, ar - procedure(), pointer :: model - - ! Outputs - real(kind=r2), intent(out) :: results(ngibbs, npars+1) - - nseed = 100 - call random_seed(size=nseed) - call random_seed(put=seed) !! Initialize random number generator - call model_select(modcode, model) - - rp1 = 0.001 + nspec*nw/2 - rsd = 0.5 - call model(inits, npars, ipars, cons, ncons, icons, PrevSpec) - do i=1,nspec - PrevError(:,i) = PrevSpec - observed(:,i) - enddo - Jump = inits * 0.05 - adapt = 20 - adj_min = 0.1 - ar = 0 - do ng=1,ngibbs - if(mod(ng, adapt) < 1) then - adj = ar / adapt / 0.75 - where(adj < adj_min) - adj = adj_min - end where - Jump = Jump * adj - ar = 0 - endif - call mh_sample(observed, nspec, model, & - inits, npars, ipars, cons, ncons, icons, rsd, & - Jump, pmu, psd, plog, pmin, PrevError, ar) - results(ng,1:npars) = inits - rp2 = 0.001 + sum(PrevError * PrevError)/2 - rinv = rgamma(rp1, 1/rp2) - rsd = 1/sqrt(rinv) - results(ng,npars+1) = rsd - enddo -end subroutine diff --git a/modules/rtm/src/RTM/statistics/inversion.re.f90 b/modules/rtm/src/RTM/statistics/inversion.re.f90 deleted file mode 100644 index 7d9009f071f..00000000000 --- a/modules/rtm/src/RTM/statistics/inversion.re.f90 +++ /dev/null @@ -1,89 +0,0 @@ -subroutine invert_re(observed, nspec, modcode, & - inits, npars, ipars, rand, & - cons, ncons, icons, & - pmu, psd, plog, pmin, ngibbs, results, seed) - use mod_types - use mod_statistics - use mod_selectmodel - use mod_dataspec_wavelength - implicit none - - ! Inputs - integer(kind=i2), intent(in) :: nspec, npars, ncons, modcode, seed(100) - integer(kind=i2), intent(in) :: ipars(npars), icons(ncons) - real(kind=r2), intent(in) :: observed(nw,nspec), inits(npars), & - cons(ncons), rand(npars,nspec) - real(kind=r2), intent(in), dimension(npars) :: pmin, pmu, psd - logical, intent(in) :: plog(npars) - integer(kind=i2), intent(in) :: ngibbs - - ! Internals - integer(kind=i2) :: nseed - integer(kind=i1) :: i, p, ng, adapt - real(kind=r2) :: rp1, rp2, rinv, rsd, tp1, tp2, tinv - real(kind=r2), dimension(npars) :: inpars, tausd - real(kind=r2) :: PrevError(nw,nspec), PrevSpec(nw) - real(kind=r2) :: Jump(npars), Jump_re(npars) - real(kind=r1) :: adj_min - real(kind=r1), dimension(npars) :: adj, ar, adj_re, ar_re - procedure(), pointer :: model - - ! Outputs - real(kind=r2), intent(out) :: results(ngibbs, npars*(nspec+2)+1) - - nseed = 100 - call random_seed(size=nseed) - call random_seed(put=seed) - call model_select(modcode, model) - - rp1 = 0.001 + nspec*nw/2 - rsd = 0.5 - - tp1 = 0.001 + nw/2 - tausd = 0.1 - - PrevSpec = 0.0d0 - do i = 1,nspec - inpars(:) = inits + rand(:,i) - call model(inpars, npars, ipars, cons, ncons, icons, PrevSpec) - PrevError(:,i) = PrevSpec - observed(:,i) - end do - Jump = inits * 0.05 - Jump_re = 0.1 - adapt = 20 - adj_min = 0.1 - ar = 0 - ar_re = 0 - do ng=1,ngibbs - if(mod(ng, adapt) < 1) then - adj = ar / adapt / 0.44 - adj_re = ar_re / nspec / adapt / 0.44 - where(adj < adj_min) - adj = adj_min - end where - where(adj_re < adj_min) - adj_re = adj_min - end where - Jump = Jump * adj - Jump_re = Jump_re * adj_re - ar = 0 - ar_re = 0 - endif - call mh_sample_re(observed, nspec, model, & - inits, npars, ipars, rand, & - cons, ncons, icons, rsd, tausd, & - Jump, Jump_re, pmu, psd, plog, pmin, PrevError, ar, ar_re) - results(ng,1:npars) = inits - results(ng,(npars+1):(npars*(nspec+1))) = reshape(rand,(/npars*nspec/)) - do p=1,npars - tp2 = 0.001 + sum(rand(p,:) * rand(p,:))/2 - tinv = rgamma(tp1, 1/tp2) - tausd(p) = 1/sqrt(tinv) - results(ng,p+npars*(nspec+1)) = tausd(p) - end do - rp2 = 0.001 + sum(PrevError * PrevError)/2 - rinv = rgamma(rp1, 1/rp2) - rsd = 1/sqrt(rinv) - results(ng,npars*(nspec+2)+1) = rsd - enddo -end subroutine diff --git a/modules/rtm/src/RTM/statistics/prior.f90 b/modules/rtm/src/RTM/statistics/prior.f90 deleted file mode 100644 index 6dcf09d4b0e..00000000000 --- a/modules/rtm/src/RTM/statistics/prior.f90 +++ /dev/null @@ -1,33 +0,0 @@ -! Custom, (log)normal priors -subroutine prior(x, pmu, psd, lognorm, d) - use mod_types - use mod_statistics - implicit none - - real(kind=r2), intent(in) :: x, pmu, psd - logical, intent(in) :: lognorm - real(kind=r2), intent(out) :: d - - real(kind=r2) :: xx - - if(lognorm) then - xx = log(x) - else - xx = x - end if - - d = ldnorm(xx, pmu, psd) - return -end subroutine - -subroutine prior_re(x, tausd, d) - use mod_types - use mod_statistics - implicit none - - real(kind=r2), intent(in) :: x, tausd - real(kind=r2), intent(out) :: d - - d = ldnorm(x, 0.0d0, tausd) - return -end subroutine diff --git a/modules/rtm/src/RTM/statistics/re.model.f90 b/modules/rtm/src/RTM/statistics/re.model.f90 deleted file mode 100644 index 5a8c1acd689..00000000000 --- a/modules/rtm/src/RTM/statistics/re.model.f90 +++ /dev/null @@ -1,28 +0,0 @@ -subroutine re_model(model, inits, npars, ipars, & - rand, nrand, cons, ncons, icons, spec) - use mod_types - use mod_dataspec_wavelength - implicit none - - ! Inputs - Procedure() :: model - integer(kind=i2), intent(in) :: npars, nrand, ncons - integer(kind=i2), intent(in) :: ipars(npars), icons(ncons) - real(kind=r2), intent(in) :: inits(npars), rand(npars,nrand), cons(ncons) - - ! Outputs - real(kind=r2), intent(out) :: spec(nw,nrand) - - ! Internals - integer :: i - real(kind=r2) :: inpars(npars) - - spec = 0 - do i = 1,nrand - inpars(:) = inits + rand(:,i) - call model(inpars, npars, ipars, cons, ncons, icons, spec(:,i)) - end do - return -end subroutine - - diff --git a/modules/rtm/src/RTM/statistics/samplers.f90 b/modules/rtm/src/RTM/statistics/samplers.f90 deleted file mode 100644 index cb291275e39..00000000000 --- a/modules/rtm/src/RTM/statistics/samplers.f90 +++ /dev/null @@ -1,56 +0,0 @@ -subroutine mh_sample(observed, nspec, model, & - inits, npars, ipars, cons, ncons, icons, rsd, & - Jump, pmu, psd, plog, pmin, PrevError, ar) - use mod_types - use mod_statistics - use mod_dataspec_wavelength - implicit none - - ! Inputs -- unchanged - integer(kind=i2), intent(in) :: npars, nspec, ncons - integer(kind=i2), intent(in) :: ipars(npars), icons(ncons) - real(kind=r2), intent(in) :: observed(nw,nspec), cons(ncons), rsd, Jump(npars) - real(kind=r2), intent(in), dimension(npars) :: pmin, pmu, psd - logical, intent(in) :: plog(npars) - procedure() :: model - - ! Input/Output -- modified - real(kind=r1) :: ar(npars) - real(kind=r2) :: inits(npars), PrevError(nw,nspec) - - ! Internals - integer(kind=i1) :: p, i, j - real(kind=r2) :: tvec(npars), a, u - real(kind=r2) :: TryError(nw,nspec), TrySpec(nw) - real(kind=r2) :: TryPost, PrevPost - - do p=1,npars - tvec = inits - tvec(p) = rnorm(inits(p),Jump(p)) - - if(tvec(p) < pmin(p)) cycle - call model(tvec, npars, ipars, cons, ncons, icons, TrySpec) - do i = 1,nspec - TryError(:,i) = TrySpec - observed(:,i) - enddo - call prior(tvec(p), pmu(p), psd(p), plog(p), TryPost) - call prior(inits(p), pmu(p), psd(p), plog(p), PrevPost) - do i=1,nw - do j=1,nspec - TryPost = TryPost + ldnorm(TryError(i,j), 0d0, rsd) - PrevPost = PrevPost + ldnorm(PrevError(i,j), 0d0, rsd) - enddo - enddo - ! rnorm is symmetrical, so shouldn't need to normalize - ! JN = dnorm(tvec(p), inits(p), Jump(p), pm(p)) - ! JD = dnorm(inits(p), tvec(p), Jump(p), pm(p)) - ! a = exp((TryPost - JN) - (PrevPost - JD)) - a = exp(TryPost - PrevPost) - call random_number(u) - if(a > u) then - inits(p) = tvec(p) - PrevError = TryError - ar(p) = ar(p) + 1 - endif - end do -end subroutine diff --git a/modules/rtm/src/RTM/statistics/samplers.re.f90 b/modules/rtm/src/RTM/statistics/samplers.re.f90 deleted file mode 100644 index 85183fdc8b2..00000000000 --- a/modules/rtm/src/RTM/statistics/samplers.re.f90 +++ /dev/null @@ -1,95 +0,0 @@ -subroutine mh_sample_re(observed, nspec, model, & - inits, npars, ipars, rand, & - cons, ncons, icons, rsd, tausd, & - Jump, Jump_re, pmu, psd, plog, pmin, PrevError, ar, ar_re) - use mod_types - use mod_statistics - use mod_dataspec_wavelength - implicit none - - ! Inputs -- unchanged - integer(kind=i2), intent(in) :: npars, nspec, ncons, & - ipars(npars), icons(ncons) - real(kind=r2), intent(in) :: observed(nw,nspec), cons(ncons), rsd, & - tausd(npars), Jump(npars), Jump_re(npars), & - pmu(npars), psd(npars), pmin(npars) - logical, intent(in) :: plog(npars) - procedure() :: model - - ! Input/Output -- modified - real(kind=r1) :: ar(npars), ar_re(npars) - real(kind=r2) :: inits(npars), PrevError(nw,nspec), rand(npars,nspec) - - ! Internals - integer(kind=i1) :: p, r, i, j - real(kind=r2) :: tvec(npars), inpars(npars), rmat(npars,nspec), & - a, u, TryError(nw,nspec), TrySpec(nw), TryPost, PrevPost - logical :: minflag - - do p=1,npars - !! Sample parameter p - minflag = .false. - tvec = inits - tvec(p) = rnorm(inits(p),Jump(p)) - - if(tvec(p) < pmin(p)) cycle - do i = 1,nspec - inpars(:) = tvec + rand(:,i) - if(inpars(p) < pmin(p)) then - minflag = .true. - exit - end if - call model(inpars, npars, ipars, cons, ncons, icons, TrySpec) - TryError(:,i) = TrySpec - observed(:,i) - end do - if(minflag) cycle - call prior(tvec(p), pmu(p), psd(p), plog(p), TryPost) - call prior(inits(p), pmu(p), psd(p), plog(p), PrevPost) - do i=1,nw - do j=1,nspec - TryPost = TryPost + ldnorm(TryError(i,j), 0d0, rsd) - PrevPost = PrevPost + ldnorm(PrevError(i,j), 0d0, rsd) - enddo - enddo - a = exp(TryPost - PrevPost) - call random_number(u) - if(a > u) then - inits(p) = tvec(p) - PrevError = TryError - ar(p) = ar(p) + 1 - endif - - !! Sample random effects for parameter p - do r=1,nspec - minflag = .false. - rmat = rand - rmat(p,r) = rnorm(rand(p,r), Jump_re(p)) - do i = 1,nspec - inpars(:) = inits + rmat(:,i) - if(inpars(p) < pmin(p)) then - minflag = .true. - exit - end if - call model(inpars, npars, ipars, cons, ncons, icons, TrySpec) - TryError(:,i) = TrySpec - observed(:,i) - end do - if(minflag) cycle - call prior(rmat(p,r), 0.0d0, tausd(p), .false., TryPost) - call prior(rand(p,r), 0.0d0, tausd(p), .false., PrevPost) - do i=1,nw - do j=1,nspec - TryPost = TryPost + ldnorm(TryError(i,j), 0d0, rsd) - PrevPost = PrevPost + ldnorm(PrevError(i,j), 0d0, rsd) - enddo - enddo - a = exp(TryPost - PrevPost) - call random_number(u) - if(a > u) then - rand(p,r) = rmat(p,r) - PrevError = TryError - ar_re(p) = ar_re(p) + 1 - end if - end do - end do -end subroutine - From b8ca1c6e3b45ae8f77cc50a59833f0eafe3a9b52 Mon Sep 17 00:00:00 2001 From: kragosta Date: Wed, 2 Aug 2017 10:51:41 -0400 Subject: [PATCH 240/771] Made settings$model$config CABLE specific Also added my name to authors --- models/cable/R/write.config.CABLE.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/models/cable/R/write.config.CABLE.R b/models/cable/R/write.config.CABLE.R index 2599443f6e0..530095c64fd 100644 --- a/models/cable/R/write.config.CABLE.R +++ b/models/cable/R/write.config.CABLE.R @@ -21,7 +21,7 @@ ##' @param run.id id of run ##' @return configuration file for CABLE for given run ##' @export -##' @author Rob Kooper +##' @author Rob Kooper, Kaitlin Ragosta ##-------------------------------------------------------------------------------------------------# write.config.CABLE <- function(defaults, trait.values, settings, run.id) { @@ -85,10 +85,10 @@ write.config.CABLE <- function(defaults, trait.values, settings, run.id) { #----------------------------------------------------------------------- ### Edit a templated config file for runs - if (!is.null(settings$model$config) && file.exists(settings$model$config)) { - config.text <- readLines(con = settings$model$config, n = -1) + if (!is.null("cable.nml") && file.exists("cable.nml")) { + config.text <- readLines(con = "cable.nml", n = -1) } else { - filename <- system.file(settings$model$config, package = "PEcAn.CABLE") + filename <- system.file("cable.nml", package = "PEcAn.CABLE") if (filename == "") { if (!is.null(settings$model$revision)) { filename <- system.file(paste0("config.", settings$model$revision), package = "PEcAn.CABLE") From 9b820c027b7e825a38b7383c280e90c4d50dc064 Mon Sep 17 00:00:00 2001 From: kragosta Date: Wed, 2 Aug 2017 11:08:04 -0400 Subject: [PATCH 241/771] Changed 2 lines back to settings$model$config --- models/cable/R/write.config.CABLE.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/cable/R/write.config.CABLE.R b/models/cable/R/write.config.CABLE.R index 530095c64fd..654702d4203 100644 --- a/models/cable/R/write.config.CABLE.R +++ b/models/cable/R/write.config.CABLE.R @@ -85,8 +85,8 @@ write.config.CABLE <- function(defaults, trait.values, settings, run.id) { #----------------------------------------------------------------------- ### Edit a templated config file for runs - if (!is.null("cable.nml") && file.exists("cable.nml")) { - config.text <- readLines(con = "cable.nml", n = -1) + if (!is.null(settings$model$config) && file.exists(settings$model$config)) { + config.text <- readLines(con = settings$model$config, n = -1) } else { filename <- system.file("cable.nml", package = "PEcAn.CABLE") if (filename == "") { From 89a27e881917ad3c7c33d3c5d04cd899b0d77f7c Mon Sep 17 00:00:00 2001 From: kragosta Date: Wed, 2 Aug 2017 11:18:33 -0400 Subject: [PATCH 242/771] Update write_restart.CABLE.R --- models/cable/R/write_restart.CABLE.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/models/cable/R/write_restart.CABLE.R b/models/cable/R/write_restart.CABLE.R index 3c52ffac8a1..d826cfd6ae4 100644 --- a/models/cable/R/write_restart.CABLE.R +++ b/models/cable/R/write_restart.CABLE.R @@ -15,4 +15,6 @@ write_restart.CABLE <- function(outdir, start.time, stop.time, settings, - new.state) {} + new.state) { +logger.severe("NOT IMPLEMENTED") +} From 201bfc256347f82bf84e5bfa9a975ee7297817ca Mon Sep 17 00:00:00 2001 From: kragosta Date: Wed, 2 Aug 2017 11:22:15 -0400 Subject: [PATCH 243/771] Update read_restart.CABLE.R --- models/cable/R/read_restart.CABLE.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/models/cable/R/read_restart.CABLE.R b/models/cable/R/read_restart.CABLE.R index 9372c8ee14a..8c6939a7d16 100644 --- a/models/cable/R/read_restart.CABLE.R +++ b/models/cable/R/read_restart.CABLE.R @@ -18,5 +18,7 @@ read_restart.CABLE <- function(outdir, stop.time, settings, var.names, - params) {} + params) { +logger.severe("NOT IMPLEMENTED") +} From deb833b9265bcf68978c02a369c0f7fcb5f2eff7 Mon Sep 17 00:00:00 2001 From: kragosta Date: Wed, 2 Aug 2017 11:24:21 -0400 Subject: [PATCH 244/771] Changed to PEcAn.CABLE::model2netcdf --- models/cable/inst/template.job | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/models/cable/inst/template.job b/models/cable/inst/template.job index 84d1554b26b..537625c6ad3 100644 --- a/models/cable/inst/template.job +++ b/models/cable/inst/template.job @@ -24,8 +24,7 @@ mkdir -p "@OUTDIR@" fi # convert to MsTMIP - echo "require (PEcAn.CABLE) -model2netcdf.CABLE('@OUTDIR@', @SITE_LAT@, @SITE_LON@, '@START_DATE@', '@END_DATE@') +PEcAn.CABLE::model2netcdf.CABLE('@OUTDIR@', @SITE_LAT@, @SITE_LON@, '@START_DATE@', '@END_DATE@') " | R --vanilla #fi From e8b0452170eacc6e5336915e545a8e74237f0869 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 2 Aug 2017 11:28:03 -0400 Subject: [PATCH 245/771] Require exact dates in DALEC register --- models/dalec/inst/register.DALEC.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/dalec/inst/register.DALEC.xml b/models/dalec/inst/register.DALEC.xml index f72b6d3a426..073da5c2bc5 100644 --- a/models/dalec/inst/register.DALEC.xml +++ b/models/dalec/inst/register.DALEC.xml @@ -1,5 +1,5 @@ DALEC - FALSE + TRUE \ No newline at end of file From 21573f965fc03b8dbc7fca98b1c63e2ffd85583d Mon Sep 17 00:00:00 2001 From: kragosta Date: Wed, 2 Aug 2017 11:33:34 -0400 Subject: [PATCH 246/771] Update NAMESPACE --- models/cable/NAMESPACE | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/models/cable/NAMESPACE b/models/cable/NAMESPACE index e815441f0ca..cd1d7c50342 100644 --- a/models/cable/NAMESPACE +++ b/models/cable/NAMESPACE @@ -1,7 +1,7 @@ # Generated by roxygen2: do not edit by hand -export(met2model.MODEL) -export(model2netcdf.MODEL) -export(read_restart.ModelName) -export(write.config.MODEL) -export(write_restart.ModelName) +export(met2model.CABLE) +export(model2netcdf.CABLE) +export(read_restart.CABLE) +export(write.config.CABLE) +export(write_restart.CABLE) From fb914629365e0bb8894142e54cd1b81c6c9c4aa6 Mon Sep 17 00:00:00 2001 From: kragosta Date: Wed, 2 Aug 2017 12:22:13 -0400 Subject: [PATCH 247/771] Added cable.nml --- models/cable/inst/cable.nml | 71 +++++++++++++++++++++++++++++++++++++ 1 file changed, 71 insertions(+) create mode 100644 models/cable/inst/cable.nml diff --git a/models/cable/inst/cable.nml b/models/cable/inst/cable.nml new file mode 100644 index 00000000000..2c8aacc3633 --- /dev/null +++ b/models/cable/inst/cable.nml @@ -0,0 +1,71 @@ +&cable + filename%met = ' *** SET PATH IN cable.nml *** ' + filename%out = 'out_cable.nc' + filename%log = 'log_cable.txt' + filename%restart_in = ' ' + filename%restart_out = './restart_out.nc' + filename%type = ' *** SET PATH IN cable.nml *** ' + filename%veg = ' *** SET PATH IN cable.nml *** ' + filename%soil = ' *** SET PATH IN cable.nml *** ' + vegparmnew = .TRUE. ! using new format when true + soilparmnew = .TRUE. ! using new format when true + spinup = .TRUE. ! do we spin up the model? + delsoilM = 0.001 ! allowed variation in soil moisture for spin up + delsoilT = 0.01 ! allowed variation in soil temperature for spin up + output%restart = .TRUE. ! should a restart file be created? + output%met = .TRUE. ! input met data + output%flux = .TRUE. ! convective, runoff, NEE + output%soil = .TRUE. ! soil states + output%snow = .TRUE. ! snow states + output%radiation = .TRUE. ! net rad, albedo + output%carbon = .TRUE. ! NEE, GPP, NPP, stores + output%veg = .TRUE. ! vegetation states + output%params = .TRUE. ! input parameters used to produce run + output%balances = .TRUE. ! energy and water balances + check%ranges = .FALSE. ! variable ranges, input and output + check%energy_bal = .TRUE. ! energy balance + check%mass_bal = .TRUE. ! water/mass balance + verbose = .TRUE. ! write details of every grid cell init and params to log? + leaps = .TRUE. ! calculate timing with leap years? + logn = 88 ! log file number - declared in input module + fixedCO2 = 350.0 ! if not found in met file, in ppmv + spincasainput = .FALSE. ! input required to spin casacnp offline + spincasa = .FALSE. ! spin casa before running the model if TRUE, and should be set to FALSE if spincasainput = .TRUE. + l_casacnp = .FALSE. ! using casaCNP with CABLE + l_laiFeedbk = .FALSE. ! using prognostic LAI + l_vcmaxFeedbk = .FALSE. ! using prognostic Vcmax + icycle = 0 ! BP pull it out from casadimension and put here; 0 for not using casaCNP, 1 for C, 2 for C+N, 3 for C+N+P + casafile%cnpipool=' *** SET PATH IN cable.nml *** ' + casafile%cnpbiome=' *** SET PATH IN cable.nml *** ' + casafile%cnpepool='poolcnpOut.csv' ! end of run pool size + casafile%cnpmetout='casamet.nc' ! output daily met forcing for spinning casacnp + casafile%cnpmetin='' ! list of daily met files for spinning casacnp + casafile%phen=' *** SET PATH IN cable.nml *** ' + casafile%cnpflux='cnpfluxOut.csv' + ncciy = 0 ! 0 for not using gswp; 4-digit year input for year of gswp met + gswpfile%rainf = 'gswp/Rainf_gswp1987.nc' + gswpfile%snowf = 'gswp/Snowf_gswp1987.nc' + gswpfile%LWdown= 'gswp/LWdown_srb1987.nc' + gswpfile%SWdown= 'gswp/SWdown_srb1987.nc' + gswpfile%PSurf = 'gswp/PSurf_ecor1987.nc' + gswpfile%Qair = 'gswp/Qair_cru1987.nc' + gswpfile%Tair = 'gswp/Tair_cru1987.nc' + gswpfile%wind = 'gswp/Wind_ncep1987.nc' + redistrb = .FALSE. ! Turn on/off the hydraulic redistribution + wiltParam = 0.5 + satuParam = 0.8 + cable_user%FWSOIL_SWITCH = 'standard' ! choices are: + ! 1. standard + ! 2. non-linear extrapolation + ! 3. Lai and Ktaul 2000 + cable_user%DIAG_SOIL_RESP = 'ON ' + cable_user%LEAF_RESPIRATION = 'ON ' + cable_user%RUN_DIAG_LEVEL= 'BASIC' ! choices are: + ! 1. BASIC + ! 1. NONE + cable_user%CONSISTENCY_CHECK= .TRUE. ! TRUE outputs combined fluxes at each timestep for comparisson to A control run + cable_user%CASA_DUMP_READ = .FALSE. ! TRUE reads CASA forcing from netcdf format + cable_user%CABLE_RUNTIME_COUPLED = .FALSE. ! see Ticket 43 + cable_user%CASA_DUMP_WRITE = .FALSE. ! TRUE outputs CASA forcing in netcdf format + cable_user%SSNOW_POTEV= 'HDM' ! Humidity Deficit Method +&end From 17fe810990b0bbbe5fbb9bd7c4d288bb14118fbb Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 2 Aug 2017 14:27:56 -0400 Subject: [PATCH 248/771] Change sla input to constants list --- modules/data.land/R/align_pools.R | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/modules/data.land/R/align_pools.R b/modules/data.land/R/align_pools.R index 722bff38b05..185ec36c16c 100644 --- a/modules/data.land/R/align_pools.R +++ b/modules/data.land/R/align_pools.R @@ -4,10 +4,10 @@ ##' @export ##' ##' @param nc.path path to netcdf file containing standard dimensions and variables; currently supports these variables: TotLivBiom, leaf_carbon_content, LAI, AbvGrndWood, root_carbon_content, fine_root_carbon_content, coarse_root_carbon_content, litter_carbon_content, soil_organic_carbon_content, soil_carbon_content, wood_debris_carbon_content -##' @param sla SLA in m2 / kg C if providing LAI for leaf carbon +##' @param constants list of constants; must include SLA in m2 / kg C if providing LAI for leaf carbon ##' @return list of pool values in kg C / m2 with generic names ##' @author Anne Thomas -align_pools <- function(nc.path, sla = NULL){ +align_pools <- function(nc.path, constants = NULL){ #function to check that var was loaded (numeric) and has a valid value (not NA or negative) is.valid <- function(var){ return(all(is.numeric(var) && !is.na(var) && var >= 0)) @@ -27,6 +27,7 @@ align_pools <- function(nc.path, sla = NULL){ fine.roots <- IC.list$vals$fine_root_carbon_content coarse.roots <- IC.list$vals$coarse_root_carbon_content + ### load non-living variables litter <- IC.list$vals$litter_carbon_content soil <- IC.list$vals$soil_organic_carbon_content @@ -58,10 +59,15 @@ align_pools <- function(nc.path, sla = NULL){ # initial canopy foliar carbon (kgC/m2) if (is.valid(leaf)) { IC.params[["leaf"]] <- leaf - } else if(is.valid(LAI) && !is.null(sla)){ + } else if(is.valid(LAI)){ + sla <- constants$sla + if(sla != NULL){ leaf <- LAI * 1/sla PEcAn.utils::logger.info(paste("using LAI", LAI, "and SLA", sla, "to get leaf", leaf)) IC.params[["leaf"]] <- leaf + } else{ + PEcAn.utils::logger.error("Could not convert LAI to leaf carbon without SLA; please include 'constants' list with named element 'sla'") + } } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && is.valid(fine.roots) && is.valid(coarse.roots)){ leaf <- (TotLivBiom - AbvGrndWood - fine.roots - coarse.roots) From 0b93093ce64defb9301b64fa567f60c048f3141b Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 2 Aug 2017 14:30:39 -0400 Subject: [PATCH 249/771] update write.configs.dalec --- models/dalec/R/write.configs.dalec.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 95c81203672..4384bc7db3b 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -121,7 +121,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { sla <- default.param[which(default.param$cmdFlag == "SLA"),"val"] * 1000 #convert SLA to m2/kgC from m2/gC (dalec default) } - IC.pools <- PEcAn.data.land::align_pools(IC.path, sla) + IC.pools <- PEcAn.data.land::align_pools(IC.path, constants = list(sla = sla)) if(!is.null(IC.pools)){ ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) From c69457967996300541ea1f0aa5201fab7cfa6b54 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 2 Aug 2017 14:35:34 -0400 Subject: [PATCH 250/771] Bugfix: Passing host list, when should be hostname --- utils/R/convert.input.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/utils/R/convert.input.R b/utils/R/convert.input.R index a6facb102f5..b32f34e6287 100644 --- a/utils/R/convert.input.R +++ b/utils/R/convert.input.R @@ -141,7 +141,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st startdate = start_date, enddate = end_date, con = con, - hostname = host, + hostname = host$name, pattern = pattern ) From ae1e1817bde5e2053dd89c3d34b04c86b76c0697 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 2 Aug 2017 14:45:21 -0400 Subject: [PATCH 251/771] update write.configs.sipnet to use align_pools --- models/sipnet/R/write.configs.SIPNET.R | 38 ++++++++++---------------- 1 file changed, 14 insertions(+), 24 deletions(-) diff --git a/models/sipnet/R/write.configs.SIPNET.R b/models/sipnet/R/write.configs.SIPNET.R index 2fd55c0483e..d979417f274 100644 --- a/models/sipnet/R/write.configs.SIPNET.R +++ b/models/sipnet/R/write.configs.SIPNET.R @@ -361,18 +361,13 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs } else if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path - IC.nc <- try(ncdf4::nc_open(IC.path)) - if(class(IC.nc) != "try-error"){ - ## plantWoodInit gC/m2 - AbvGrndWood <- try(ncdf4::ncvar_get(IC.nc,"AbvGrndWood"),silent = TRUE) - if (!is.na(AbvGrndWood) && is.numeric(AbvGrndWood)) { - fineRootFrac <- param[which(param[, 1] == "fineRootFrac"), 2] - coarseRootFrac <- param[which(param[, 1] == "coarseRootFrac"), 2] - plantWood <- AbvGrndWood/(1-(fineRootFrac+coarseRootFrac)) #inflate plantWood to include belowground - param[which(param[, 1] == "plantWoodInit"), 2] <- plantWood * 1000 #PEcAn standard AbvGrndWood kgC/m2 - } - else{ - #try back-calculate from LAI,sla, and total biomass? where is total biomass? + IC.pools <- PEcAn.data.land::align_pools(IC.path, constants = list(sla = SLA)) + + if(!is.null(IC.pools)){ + IC.nc <- ncdf4::nc_open(IC.path) #for additional variables specific to SIPNET + ## plantWoodInit gC/m2 + if ("wood" %in% names(IC.pools)) { + param[which(param[, 1] == "plantWoodInit"), 2] <- ICpools$wood * 1000 #from PEcAn standard AbvGrndWood kgC/m2 } ## laiInit m2/m2 lai <- try(ncdf4::ncvar_get(IC.nc,"LAI"),silent = TRUE) @@ -380,14 +375,12 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs param[which(param[, 1] == "laiInit"), 2] <- lai } ## litterInit gC/m2 - litter <- try(ncdf4::ncvar_get(IC.nc,"litter_carbon_content"),silent = TRUE) - if (!is.na(litter) && is.numeric(litter)) { - param[which(param[, 1] == "litterInit"), 2] <- litter * 1000 #PEcAn standard litter_carbon_content kg/m2 + if ("litter" %in% names(IC.pools)) { + param[which(param[, 1] == "litterInit"), 2] <- ICpools$litter * 1000 #from PEcAn standard litter_carbon_content kg/m2 } ## soilInit gC/m2 - soil <- try(ncdf4::ncvar_get(IC.nc,"soil_carbon_content"),silent = TRUE) - if (!is.na(soil) && is.numeric(soil)) { - param[which(param[, 1] == "soilInit"), 2] <- sum(soil) * 1000 #PEcAn standard TotSoilCarb kg C/m2 + if ("soil" %in% names(IC.pools)) { + param[which(param[, 1] == "soilInit"), 2] <- sum(ICpools$soil) * 1000 #from PEcAn standard TotSoilCarb kg C/m2 } ## soilWFracInit fraction soilWFrac <- try(ncdf4::ncvar_get(IC.nc,"SoilMoistFrac"),silent = TRUE) @@ -400,19 +393,16 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs ## snowInit cm water equivalent snow = try(ncdf4::ncvar_get(IC.nc,"SWE"),silent = TRUE) if (!is.na(snow) && is.numeric(snow)) { - param[which(param[, 1] == "snowInit"), 2] <- snow*0.1 #PEcAn standard SWE kg/m2 (1kg = 1mm) + param[which(param[, 1] == "snowInit"), 2] <- snow*0.1 #from PEcAn standard SWE kg/m2 (1kg = 1mm) } ## microbeInit mgC/g soil microbe <- try(ncdf4::ncvar_get(IC.nc,"Microbial Biomass C"),silent = TRUE) if (!is.na(microbe) && is.numeric(microbe)) { param[which(param[, 1] == "microbeInit"), 2] <- microbe * .001 #BETY Microbial Biomass C mg C kg-1 soil } - - #close file ncdf4::nc_close(IC.nc) - } - else{ - PEcAn.utils::logger.error("Bad initial conditions filepath; kept defaults") + }else{ + PEcAn.utils::logger.error("Bad initial conditions filepath; keeping defaults") } }else{ #some stuff about IC file that we can give in lieu of actual ICs From 8ae69068385765dc214638f9d35b916e9533ae67 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 2 Aug 2017 14:47:30 -0400 Subject: [PATCH 252/771] change comments --- models/dalec/R/write.configs.dalec.R | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 4384bc7db3b..3d49cb3c4a8 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -15,7 +15,7 @@ PREFIX_XML <- "\n" convert.samples.DALEC <- function(trait.samples) { DEFAULT.LEAF.C <- 0.48 - ## convert SLA from m2 / kg leaf to m2 / g C + ## convert SLA from PEcAn m2 / kg leaf to m2 / g C if ("SLA" %in% names(trait.samples)) { trait.samples[["SLA"]] <- trait.samples[["SLA"]]/DEFAULT.LEAF.C/1000 @@ -128,31 +128,31 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { # cf0 initial canopy foliar carbon (g/m2) if ("leaf" %in% names(IC.pools)) { - IC.params[["cf0"]] <- IC.pools$leaf * 1000 #from standard kg C m-2 + IC.params[["cf0"]] <- IC.pools$leaf * 1000 #from PEcAn standard kg C m-2 } # cw0 initial pool of woody carbon (g/m2) if ("wood" %in% names(IC.pools)) { - IC.params[["cw0"]] <- IC.pools$wood * 1000 #from standard kg C m-2 + IC.params[["cw0"]] <- IC.pools$wood * 1000 #from PEcAn standard kg C m-2 } # cr0 initial pool of fine root carbon (g/m2) if ("fine.roots" %in% names(IC.pools)) { - IC.params[["cr0"]] <- IC.pools$fine.roots * 1000 #from standard kg C m-2 + IC.params[["cr0"]] <- IC.pools$fine.roots * 1000 #from PEcAn standard kg C m-2 } ###non-living variables # cl0 initial pool of litter carbon (g/m2) if ("litter" %in% names(IC.pools)) { - IC.params[["cl0"]] <- IC.pools$litter * 1000 #from standard kg C m-2 + IC.params[["cl0"]] <- IC.pools$litter * 1000 #from PEcAn standard kg C m-2 } # cs0 initial pool of soil organic matter and woody debris carbon (g/m2) if("soil" %in% names(IC.pools)){ if("wood.debris" %in% names(IC.pools)){ - IC.params[["cs0"]] <- (IC.pools$soil + sum(IC.pools$wood.debris)) * 1000 #from standard kg C m-2 + IC.params[["cs0"]] <- (IC.pools$soil + sum(IC.pools$wood.debris)) * 1000 #from PEcAn standard kg C m-2 } else { - IC.params[["cs0"]] <- IC.pools$soil * 1000 #from standard kg C m-2 + IC.params[["cs0"]] <- IC.pools$soil * 1000 #from PEcAn standard kg C m-2 PEcAn.utils::logger.warn("write.configs.DALEC IC: Loading soil carbon pool without woody debris.") } } From 289b376aa3aad8520ada0a8179a72dd0985bb0f9 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 2 Aug 2017 15:13:43 -0400 Subject: [PATCH 253/771] documentation update --- modules/data.land/man/align_pools.Rd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.land/man/align_pools.Rd b/modules/data.land/man/align_pools.Rd index c20780a7ecd..09d36e553db 100644 --- a/modules/data.land/man/align_pools.Rd +++ b/modules/data.land/man/align_pools.Rd @@ -4,12 +4,12 @@ \alias{align_pools} \title{align_pools} \usage{ -align_pools(nc.path, sla = NULL) +align_pools(nc.path, constants = NULL) } \arguments{ \item{nc.path}{path to netcdf file containing standard dimensions and variables; currently supports these variables: TotLivBiom, leaf_carbon_content, LAI, AbvGrndWood, root_carbon_content, fine_root_carbon_content, coarse_root_carbon_content, litter_carbon_content, soil_organic_carbon_content, soil_carbon_content, wood_debris_carbon_content} -\item{sla}{SLA in m2 / kg C if providing LAI for leaf carbon} +\item{constants}{list of constants; must include SLA in m2 / kg C if providing LAI for leaf carbon} } \value{ list of pool values in kg C / m2 with generic names From 04278b562082cfbb31340accfcfeb478bbb45f84 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 2 Aug 2017 15:14:16 -0400 Subject: [PATCH 254/771] Fix null check --- modules/data.land/R/align_pools.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/R/align_pools.R b/modules/data.land/R/align_pools.R index 185ec36c16c..880f2653384 100644 --- a/modules/data.land/R/align_pools.R +++ b/modules/data.land/R/align_pools.R @@ -61,7 +61,7 @@ align_pools <- function(nc.path, constants = NULL){ IC.params[["leaf"]] <- leaf } else if(is.valid(LAI)){ sla <- constants$sla - if(sla != NULL){ + if(!is.null(sla)){ leaf <- LAI * 1/sla PEcAn.utils::logger.info(paste("using LAI", LAI, "and SLA", sla, "to get leaf", leaf)) IC.params[["leaf"]] <- leaf From e31fafb1a7094a9fd41d3b6692e4b2af83377502 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 2 Aug 2017 15:29:14 -0400 Subject: [PATCH 255/771] Fix IC.pools --- models/sipnet/R/write.configs.SIPNET.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/models/sipnet/R/write.configs.SIPNET.R b/models/sipnet/R/write.configs.SIPNET.R index d979417f274..1f00a22248c 100644 --- a/models/sipnet/R/write.configs.SIPNET.R +++ b/models/sipnet/R/write.configs.SIPNET.R @@ -367,7 +367,7 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs IC.nc <- ncdf4::nc_open(IC.path) #for additional variables specific to SIPNET ## plantWoodInit gC/m2 if ("wood" %in% names(IC.pools)) { - param[which(param[, 1] == "plantWoodInit"), 2] <- ICpools$wood * 1000 #from PEcAn standard AbvGrndWood kgC/m2 + param[which(param[, 1] == "plantWoodInit"), 2] <- IC.pools$wood * 1000 #from PEcAn standard AbvGrndWood kgC/m2 } ## laiInit m2/m2 lai <- try(ncdf4::ncvar_get(IC.nc,"LAI"),silent = TRUE) @@ -376,11 +376,11 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs } ## litterInit gC/m2 if ("litter" %in% names(IC.pools)) { - param[which(param[, 1] == "litterInit"), 2] <- ICpools$litter * 1000 #from PEcAn standard litter_carbon_content kg/m2 + param[which(param[, 1] == "litterInit"), 2] <- IC.pools$litter * 1000 #from PEcAn standard litter_carbon_content kg/m2 } ## soilInit gC/m2 if ("soil" %in% names(IC.pools)) { - param[which(param[, 1] == "soilInit"), 2] <- sum(ICpools$soil) * 1000 #from PEcAn standard TotSoilCarb kg C/m2 + param[which(param[, 1] == "soilInit"), 2] <- sum(IC.pools$soil) * 1000 #from PEcAn standard TotSoilCarb kg C/m2 } ## soilWFracInit fraction soilWFrac <- try(ncdf4::ncvar_get(IC.nc,"SoilMoistFrac"),silent = TRUE) From 513ad4615821f35eb43ad1ef22053fc4766293c5 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 1 Aug 2017 15:11:39 -0400 Subject: [PATCH 256/771] Use faster effective sample size calc. --- modules/rtm/R/neff.R | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/modules/rtm/R/neff.R b/modules/rtm/R/neff.R index 1ff72cde230..d014cb9a312 100644 --- a/modules/rtm/R/neff.R +++ b/modules/rtm/R/neff.R @@ -8,17 +8,23 @@ neff <- function(x) { } #' @export -neff.default <- function(x, ...) { - xna <- is.na(x) - if (any(xna)) { - warning("NA in neff input. Omitting.") - x <- x[!xna] +neff.default <- function(x, lag.max = NULL, min_rho = 0.1) { + x_use <- x[!is.na(x)] + nx <- length(x_use) + if (is.null(lag.max)) { + # Same as in the ACF function + lag.max <- floor(10 * log10(nx)) } - arout <- ar.yw(x, ...) - spec <- arout$var.pred/(1 - sum(arout$ar))^2 - out <- length(x) * var(x) / spec - stopifnot(length(out) == 1) - return(out) + rho_all <- .Call(stats:::C_acf, x_use, lag.max, TRUE) + rho <- rho_all[-1] + too_small <- rho < min_rho + if (any(too_small)) { + rho <- rho[seq_len(which(too_small)[1])] + } + nrho <- length(rho) + tau <- 1 + 2 * sum((1 - seq_len(nrho) / nx) * rho) + n_eff <- nx / tau + return(n_eff) } #' @export From 55168ec692e42131b00dea4c3a96547e375fb540 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 1 Aug 2017 17:24:15 -0400 Subject: [PATCH 257/771] Revise BayesianTools helpers in `assim.batch` * In the `pda.create.btprior` function, replace `parse-eval` framework, which is unsafe and a bit clunky, with functional programming (`match.fun`, and then). * Move BayesianTools-related functions to their own file. * Add unit tests for `pda.create.btprior`. --- .../assim.batch/R/pda.bayestools.helpers.R | 233 ++++++++++++++++++ modules/assim.batch/R/pda.utils.R | 202 --------------- modules/assim.batch/man/correlationPlot.Rd | 6 +- modules/assim.batch/man/pda.create.btprior.Rd | 18 +- modules/assim.batch/man/pda.settings.bt.Rd | 2 +- .../tests/testthat/test.bt_prior.R | 37 +++ 6 files changed, 287 insertions(+), 211 deletions(-) create mode 100644 modules/assim.batch/R/pda.bayestools.helpers.R create mode 100644 modules/assim.batch/tests/testthat/test.bt_prior.R diff --git a/modules/assim.batch/R/pda.bayestools.helpers.R b/modules/assim.batch/R/pda.bayestools.helpers.R new file mode 100644 index 00000000000..50f754fd80c --- /dev/null +++ b/modules/assim.batch/R/pda.bayestools.helpers.R @@ -0,0 +1,233 @@ +##' Create priors for BayesianTools +##' +##' Helper function for creating log-priors compatible with BayesianTools package +##' +##' @param prior.sel `data.frame` containing prior distributions of the selected parameters +##' +##' @return out Prior class object for BayesianTools package +##' @details `prior.sel` must contain the following columns: +##' * `distn` -- String describing a distribution; e.g. `norm` for `dnorm`, `rnorm`, etc. +##' * `parama`, `paramb` -- First and second parameters, respectively, of the corresponding distribution +##' +##' Optionally, `prior.sel` may also contain the following columns: +##' * `param_name` -- Parameter name, which will be carried through to the prior object and sampler +##' * `lower`, `upper` -- Lower and upper bounds, respectively. These can be leveraged by the BayesianTools samplers. +##' * `best` -- Best guess for a parameter estimate. BayesianTools can also use this, though I'm not sure how... +##' +##' @author Istem Fer, Alexey Shiklomanov +##' @export +pda.create.btprior <- function(prior.sel) { + + # TODO: test exponential -- it only has one argument, so this won't work + + # Returns a function that calculates the density of the specified + # distribution given the parameters + ddist_generator <- function(distn, a, b) { + fun_string <- paste0('d', distn) + f <- match.fun(fun_string) + out <- function(x) f(x, a, b, log = TRUE) + return(out) + } + + # Returns a function that draws from the specified distribution with the + # specified parameters + rdist_generator <- function(distn, a, b) { + fun_string <- paste0('r', distn) + f <- match.fun(fun_string) + out <- function(n = 1) f(n, a, b) + return(out) + } + + # Create a list of density and random draw functions + ddist_funs <- with(prior.sel, mapply(ddist_generator, distn, parama, paramb)) + rdist_funs <- with(prior.sel, mapply(rdist_generator, distn, parama, paramb)) + if ('param_name' %in% names(prior.sel)) { + names(ddist_funs) <- names(rdist_funs) <- prior.sel[['param_name']] + } + + # `mapply` statement returns + density <- function(params) { + dens_vec <- mapply(function(f, x) f(x), ddist_funs, params) # Returns vector of log densities + out <- sum(dens_vec) + return(out) + } + + # Returns vector of random draws + sampler <- function() { + out <- vapply(rdist_funs, function(f) f(), numeric(1)) + return(out) + } + + # BayesianTools lower and upper bounds and best guess, if specified in data.frame + lower <- NULL + if ('lower' %in% names(prior.sel)) { + lower <- prior.sel[['lower']] + } + upper <- NULL + if ('upper' %in% names(prior.sel)) { + upper <- prior.sel[['upper']] + } + best <- NULL + if ('best' %in% names(prior.sel)) { + best <- prior.sel[['best']] + } + + # Use createPrior{BayesianTools} function to create prior class object compatible + # with rest of the functions + out <- BayesianTools::createPrior(density = density, sampler = sampler, + lower = lower, upper = upper, best = best) + return(out) +} # pda.create.btprior + + +##' Helper function for applying BayesianTools specific settings from PEcAn general settings +##' +##' @title Apply settings for BayesianTools +##' @param settings PEcAn settings +##' +##' @return bt.settings list of runMCMC{BayesianTools} settings +##' +##' @author Istem Fer +##' @export +##' +pda.settings.bt <- function(settings) { + + sampler <- settings$assim.batch$bt.settings$sampler + + iterations <- as.numeric(settings$assim.batch$bt.settings$iter) + optimize <- ifelse(!is.null(settings$assim.batch$bt.settings$optimize), + settings$assim.batch$bt.settings$optimize, + TRUE) + # consoleUpdates = ifelse(!is.null(settings$assim.batch$bt.settings$consoleUpdates), + # as.numeric(settings$assim.batch$bt.settings$consoleUpdates), max(round(iterations/10),100)) + adapt <- ifelse(!is.null(settings$assim.batch$bt.settings$adapt), + settings$assim.batch$bt.settings$adapt, + TRUE) + adaptationInverval = ifelse(!is.null(settings$assim.batch$bt.settings$adaptationInverval), + as.numeric(settings$assim.batch$bt.settings$adaptationInverval), + max(round(iterations/100*5),100)) + adaptationNotBefore <- ifelse(!is.null(settings$assim.batch$bt.settings$adaptationNotBefore), + as.numeric(settings$assim.batch$bt.settings$adaptationNotBefore), + adaptationInverval) + DRlevels <- ifelse(!is.null(settings$assim.batch$bt.settings$DRlevels), + as.numeric(settings$assim.batch$bt.settings$DRlevels), + 1) + if (!is.null(settings$assim.batch$bt.settings$gibbsProbabilities)) { + gibbsProbabilities <- as.numeric(unlist(settings$assim.batch$bt.settings$gibbsProbabilities)) + } else { + gibbsProbabilities <- NULL + } + + if (sampler == "Metropolis") { + bt.settings <- list(iterations = iterations, + optimize = optimize, + DRlevels = DRlevels, + adapt = adapt, + adaptationNotBefore = adaptationNotBefore, + gibbsProbabilities = gibbsProbabilities) + } else if (sampler %in% c("AM", "M", "DRAM", "DR")) { + bt.settings <- list(iterations = iterations, startValue = "prior") + } else if (sampler %in% c("DE", "DEzs", "DREAM", "DREAMzs", "Twalk")) { + bt.settings <- list(iterations = iterations) + } else if (sampler == "SMC") { + bt.settings <- list(initialParticles = list("prior", iterations)) + } else { + logger.error(paste0(sampler, " sampler not found!")) + } + + return(bt.settings) +} # pda.settings.bt + +#' Flexible function to create correlation density plots +#' +#' numeric matrix or data.frame +#' @author Florian Hartig +#' @param mat matrix or data frame of variables +#' @param density type of plot to do +#' @param thin thinning of the matrix to make things faster. Default is to thin to 5000 +#' @param method method for calculating correlations +#' @import IDPmisc +#' @import ellipse +#' @references The code for the correlation density plot originates from Hartig, F.; Dislich, C.; Wiegand, T. & Huth, A. (2014) Technical Note: Approximate Bayesian parameterization of a process-based tropical forest model. Biogeosciences, 11, 1261-1272. +#' @export +#' +correlationPlot <- function(mat, density = "smooth", thin = "auto", method = "pearson", whichParameters = NULL) { + + if (inherits(mat, "bayesianOutput")) { + mat <- getSample(mat, thin = thin, whichParameters = whichParameters, ...) + } + + numPars <- ncol(mat) + names <- colnames(mat) + + panel.hist.dens <- function(x, ...) { + usr <- par("usr") + on.exit(par(usr)) + par(usr = c(usr[1:2], 0, 1.5)) + h <- hist(x, plot = FALSE) + breaks <- h$breaks + nB <- length(breaks) + y <- h$counts + y <- y/max(y) + rect(breaks[-nB], 0, breaks[-1], y, col = "blue4", ...) + } # panel.hist.dens + + # replaced by spearman + panel.cor <- function(x, y, digits = 2, prefix = "", cex.cor, ...) { + usr <- par("usr") + on.exit(par(usr)) + par(usr = c(0, 1, 0, 1)) + r <- cor(x, y, use = "complete.obs", method = method) + txt <- format(c(r, 0.123456789), digits = digits)[1] + txt <- paste0(prefix, txt) + if (missing(cex.cor)) { + cex.cor <- 0.8/strwidth(txt) + } + text(0.5, 0.5, txt, cex = cex.cor * abs(r)) + } # panel.cor + + plotEllipse <- function(x, y) { + usr <- par("usr") + on.exit(par(usr)) + par(usr = c(usr[1:2], 0, 1.5)) + cor <- cor(x, y) + el <- ellipse::ellipse(cor) + polygon(el[, 1] + mean(x), el[, 2] + mean(y), col = "red") + } # plotEllipse + + correlationEllipse <- function(x) { + cor <- cor(x) + ToRGB <- function(x) { + rgb(x[1] / 255, x[2] / 255, x[3] / 255) + } + C1 <- ToRGB(c(178, 24, 43)) + C2 <- ToRGB(c(214, 96, 77)) + C3 <- ToRGB(c(244, 165, 130)) + C4 <- ToRGB(c(253, 219, 199)) + C5 <- ToRGB(c(247, 247, 247)) + C6 <- ToRGB(c(209, 229, 240)) + C7 <- ToRGB(c(146, 197, 222)) + C8 <- ToRGB(c(67, 147, 195)) + C9 <- ToRGB(c(33, 102, 172)) + CustomPalette <- colorRampPalette(rev(c(C1, C2, C3, C4, C5, C6, C7, C8, C9))) + ord <- order(cor[1, ]) + xc <- cor[ord, ord] + colors <- unlist(CustomPalette(100)) + ellipse::plotcorr(xc, col = colors[xc * 50 + 50]) + } # correlationEllipse + + if (density == "smooth") { + pairs(mat, lower.panel = function(...) { + par(new = TRUE) + IDPmisc::ipanel.smooth(...) + }, diag.panel = panel.hist.dens, upper.panel = panel.cor) + } else if (density == "corellipseCor") { + pairs(mat, lower.panel = plotEllipse, diag.panel = panel.hist.dens, upper.panel = panel.cor) + } else if (density == "ellipse") { + correlationEllipse(mat) + } else if (density == F) { + pairs(mat, lower.panel = panel.cor, diag.panel = panel.hist.dens, upper.panel = panel.cor) + } else stop("wrong sensity argument") + + # The if block above is generating return values +} # correlationPlot diff --git a/modules/assim.batch/R/pda.utils.R b/modules/assim.batch/R/pda.utils.R index 765fe2a776a..649c73a38ed 100644 --- a/modules/assim.batch/R/pda.utils.R +++ b/modules/assim.batch/R/pda.utils.R @@ -665,208 +665,6 @@ pda.generate.sf <- function(n.knot, sf, prior.list){ } - -##' Helper function for creating log-priors compatible with BayesianTools package -##' -##' @title Create priors for BayesianTools -##' @param prior.sel prior distributions of the selected parameters -##' -##' @return out prior class object for BayesianTools package -##' -##' @author Istem Fer -##' @export -pda.create.btprior <- function(prior.sel) { - - dens.fn <- samp.fn <- list() - - # TODO: test exponential - for (i in seq_len(nrow(prior.sel))) { - # if(prior.sel$distn[i] == 'exp'){ - # dens.fn[[i]]=paste('d',prior.sel$distn[i],'(x[',i,'],',prior.sel$parama[i],',log=TRUE)',sep='') - # samp.fn[[i]] <- paste('x[',i,']=r',prior.sel$distn[i],'(1,',prior.sel$parama[i],')',sep='') - # }else{ - dens.fn[[i]] <- paste0("d", - prior.sel$distn[i], - "(x[", i, "],", - prior.sel$parama[i], - ",", - prior.sel$paramb[i], - ",log=TRUE)") - samp.fn[[i]] <- paste0("x[", i, "]=r", - prior.sel$distn[i], - "(1,", prior.sel$parama[i], - ",", - prior.sel$paramb[i], - ")") - # } - } - - to.density <- paste(dens.fn, collapse = ",") - to.sampler <- paste(samp.fn, collapse = " ", "\n") - - density <- eval(parse(text = paste0("function(x){ \n return(sum(", to.density, ")) \n }"))) - sampler <- eval(parse(text = paste0("function(){ \n x=rep(NA,", nrow(prior.sel), ") \n", to.sampler, - "return(x) \n ", "}"))) - - # Use createPrior{BayesianTools} function to create prior class object compatible - # with rest of the functions - out <- createPrior(density = density, sampler = sampler) - return(out) -} # pda.create.btprior - - -##' Helper function for applying BayesianTools specific settings from PEcAn general settings -##' -##' @title Apply settings for BayesianTools -##' @param settings PEcAn settings -##' -##' @return bt.settings list of runMCMC{BayesianTools} settings -##' -##' @author Istem Fer -##' @export -##' -pda.settings.bt <- function(settings) { - - sampler <- settings$assim.batch$bt.settings$sampler - - iterations <- as.numeric(settings$assim.batch$bt.settings$iter) - optimize <- ifelse(!is.null(settings$assim.batch$bt.settings$optimize), - settings$assim.batch$bt.settings$optimize, - TRUE) - # consoleUpdates = ifelse(!is.null(settings$assim.batch$bt.settings$consoleUpdates), - # as.numeric(settings$assim.batch$bt.settings$consoleUpdates), max(round(iterations/10),100)) - adapt <- ifelse(!is.null(settings$assim.batch$bt.settings$adapt), - settings$assim.batch$bt.settings$adapt, - TRUE) - adaptationInverval = ifelse(!is.null(settings$assim.batch$bt.settings$adaptationInverval), - as.numeric(settings$assim.batch$bt.settings$adaptationInverval), - max(round(iterations/100*5),100)) - adaptationNotBefore <- ifelse(!is.null(settings$assim.batch$bt.settings$adaptationNotBefore), - as.numeric(settings$assim.batch$bt.settings$adaptationNotBefore), - adaptationInverval) - DRlevels <- ifelse(!is.null(settings$assim.batch$bt.settings$DRlevels), - as.numeric(settings$assim.batch$bt.settings$DRlevels), - 1) - if (!is.null(settings$assim.batch$bt.settings$gibbsProbabilities)) { - gibbsProbabilities <- as.numeric(unlist(settings$assim.batch$bt.settings$gibbsProbabilities)) - } else { - gibbsProbabilities <- NULL - } - - if (sampler == "Metropolis") { - bt.settings <- list(iterations = iterations, - optimize = optimize, - DRlevels = DRlevels, - adapt = adapt, - adaptationNotBefore = adaptationNotBefore, - gibbsProbabilities = gibbsProbabilities) - } else if (sampler %in% c("AM", "M", "DRAM", "DR")) { - bt.settings <- list(iterations = iterations, startValue = "prior") - } else if (sampler %in% c("DE", "DEzs", "DREAM", "DREAMzs", "Twalk")) { - bt.settings <- list(iterations = iterations) - } else if (sampler == "SMC") { - bt.settings <- list(initialParticles = list("prior", iterations)) - } else { - logger.error(paste0(sampler, " sampler not found!")) - } - - return(bt.settings) -} # pda.settings.bt - - -#' Flexible function to create correlation density plots -#' numeric matrix or data.frame -#' @author Florian Hartig -#' @param mat matrix or data frame of variables -#' @param density type of plot to do -#' @param thin thinning of the matrix to make things faster. Default is to thin to 5000 -#' @param method method for calculating correlations -#' @import IDPmisc -#' @import ellipse -#' @references The code for the correlation density plot originates from Hartig, F.; Dislich, C.; Wiegand, T. & Huth, A. (2014) Technical Note: Approximate Bayesian parameterization of a process-based tropical forest model. Biogeosciences, 11, 1261-1272. -#' @export -#' -correlationPlot <- function(mat, density = "smooth", thin = "auto", method = "pearson", whichParameters = NULL) { - - if (inherits(mat, "bayesianOutput")) { - mat <- getSample(mat, thin = thin, whichParameters = whichParameters, ...) - } - - numPars <- ncol(mat) - names <- colnames(mat) - - panel.hist.dens <- function(x, ...) { - usr <- par("usr") - on.exit(par(usr)) - par(usr = c(usr[1:2], 0, 1.5)) - h <- hist(x, plot = FALSE) - breaks <- h$breaks - nB <- length(breaks) - y <- h$counts - y <- y/max(y) - rect(breaks[-nB], 0, breaks[-1], y, col = "blue4", ...) - } # panel.hist.dens - - # replaced by spearman - panel.cor <- function(x, y, digits = 2, prefix = "", cex.cor, ...) { - usr <- par("usr") - on.exit(par(usr)) - par(usr = c(0, 1, 0, 1)) - r <- cor(x, y, use = "complete.obs", method = method) - txt <- format(c(r, 0.123456789), digits = digits)[1] - txt <- paste0(prefix, txt) - if (missing(cex.cor)) { - cex.cor <- 0.8/strwidth(txt) - } - text(0.5, 0.5, txt, cex = cex.cor * abs(r)) - } # panel.cor - - plotEllipse <- function(x, y) { - usr <- par("usr") - on.exit(par(usr)) - par(usr = c(usr[1:2], 0, 1.5)) - cor <- cor(x, y) - el <- ellipse::ellipse(cor) - polygon(el[, 1] + mean(x), el[, 2] + mean(y), col = "red") - } # plotEllipse - - correlationEllipse <- function(x) { - cor <- cor(x) - ToRGB <- function(x) { - rgb(x[1] / 255, x[2] / 255, x[3] / 255) - } - C1 <- ToRGB(c(178, 24, 43)) - C2 <- ToRGB(c(214, 96, 77)) - C3 <- ToRGB(c(244, 165, 130)) - C4 <- ToRGB(c(253, 219, 199)) - C5 <- ToRGB(c(247, 247, 247)) - C6 <- ToRGB(c(209, 229, 240)) - C7 <- ToRGB(c(146, 197, 222)) - C8 <- ToRGB(c(67, 147, 195)) - C9 <- ToRGB(c(33, 102, 172)) - CustomPalette <- colorRampPalette(rev(c(C1, C2, C3, C4, C5, C6, C7, C8, C9))) - ord <- order(cor[1, ]) - xc <- cor[ord, ord] - colors <- unlist(CustomPalette(100)) - ellipse::plotcorr(xc, col = colors[xc * 50 + 50]) - } # correlationEllipse - - if (density == "smooth") { - pairs(mat, lower.panel = function(...) { - par(new = TRUE) - IDPmisc::ipanel.smooth(...) - }, diag.panel = panel.hist.dens, upper.panel = panel.cor) - } else if (density == "corellipseCor") { - pairs(mat, lower.panel = plotEllipse, diag.panel = panel.hist.dens, upper.panel = panel.cor) - } else if (density == "ellipse") { - correlationEllipse(mat) - } else if (density == F) { - pairs(mat, lower.panel = panel.cor, diag.panel = panel.hist.dens, upper.panel = panel.cor) - } else stop("wrong sensity argument") - - # The if block above is generating return values -} # correlationPlot - ##' @title return.bias ##' @author Istem Fer ##' @export diff --git a/modules/assim.batch/man/correlationPlot.Rd b/modules/assim.batch/man/correlationPlot.Rd index e55004137a8..14d9b0d61c8 100644 --- a/modules/assim.batch/man/correlationPlot.Rd +++ b/modules/assim.batch/man/correlationPlot.Rd @@ -1,9 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pda.utils.R +% Please edit documentation in R/pda.bayestools.helpers.R \name{correlationPlot} \alias{correlationPlot} -\title{Flexible function to create correlation density plots -numeric matrix or data.frame} +\title{Flexible function to create correlation density plots} \usage{ correlationPlot(mat, density = "smooth", thin = "auto", method = "pearson", whichParameters = NULL) @@ -18,7 +17,6 @@ correlationPlot(mat, density = "smooth", thin = "auto", \item{method}{method for calculating correlations} } \description{ -Flexible function to create correlation density plots numeric matrix or data.frame } \references{ diff --git a/modules/assim.batch/man/pda.create.btprior.Rd b/modules/assim.batch/man/pda.create.btprior.Rd index 141abd81401..d6e4dba940b 100644 --- a/modules/assim.batch/man/pda.create.btprior.Rd +++ b/modules/assim.batch/man/pda.create.btprior.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pda.utils.R +% Please edit documentation in R/pda.bayestools.helpers.R \name{pda.create.btprior} \alias{pda.create.btprior} \title{Create priors for BayesianTools} @@ -7,14 +7,24 @@ pda.create.btprior(prior.sel) } \arguments{ -\item{prior.sel}{prior distributions of the selected parameters} +\item{prior.sel}{`data.frame` containing prior distributions of the selected parameters} } \value{ -out prior class object for BayesianTools package +out Prior class object for BayesianTools package } \description{ Helper function for creating log-priors compatible with BayesianTools package } +\details{ +`prior.sel` must contain the following columns: + * `distn` -- String describing a distribution; e.g. `norm` for `dnorm`, `rnorm`, etc. + * `parama`, `paramb` -- First and second parameters, respectively, of the corresponding distribution + +Optionally, `prior.sel` may also contain the following columns: + * `param_name` -- Parameter name, which will be carried through to the prior object and sampler + * `lower`, `upper` -- Lower and upper bounds, respectively. These can be leveraged by the BayesianTools samplers. + * `best` -- Best guess for a parameter estimate. BayesianTools can also use this, though I'm not sure how... +} \author{ -Istem Fer +Istem Fer, Alexey Shiklomanov } diff --git a/modules/assim.batch/man/pda.settings.bt.Rd b/modules/assim.batch/man/pda.settings.bt.Rd index 361dcbafe59..2e2008913bf 100644 --- a/modules/assim.batch/man/pda.settings.bt.Rd +++ b/modules/assim.batch/man/pda.settings.bt.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pda.utils.R +% Please edit documentation in R/pda.bayestools.helpers.R \name{pda.settings.bt} \alias{pda.settings.bt} \title{Apply settings for BayesianTools} diff --git a/modules/assim.batch/tests/testthat/test.bt_prior.R b/modules/assim.batch/tests/testthat/test.bt_prior.R new file mode 100644 index 00000000000..b892043e0ad --- /dev/null +++ b/modules/assim.batch/tests/testthat/test.bt_prior.R @@ -0,0 +1,37 @@ +library(PEcAn.assim.batch) +library(testthat) +context("BayesianTools prior functions") + +prior_list <- list(list('normal', 'norm', 0.5, 2), + list('lognormal', 'lnorm', 1, 1), + list('gamma', 'gamma', 0.5, 0.5)) +prior_df <- do.call(rbind.data.frame, prior_list) +colnames(prior_df) <- c('param_name', 'distn', 'parama', 'paramb') + +prior <- pda.create.btprior(prior_df) + +x <- c(2, 3, 4) +correct_dens <- with(prior_df, dnorm(x[1], parama[1], paramb[1], log = TRUE) + + dlnorm(x[2], parama[2], paramb[2], log = TRUE) + + dgamma(x[3], parama[3], paramb[3], log = TRUE)) +prior_dens <- prior$density(x) + +test_that('Prior returns correct density', expect_equal(correct_dens, prior_dens)) + +correct_mean <- with(prior_df, c(parama[1], + exp(parama[2] + paramb[2]^2 / 2), + parama[3] / paramb[3])) +correct_var <- with(prior_df, c(paramb[1]^2, + (exp(paramb[2]^2) - 1) * exp(2 * parama[2] + paramb[2]^2), + parama[3] / paramb[3]^2)) +names(correct_mean) <- names(correct_var) <- prior_df[['param_name']] + +nsamp <- 10000 +prior_samples <- vapply(seq_len(nsamp), function(x) prior$sampler(), numeric(3)) +prior_sampmean <- rowMeans(prior_samples) +prior_sampvar <- apply(prior_samples, 1, var) + +test_that('Prior sampler returns reasonable values', { + expect_equal(correct_mean, prior_sampmean, tolerance = 0.1) + expect_equal(correct_var, prior_sampvar, tolerance = 0.25) + }) From 6cec4c03e1639cf7316e6a6efa4c0c907351fea9 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 1 Aug 2017 19:31:19 -0400 Subject: [PATCH 258/771] First pass at BayesianTools inversion --- modules/rtm/.gitignore | 2 + modules/rtm/DESCRIPTION | 7 +- modules/rtm/NAMESPACE | 2 + modules/rtm/R/bayestools.R | 133 ++++++++++++++++++++++++ modules/rtm/R/neff.R | 10 +- modules/rtm/man/bt_check_convergence.Rd | 12 +++ modules/rtm/man/corr_max_lag.Rd | 11 ++ modules/rtm/man/invert_bt.Rd | 11 ++ modules/rtm/man/neff.Rd | 2 +- modules/rtm/man/prospect_bt_prior.Rd | 11 ++ modules/rtm/man/rtm_loglike.Rd | 11 ++ modules/rtm/tests/invert_bt.R | 15 +++ 12 files changed, 220 insertions(+), 7 deletions(-) create mode 100644 modules/rtm/R/bayestools.R create mode 100644 modules/rtm/man/bt_check_convergence.Rd create mode 100644 modules/rtm/man/corr_max_lag.Rd create mode 100644 modules/rtm/man/invert_bt.Rd create mode 100644 modules/rtm/man/prospect_bt_prior.Rd create mode 100644 modules/rtm/man/rtm_loglike.Rd create mode 100644 modules/rtm/tests/invert_bt.R diff --git a/modules/rtm/.gitignore b/modules/rtm/.gitignore index f7f39d3c92a..bb44ce8bfba 100644 --- a/modules/rtm/.gitignore +++ b/modules/rtm/.gitignore @@ -17,3 +17,5 @@ check # R profile output */Rprof.out **/Rprof.out + +**/.scratch.R diff --git a/modules/rtm/DESCRIPTION b/modules/rtm/DESCRIPTION index 38e5fb809a5..908115e955b 100644 --- a/modules/rtm/DESCRIPTION +++ b/modules/rtm/DESCRIPTION @@ -20,11 +20,8 @@ Suggests: PEcAn.utils, PEcAn.ED2, testthat (>= 1.0.2), - knitr -Remotes: - github::pecanproject/pecan/modules/assim.batch, - github::pecanproject/pecan/models/ed, - github::pecanproject/pecan/utils + knitr, + pwr OS_type: unix License: FreeBSD + file LICENSE Copyright: Authors diff --git a/modules/rtm/NAMESPACE b/modules/rtm/NAMESPACE index d6f636c40bb..99e65a0c509 100644 --- a/modules/rtm/NAMESPACE +++ b/modules/rtm/NAMESPACE @@ -17,6 +17,7 @@ export(get.EDR.output) export(invert.auto) export(invert.custom) export(invert.lsq) +export(invert_bt) export(load.from.name) export(lognorm.mu) export(lognorm.sigma) @@ -30,6 +31,7 @@ export(priorfunc.prospect) export(pro2s) export(pro4sail) export(prospect) +export(prospect_bt_prior) export(rtnorm) export(sensor.list) export(sensor.proper) diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R new file mode 100644 index 00000000000..dde102512b2 --- /dev/null +++ b/modules/rtm/R/bayestools.R @@ -0,0 +1,133 @@ +#' Generic log-likelihood generator for RTMs +rtm_loglike <- function(nparams, model, observed, lag.max = 0.01, ...) { + fail_ll <- -1e10 + stopifnot(nparams >= 1, nparams %% 1 == 0, is.function(model), is.numeric(observed)) + n_obs <- length(observed) + out <- function(x) { + rtm_params <- x[seq_len(nparams)] + rsd <- x[nparams + 1] + mod <- model(rtm_params, ...) + if (any(is.na(mod))) return(fail_ll) + err <- mod - observed + ss <- sum(err * err) + sigma2 <- rsd * rsd + n_eff <- neff(err, lag.max = lag.max) + sigma2eff <- sigma2 * n_obs / n_eff + ll <- -0.5 * (n_obs * log(sigma2eff) + ss / sigma2eff) + if (is.na(ll)) return(fail_ll) + return(ll) + } + return(out) +} + +#' Check convergence of BayesianTools output +bt_check_convergence <- function(samples, threshold = 1.1, use_CI = TRUE, use_mpsrf = TRUE) { + i <- ifelse(use_CI, 2, 1) + gelman <- BayesianTools::gelmanDiagnostics(samples) + if (use_mpsrf) { + gelman_vec <- c(gelman$psrf[,i], mpsrf = gelman$mpsrf) + } else { + gelman_vec <- gelman$psrf[,i] + } + exceeds <- gelman_vec > threshold + if (any(exceeds)) { + exceeds_vec <- gelman_vec[exceeds] + exceeds_char <- sprintf('%s: %.2f', names(exceeds_vec), exceeds_vec) + exceeds_str <- paste(exceeds_char, collapse = '; ') + message('The following parameters exceed threshold: ', exceeds_str) + return(FALSE) + } else { + return(TRUE) + } +} + +#' Quick BayesianTools prior creator for PROSPECT model +#' +#' @export +prospect_bt_prior <- function(version, custom_prior = list()) { + col_names <- c('param_name', 'distn', 'parama', 'paramb', 'lower') + prior_default_list <- list(N = list('N', 'norm', 1.4, 0.8, 1), + Cab = list('Cab', 'lnorm', log(40), 0.9, 0), + Car = list('Car', 'lnorm', log(10), 1.1, 0), + Cbrown = list('Cbrown', 'lnorm', log(1), 1.1, 0), + Cw = list('Cw', 'lnorm', log(0.01), 1, 0), + Cm = list('Cm', 'lnorm', log(0.009), 1, 0), + residual = list('residual', 'lnorm', log(0.001), 2.5, 0) + ) + prior_list <- modifyList(prior_default_list, custom_prior) + prior_df_all <- do.call(rbind.data.frame, prior_list) + colnames(prior_df_all) <- col_names + default_params <- defparam(paste0('prospect_', tolower(version))) + use_names <- c(names(default_params), 'residual') + prior_df <- prior_df_all[prior_df_all[['param_name']] %in% use_names,] + prior <- PEcAn.assim.batch::pda.create.btprior(prior_df) + return(prior) +} + +#' Perform Bayesian inversion using BayesianTools package +#' +#' @export +invert_bt <- function(observed, model, prior, custom_settings = list()) { + + default_settings <- list(common = list(), + init = list(iterations = 10000), + loop = list(iterations = 2000), + other = list(sampler = 'DEzs', + use_mpsrf = FALSE, + min_samp = 1000)) + + for (s in seq_along(default_settings)) { + s_name <- names(default_settings)[s] + if (s_name %in% names(custom_settings)) { + settings[[s_name]] <- modifyList(default_settings[[s_name]], + custom_settings[[s_name]]) + } else { + settings[[s_name]] <- default_settings[[s_name]] + } + } + + use_mpsrf <- settings[['other']][['use_mpsrf']] + min_samp <- settings[['other']][['min_samp']] + lag.max <- settings[['other']][['lag.max']] + + stopifnot('prior' %in% class(prior)) + test_samp <- prior$sampler() + param_names <- names(test_samp) + nparams <- length(test_samp[param_names != 'residual']) + loglike <- rtm_loglike(nparams = nparams, + model = model, + observed = observed, + lag.max = lag.max) + + + setup <- createBayesianSetup(likelihood = loglike, + prior = prior, + names = param_names) + + + init_settings <- modifyList(settings[['common']], settings[['init']]) + samples <- BayesianTools::runMCMC(bayesianSetup = setup, + sampler = settings[['other']][['sampler']], + settings = init_settings) + converged <- bt_check_convergence(samples = samples, use_mpsrf = settings[['other']][['use_mpsrf']]) + + loop_settings <- modifyList(settings[['common']], settings[['loop']]) + + while(!(converged && enough_samples)) { + samples <- BayesianTools::runMCMC(samples, sampler = sampler, settings = loop_settings) + converged <- bt_check_convergence(samples = samples, use_mpsrf = settings[['other']][['use_mpsrf']]) + if (converged) { + coda_samples <- BayesianTools::getSample(samples, coda = TRUE) + burned_samples <- PEcAn.assim.batch::autoburnin(coda_samples, return.burnin = TRUE, method = 'gelman.plot') + if (burned_samples$burnin == 1) next + n_samples <- coda::niter(burned_samples$samples) + enough_samples <- n_samples > min_samp + if (!enough_samples) { + message(n_samples, ' samples after burnin is less than target ', min_samp, + '. Resuming sampling.') + } + } + } + return(samples) +} + diff --git a/modules/rtm/R/neff.R b/modules/rtm/R/neff.R index d014cb9a312..4f4202d3f26 100644 --- a/modules/rtm/R/neff.R +++ b/modules/rtm/R/neff.R @@ -3,7 +3,7 @@ #' Calculate effective sample size of vector based on its autocorrelation. #' @param x A vector or time series #' @export -neff <- function(x) { +neff <- function(x, ...) { UseMethod("neff") } @@ -32,3 +32,11 @@ neff.matrix <- function(x, ...) { col_neff <- apply(x, 2, neff.default, ...) return(sum(col_neff)) } + +#' Calculate max ACF lag from correlation power analysis +corr_max_lag <- function(nx, r = 0.1, sig.level = 0.05, power = 0.95, ...) { + testForPackage('pwr') + power_analysis <- pwr::pwr.r.test(n = NULL, r = r, sig.level = sig.level, power = power, ...) + nlag <- ceiling(nx - power_analysis$n) + return(nlag) +} diff --git a/modules/rtm/man/bt_check_convergence.Rd b/modules/rtm/man/bt_check_convergence.Rd new file mode 100644 index 00000000000..8e68a505e6f --- /dev/null +++ b/modules/rtm/man/bt_check_convergence.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bayestools.R +\name{bt_check_convergence} +\alias{bt_check_convergence} +\title{Check convergence of BayesianTools output} +\usage{ +bt_check_convergence(samples, threshold = 1.1, use_CI = TRUE, + use_mpsrf = TRUE) +} +\description{ +Check convergence of BayesianTools output +} diff --git a/modules/rtm/man/corr_max_lag.Rd b/modules/rtm/man/corr_max_lag.Rd new file mode 100644 index 00000000000..17eeec2cd93 --- /dev/null +++ b/modules/rtm/man/corr_max_lag.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/neff.R +\name{corr_max_lag} +\alias{corr_max_lag} +\title{Calculate max ACF lag from correlation power analysis} +\usage{ +corr_max_lag(nx, r = 0.1, sig.level = 0.05, power = 0.95, ...) +} +\description{ +Calculate max ACF lag from correlation power analysis +} diff --git a/modules/rtm/man/invert_bt.Rd b/modules/rtm/man/invert_bt.Rd new file mode 100644 index 00000000000..4a4e9360cdf --- /dev/null +++ b/modules/rtm/man/invert_bt.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bayestools.R +\name{invert_bt} +\alias{invert_bt} +\title{Perform Bayesian inversion using BayesianTools package} +\usage{ +invert_bt(observed, model, prior, custom_settings = list()) +} +\description{ +Perform Bayesian inversion using BayesianTools package +} diff --git a/modules/rtm/man/neff.Rd b/modules/rtm/man/neff.Rd index 98551e18b14..97fa3eed012 100644 --- a/modules/rtm/man/neff.Rd +++ b/modules/rtm/man/neff.Rd @@ -4,7 +4,7 @@ \alias{neff} \title{Effective sample size} \usage{ -neff(x) +neff(x, ...) } \arguments{ \item{x}{A vector or time series} diff --git a/modules/rtm/man/prospect_bt_prior.Rd b/modules/rtm/man/prospect_bt_prior.Rd new file mode 100644 index 00000000000..2d2e2854070 --- /dev/null +++ b/modules/rtm/man/prospect_bt_prior.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bayestools.R +\name{prospect_bt_prior} +\alias{prospect_bt_prior} +\title{Quick BayesianTools prior creator for PROSPECT model} +\usage{ +prospect_bt_prior(version, custom_prior = list()) +} +\description{ +Quick BayesianTools prior creator for PROSPECT model +} diff --git a/modules/rtm/man/rtm_loglike.Rd b/modules/rtm/man/rtm_loglike.Rd new file mode 100644 index 00000000000..2eea76e9edd --- /dev/null +++ b/modules/rtm/man/rtm_loglike.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bayestools.R +\name{rtm_loglike} +\alias{rtm_loglike} +\title{Generic log-likelihood generator for RTMs} +\usage{ +rtm_loglike(nparams, model, observed, lag.max = 0.01, ...) +} +\description{ +Generic log-likelihood generator for RTMs +} diff --git a/modules/rtm/tests/invert_bt.R b/modules/rtm/tests/invert_bt.R new file mode 100644 index 00000000000..92f287bff54 --- /dev/null +++ b/modules/rtm/tests/invert_bt.R @@ -0,0 +1,15 @@ +#devtools::load_all('assim.batch') +#devtools::load_all('rtm') +library(PEcAnRTM) + +#observed <- prospect(defparam('prospect_5'), 5)[,1] + generate.noise() +data(testspec) +observed <- testspec_ACRU[,5] +model <- function(x) prospect(x, 5)[,1] +prior <- PEcAn.assim.batch::prospect_bt_prior(5) +custom_settings <- list() +samples <- invert_bt(observed = observed, model = model, prior = prior, + custom_settings = list()) + +s <- getSample(samples, start = 400, coda = TRUE) +traceplot(s[,2]) From 714638fbcf6a4113facceff11b716c77cc8d03d9 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 2 Aug 2017 16:33:33 -0400 Subject: [PATCH 259/771] Fully functional BayesianTools inversion --- modules/rtm/R/bayestools.R | 29 ++++++++++++------- modules/rtm/R/invert.auto.R | 2 +- modules/rtm/tests/invert_bt.R | 15 ---------- .../tests/testthat/test.invert_bayestools.R | 18 ++++++++++++ 4 files changed, 37 insertions(+), 27 deletions(-) delete mode 100644 modules/rtm/tests/invert_bt.R create mode 100644 modules/rtm/tests/testthat/test.invert_bayestools.R diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R index dde102512b2..732471ae4b7 100644 --- a/modules/rtm/R/bayestools.R +++ b/modules/rtm/R/bayestools.R @@ -76,14 +76,18 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { use_mpsrf = FALSE, min_samp = 1000)) - for (s in seq_along(default_settings)) { - s_name <- names(default_settings)[s] - if (s_name %in% names(custom_settings)) { - settings[[s_name]] <- modifyList(default_settings[[s_name]], - custom_settings[[s_name]]) - } else { - settings[[s_name]] <- default_settings[[s_name]] - } + if (length(custom_settings) > 0) { + for (s in seq_along(default_settings)) { + s_name <- names(default_settings)[s] + if (s_name %in% names(custom_settings)) { + settings[[s_name]] <- modifyList(default_settings[[s_name]], + custom_settings[[s_name]]) + } else { + settings[[s_name]] <- default_settings[[s_name]] + } + } + } else { + settings <- default_settings } use_mpsrf <- settings[['other']][['use_mpsrf']] @@ -100,9 +104,9 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { lag.max = lag.max) - setup <- createBayesianSetup(likelihood = loglike, - prior = prior, - names = param_names) + setup <- BayesianTools::createBayesianSetup(likelihood = loglike, + prior = prior, + names = param_names) init_settings <- modifyList(settings[['common']], settings[['init']]) @@ -113,6 +117,9 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { loop_settings <- modifyList(settings[['common']], settings[['loop']]) + last_iter <- 1 + current_iter <- + while(!(converged && enough_samples)) { samples <- BayesianTools::runMCMC(samples, sampler = sampler, settings = loop_settings) converged <- bt_check_convergence(samples = samples, use_mpsrf = settings[['other']][['use_mpsrf']]) diff --git a/modules/rtm/R/invert.auto.R b/modules/rtm/R/invert.auto.R index b930e76279c..fc93488bd22 100644 --- a/modules/rtm/R/invert.auto.R +++ b/modules/rtm/R/invert.auto.R @@ -309,7 +309,7 @@ process_output <- function(output.list, message("Passed initial convergence check.") } if (calculate.burnin) { - burn <- PEcAn.assim.batch::autoburnin(out$samples, return.burnin = TRUE) + burn <- PEcAn.assim.batch::autoburnin(out$samples, return.burnin = TRUE, method = 'gelman.plot') out$burnin <- burn$burnin if (out$burnin == 1) { message("Robust convergence check in autoburnin failed. ", diff --git a/modules/rtm/tests/invert_bt.R b/modules/rtm/tests/invert_bt.R deleted file mode 100644 index 92f287bff54..00000000000 --- a/modules/rtm/tests/invert_bt.R +++ /dev/null @@ -1,15 +0,0 @@ -#devtools::load_all('assim.batch') -#devtools::load_all('rtm') -library(PEcAnRTM) - -#observed <- prospect(defparam('prospect_5'), 5)[,1] + generate.noise() -data(testspec) -observed <- testspec_ACRU[,5] -model <- function(x) prospect(x, 5)[,1] -prior <- PEcAn.assim.batch::prospect_bt_prior(5) -custom_settings <- list() -samples <- invert_bt(observed = observed, model = model, prior = prior, - custom_settings = list()) - -s <- getSample(samples, start = 400, coda = TRUE) -traceplot(s[,2]) diff --git a/modules/rtm/tests/testthat/test.invert_bayestools.R b/modules/rtm/tests/testthat/test.invert_bayestools.R new file mode 100644 index 00000000000..0d449f7b067 --- /dev/null +++ b/modules/rtm/tests/testthat/test.invert_bayestools.R @@ -0,0 +1,18 @@ +#devtools::load_all('.') +library(PEcAnRTM) +library(testthat) +context('Inversion using BayesianTools') + +true_params <- defparam('prospect_5') +model <- function(x) prospect(x, 5)[,1] +observed <- model(true_params) + generate.noise() +prior <- prospect_bt_prior(5) +custom_settings <- list() +samples <- invert_bt(observed = observed, model = model, prior = prior, + custom_settings = list()) + +samples_burned <- PEcAn.assim.batch::autoburnin(BayesianTools::getSample(samples, coda = TRUE), method = 'gelman.plot') +mean_estimates <- do.call(cbind, summary(samples_burned)[c('statistics', 'quantiles')]) + +test_that('Mean estimates are within 10% of true values', + expect_equal(true_params, mean_estimates[seq_along(true_params),'Mean'], tol = 0.1)) From c31ad4eecc05acda83564dc0ab611f78b535a654 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 2 Aug 2017 16:59:52 -0400 Subject: [PATCH 260/771] Cleanup of BayesianTools inversion in PEcAnRTM --- modules/rtm/R/bayestools.R | 30 ++++++++++++++- modules/rtm/man/invert_bt.Rd | 37 ++++++++++++++++++- modules/rtm/man/prospect_bt_prior.Rd | 5 +++ .../tests/testthat/test.invert_bayestools.R | 26 +++++++------ 4 files changed, 85 insertions(+), 13 deletions(-) diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R index 732471ae4b7..005ac6b0545 100644 --- a/modules/rtm/R/bayestools.R +++ b/modules/rtm/R/bayestools.R @@ -42,7 +42,9 @@ bt_check_convergence <- function(samples, threshold = 1.1, use_CI = TRUE, use_mp } #' Quick BayesianTools prior creator for PROSPECT model -#' +#' +#' @param custom_prior List containing `param_name`, `distn`, `parama`, `paramb`, and `lower` +#' @inheritParams prospect #' @export prospect_bt_prior <- function(version, custom_prior = list()) { col_names <- c('param_name', 'distn', 'parama', 'paramb', 'lower') @@ -66,6 +68,32 @@ prospect_bt_prior <- function(version, custom_prior = list()) { #' Perform Bayesian inversion using BayesianTools package #' +#' Use samplers from the BayesianTools package to fit models to data. Like +#' `invert.auto`, this will continue to run until convergence is achieved +#' (based on Gelman diagnostic) _and_ the result has enough samples (as +#' specified by the user; see Details). +#' +#' @details `custom_settings` is a list of lists, containing the following: +#' * `common` -- BayesianTools settings common to both the initial and subsequent samples. +#' * `init` -- BayesianTools settings for just the first round of sampling. +#' This is most common for the initial number of iterations, which is the +#' minimum expected for convergence. +#' * `loop` -- BayesianTools settings for iterations inside the convergence +#' checking `while` loop. This is most commonly for setting a smaller +#' iteration count than in `init`. +#' * `other` -- Miscellaneous (non-BayesianTools) settings, including: +#' - `sampler` -- String describing which sampler to use. Default is `DEzs` +#' - `use_mpsrf` -- Use the multivariate PSRF to check convergence. +#' Default is `FALSE` because it may be an excessively conservative +#' diagnostic. +#' - `min_samp` -- Minimum number of samples after burnin before stopping. +#' +#' See the BayesianTools sampler documentation for what can go in the `BayesianTools` settings lists. +#' @param observed Vector of observations +#' @param model Function called by log-likelihood. Must be `function(params)` +#' and return a vector equal to `length(observed)` or `nrow(observed)`. +#' @param prior BayesianTools prior object. +#' @param custom_settings Nested settings list. See Details. #' @export invert_bt <- function(observed, model, prior, custom_settings = list()) { diff --git a/modules/rtm/man/invert_bt.Rd b/modules/rtm/man/invert_bt.Rd index 4a4e9360cdf..c3faa685c3d 100644 --- a/modules/rtm/man/invert_bt.Rd +++ b/modules/rtm/man/invert_bt.Rd @@ -6,6 +6,41 @@ \usage{ invert_bt(observed, model, prior, custom_settings = list()) } +\arguments{ +\item{observed}{Vector of observations} + +\item{model}{Function called by log-likelihood. Must be \code{function(params)} +and return a vector equal to \code{length(observed)} or \code{nrow(observed)}.} + +\item{prior}{BayesianTools prior object.} + +\item{custom_settings}{Nested settings list. See Details.} +} \description{ -Perform Bayesian inversion using BayesianTools package +Use samplers from the BayesianTools package to fit models to data. Like +\code{invert.auto}, this will continue to run until convergence is achieved +(based on Gelman diagnostic) \emph{and} the result has enough samples (as +specified by the user; see Details). +} +\details{ +\code{custom_settings} is a list of lists, containing the following: +\itemize{ +\item \code{common} -- BayesianTools settings common to both the initial and subsequent samples. +\item \code{init} -- BayesianTools settings for just the first round of sampling. +This is most common for the initial number of iterations, which is the +minimum expected for convergence. +\item \code{loop} -- BayesianTools settings for iterations inside the convergence +checking \code{while} loop. This is most commonly for setting a smaller +iteration count than in \code{init}. +\item \code{other} -- Miscellaneous (non-BayesianTools) settings, including: +\itemize{ +\item \code{sampler} -- String describing which sampler to use. Default is \code{DEzs} +\item \code{use_mpsrf} -- Use the multivariate PSRF to check convergence. +Default is \code{FALSE} because it may be an excessively conservative +diagnostic. +\item \code{min_samp} -- Minimum number of samples after burnin before stopping. +} +} + +See the BayesianTools sampler documentation for what can go in the \code{BayesianTools} settings lists. } diff --git a/modules/rtm/man/prospect_bt_prior.Rd b/modules/rtm/man/prospect_bt_prior.Rd index 2d2e2854070..d27bb26a54b 100644 --- a/modules/rtm/man/prospect_bt_prior.Rd +++ b/modules/rtm/man/prospect_bt_prior.Rd @@ -6,6 +6,11 @@ \usage{ prospect_bt_prior(version, custom_prior = list()) } +\arguments{ +\item{version}{PROSPECT version: 4, 5, or '5B'} + +\item{custom_prior}{List containing \code{param_name}, \code{distn}, \code{parama}, \code{paramb}, and \code{lower}} +} \description{ Quick BayesianTools prior creator for PROSPECT model } diff --git a/modules/rtm/tests/testthat/test.invert_bayestools.R b/modules/rtm/tests/testthat/test.invert_bayestools.R index 0d449f7b067..384831efeb7 100644 --- a/modules/rtm/tests/testthat/test.invert_bayestools.R +++ b/modules/rtm/tests/testthat/test.invert_bayestools.R @@ -3,16 +3,20 @@ library(PEcAnRTM) library(testthat) context('Inversion using BayesianTools') -true_params <- defparam('prospect_5') -model <- function(x) prospect(x, 5)[,1] -observed <- model(true_params) + generate.noise() -prior <- prospect_bt_prior(5) -custom_settings <- list() -samples <- invert_bt(observed = observed, model = model, prior = prior, - custom_settings = list()) +if (Sys.getenv('CI') == 'true') { + message('Skipping inversion tests on CI system') +} else { + true_params <- defparam('prospect_5') + model <- function(x) prospect(x, 5)[,1] + observed <- model(true_params) + generate.noise() + prior <- prospect_bt_prior(5) + custom_settings <- list() + samples <- invert_bt(observed = observed, model = model, prior = prior, + custom_settings = list()) -samples_burned <- PEcAn.assim.batch::autoburnin(BayesianTools::getSample(samples, coda = TRUE), method = 'gelman.plot') -mean_estimates <- do.call(cbind, summary(samples_burned)[c('statistics', 'quantiles')]) + samples_burned <- PEcAn.assim.batch::autoburnin(BayesianTools::getSample(samples, coda = TRUE), method = 'gelman.plot') + mean_estimates <- do.call(cbind, summary(samples_burned)[c('statistics', 'quantiles')]) -test_that('Mean estimates are within 10% of true values', - expect_equal(true_params, mean_estimates[seq_along(true_params),'Mean'], tol = 0.1)) + test_that('Mean estimates are within 10% of true values', + expect_equal(true_params, mean_estimates[seq_along(true_params),'Mean'], tol = 0.1)) +} From f25f1e4e868416a66b27469b742de780d1f953d6 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Thu, 3 Aug 2017 03:13:04 -0500 Subject: [PATCH 261/771] Cleaning code in ui.R, Stashing file upload in helper, subset input ids in server.R --- shiny/workflowPlot/helper.R | 2 ++ shiny/workflowPlot/server.R | 2 +- shiny/workflowPlot/ui.R | 8 -------- 3 files changed, 3 insertions(+), 9 deletions(-) diff --git a/shiny/workflowPlot/helper.R b/shiny/workflowPlot/helper.R index c4f2c9d28c4..8e250d2267d 100644 --- a/shiny/workflowPlot/helper.R +++ b/shiny/workflowPlot/helper.R @@ -29,6 +29,8 @@ checkAndDownload(c('plotly','scales','dplyr')) # 'Double Quote'='"', # 'Single Quote'="'"), # ''), +# textInput("inputRecordID", "Input Record ID for file", "1000011260"), +# textInput("formatID", "Format ID for file (Default CSV)", "5000000002"), # actionButton("load_data", "Load External Data") # server.R # loadExternalData <-eventReactive(input$load_data,{ diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 4d3845585b2..40318819723 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -144,7 +144,7 @@ server <- shinyServer(function(input, output, session) { my_machine_id <- tbl(bety, 'machines') %>% filter(hostname == my_hostname) %>% pull(id) inputs_df <- tbl(bety, 'dbfiles') %>% filter(container_type == 'Input', machine_id == my_machine_id) %>% - left_join(tbl(bety, 'inputs') %>% filter(site_id %in% site_Id), by = c('container_id' = 'id')) %>% + inner_join(tbl(bety, 'inputs') %>% filter(site_id %in% site_Id), by = c('container_id' = 'id')) %>% collect() inputs_df <- inputs_df[order(inputs_df$container_id),] input_selection_list <- paste(inputs_df$container_id, inputs_df$name) diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index d9ae275a96b..9e7874f1bb3 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -7,7 +7,6 @@ ui <- shinyUI(fluidPage( titlePanel("Workflow Plots"), sidebarLayout( sidebarPanel( - # helpText(), p("Please select the workflow IDs to continue. You can select multiple IDs"), selectizeInput("all_workflow_id", "Mutliple Workflow IDs", c(),multiple=TRUE), p("Please select the run IDs. You can select multiple IDs"), @@ -25,13 +24,6 @@ ui <- shinyUI(fluidPage( tags$hr(), selectizeInput("all_site_id", "Select Site ID", c()), selectizeInput("all_input_id", "Select Input ID", c()), - # fileInput('fileUploaded', 'Choose file to upload data' - # # accept=c('text/csv', - # # 'text/comma-separated-values,text/plain', - # # '.csv') - # ), - # textInput("inputRecordID", "Input Record ID for file", "1000011260"), - # textInput("formatID", "Format ID for file (Default CSV)", "5000000002"), radioButtons("data_geom", "Plot Type (for loaded data)", c("Scatter Plot" = "point", "Line Chart" = "line"), From 33004d1c908a974523f843576d4ef9e879590d70 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 3 Aug 2017 10:18:00 -0400 Subject: [PATCH 262/771] Change align_pools to prepare_pools --- models/dalec/R/write.configs.dalec.R | 2 +- models/sipnet/R/write.configs.SIPNET.R | 2 +- modules/data.land/NAMESPACE | 1 - modules/data.land/R/align_pools.R | 16 ++++++++-------- 4 files changed, 10 insertions(+), 11 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 3d49cb3c4a8..d4a667b4438 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -121,7 +121,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { sla <- default.param[which(default.param$cmdFlag == "SLA"),"val"] * 1000 #convert SLA to m2/kgC from m2/gC (dalec default) } - IC.pools <- PEcAn.data.land::align_pools(IC.path, constants = list(sla = sla)) + IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = sla)) if(!is.null(IC.pools)){ ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) diff --git a/models/sipnet/R/write.configs.SIPNET.R b/models/sipnet/R/write.configs.SIPNET.R index 1f00a22248c..7b7a6c98228 100644 --- a/models/sipnet/R/write.configs.SIPNET.R +++ b/models/sipnet/R/write.configs.SIPNET.R @@ -361,7 +361,7 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs } else if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path - IC.pools <- PEcAn.data.land::align_pools(IC.path, constants = list(sla = SLA)) + IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = SLA)) if(!is.null(IC.pools)){ IC.nc <- ncdf4::nc_open(IC.path) #for additional variables specific to SIPNET diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index 084242db832..48d5c6a8761 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -4,7 +4,6 @@ export(Clean_Tucson) export(InventoryGrowthFusion) export(InventoryGrowthFusionDiagnostics) export(Read_Tucson) -export(align_pools) export(buildJAGSdata_InventoryRings) export(download_package_rm) export(extract.stringCode) diff --git a/modules/data.land/R/align_pools.R b/modules/data.land/R/align_pools.R index 880f2653384..7fcc79fc3cf 100644 --- a/modules/data.land/R/align_pools.R +++ b/modules/data.land/R/align_pools.R @@ -1,5 +1,5 @@ -##' @name align_pools -##' @title align_pools +##' @name prepare_pools +##' @title prepare_pools ##' @description Calculates pools from given initial condition values, deriving complements where necessary/possible if given TotLivBiomass ##' @export ##' @@ -7,7 +7,7 @@ ##' @param constants list of constants; must include SLA in m2 / kg C if providing LAI for leaf carbon ##' @return list of pool values in kg C / m2 with generic names ##' @author Anne Thomas -align_pools <- function(nc.path, constants = NULL){ +prepare_pools <- function(nc.path, constants = NULL){ #function to check that var was loaded (numeric) and has a valid value (not NA or negative) is.valid <- function(var){ return(all(is.numeric(var) && !is.na(var) && var >= 0)) @@ -37,17 +37,17 @@ align_pools <- function(nc.path, constants = NULL){ # note: if roots are partitionable, they will override fine_ and/or coarse_root_carbon_content if loaded if(is.valid(roots)){ if("rtsize" %in% names(IC.list$dims)){ - PEcAn.utils::logger.info("align_pools: Attempting to partition root_carbon_content") + PEcAn.utils::logger.info("prepare_pools: Attempting to partition root_carbon_content") rtsize <- IC.list$dims$rtsize part_roots <- PEcAn.data.land::partition_roots(roots, rtsize) if(!is.null(part_roots)){ fine.roots <- part_roots$fine.roots coarse.roots <- part_roots$coarse.roots } else{ - PEcAn.utils::logger.error("align_pools: could not partition roots; please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + PEcAn.utils::logger.error("prepare_pools: could not partition roots; please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") } } else{ - PEcAn.utils::logger.error("align_pools: Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + PEcAn.utils::logger.error("prepare_pools: Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") } } else{ # proceed without error message @@ -83,7 +83,7 @@ align_pools <- function(nc.path, constants = NULL){ if(is.valid(coarse.roots)){ IC.params[["wood"]] <- (AbvGrndWood + coarse.roots) } else{ - PEcAn.utils::logger.error("align_pools can't calculate total woody biomass with only AbvGrndWood; checking for total biomass.") + PEcAn.utils::logger.error("prepare_pools can't calculate total woody biomass with only AbvGrndWood; checking for total biomass.") } } else if (is.valid(TotLivBiom) && is.valid(leaf) && is.valid(fine.roots)){ wood <- (TotLivBiom - leaf - fine.roots) @@ -93,7 +93,7 @@ align_pools <- function(nc.path, constants = NULL){ PEcAn.utils::logger.error(paste("TotLivBiom (", TotLivBiom, ") is less than sum of leaf (", leaf, ") and fine roots(",fine.roots,"); will use default for woody biomass.")) } } else{ - PEcAn.utils::logger.error("align_pools could not calculate woody biomass; will use defaults. Please provide AbvGrndWood and coarse_root_carbon OR leaf_carbon_content/LAI, fine_root_carbon_content, and TotLivBiom in netcdf.") + PEcAn.utils::logger.error("prepare_pools could not calculate woody biomass; will use defaults. Please provide AbvGrndWood and coarse_root_carbon OR leaf_carbon_content/LAI, fine_root_carbon_content, and TotLivBiom in netcdf.") } # initial pool of fine root carbon (kgC/m2) From ef3d40a8f27eef826e0385af5ccf8f202941b7fe Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 3 Aug 2017 10:41:21 -0400 Subject: [PATCH 263/771] Update documentation --- modules/data.land/NAMESPACE | 1 + .../data.land/man/{align_pools.Rd => prepare_pools.Rd} | 8 ++++---- 2 files changed, 5 insertions(+), 4 deletions(-) rename modules/data.land/man/{align_pools.Rd => prepare_pools.Rd} (88%) diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index 48d5c6a8761..bfa07bff22a 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -30,6 +30,7 @@ export(partition_roots) export(plot2AGB) export(pool_ic_list2netcdf) export(pool_ic_netcdf2list) +export(prepare_pools) export(sclass) export(shp2kml) export(soil.units) diff --git a/modules/data.land/man/align_pools.Rd b/modules/data.land/man/prepare_pools.Rd similarity index 88% rename from modules/data.land/man/align_pools.Rd rename to modules/data.land/man/prepare_pools.Rd index 09d36e553db..0abd1f7051f 100644 --- a/modules/data.land/man/align_pools.Rd +++ b/modules/data.land/man/prepare_pools.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/align_pools.R -\name{align_pools} -\alias{align_pools} -\title{align_pools} +\name{prepare_pools} +\alias{prepare_pools} +\title{prepare_pools} \usage{ -align_pools(nc.path, constants = NULL) +prepare_pools(nc.path, constants = NULL) } \arguments{ \item{nc.path}{path to netcdf file containing standard dimensions and variables; currently supports these variables: TotLivBiom, leaf_carbon_content, LAI, AbvGrndWood, root_carbon_content, fine_root_carbon_content, coarse_root_carbon_content, litter_carbon_content, soil_organic_carbon_content, soil_carbon_content, wood_debris_carbon_content} From 90a6ec241da47e18361c58101b9d010bd0a3bb14 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 3 Aug 2017 10:42:43 -0400 Subject: [PATCH 264/771] Rename prepare_pools file --- modules/data.land/R/{align_pools.R => prepare_pools.R} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename modules/data.land/R/{align_pools.R => prepare_pools.R} (100%) diff --git a/modules/data.land/R/align_pools.R b/modules/data.land/R/prepare_pools.R similarity index 100% rename from modules/data.land/R/align_pools.R rename to modules/data.land/R/prepare_pools.R From 9b0bda123e11fa58e165cd7d22dd57f3ab1ba88f Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 3 Aug 2017 11:29:05 -0400 Subject: [PATCH 265/771] update prepare_pools.Rd --- modules/data.land/man/prepare_pools.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/man/prepare_pools.Rd b/modules/data.land/man/prepare_pools.Rd index 0abd1f7051f..3fbdf7c0ac1 100644 --- a/modules/data.land/man/prepare_pools.Rd +++ b/modules/data.land/man/prepare_pools.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/align_pools.R +% Please edit documentation in R/prepare_pools.R \name{prepare_pools} \alias{prepare_pools} \title{prepare_pools} From 453a9c495c84e41572e1859cb3cd8dcc1033937b Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 3 Aug 2017 12:05:00 -0400 Subject: [PATCH 266/771] Whitespace --- modules/data.land/R/prepare_pools.R | 1 - 1 file changed, 1 deletion(-) diff --git a/modules/data.land/R/prepare_pools.R b/modules/data.land/R/prepare_pools.R index 7fcc79fc3cf..c6cec6d8efe 100644 --- a/modules/data.land/R/prepare_pools.R +++ b/modules/data.land/R/prepare_pools.R @@ -27,7 +27,6 @@ prepare_pools <- function(nc.path, constants = NULL){ fine.roots <- IC.list$vals$fine_root_carbon_content coarse.roots <- IC.list$vals$coarse_root_carbon_content - ### load non-living variables litter <- IC.list$vals$litter_carbon_content soil <- IC.list$vals$soil_organic_carbon_content From 5c749aa71ad34f636a9e7d3ae3fdeb075568e759 Mon Sep 17 00:00:00 2001 From: annethomas Date: Fri, 4 Aug 2017 13:55:50 -0400 Subject: [PATCH 267/771] Fix broken error message in jagify --- modules/meta.analysis/R/jagify.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/modules/meta.analysis/R/jagify.R b/modules/meta.analysis/R/jagify.R index 87d5f83b236..f4fabdf47c9 100644 --- a/modules/meta.analysis/R/jagify.R +++ b/modules/meta.analysis/R/jagify.R @@ -36,9 +36,11 @@ jagify <- function(result) { select = c("stat", "n", "site_id", "trt_id", "mean", "citation_id", "greenhouse")) if (length(r$stat[!is.na(r$stat) & r$stat <= 0]) > 0) { + varswithbadstats <- unique(result$vname[which(r$stat <= 0)]) citationswithbadstats <- unique(r$citation_id[which(r$stat <= 0)]) + logger.warn("there are implausible values of SE: SE <= 0 \n", - "for", names(result)[i], + "for", varswithbadstats, "result from citation", citationswithbadstats, "\n", "SE <=0 set to NA \n") r$stat[r$stat <= 0] <- NA From 305faee4cd14e2f32dbda8a516875493f494dffa Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Sat, 5 Aug 2017 09:06:04 -0500 Subject: [PATCH 268/771] Working flow for subsetting input id based on VM --- shiny/workflowPlot/helper.R | 2 ++ shiny/workflowPlot/server.R | 68 +++++++++++++++++++++++++------------ shiny/workflowPlot/ui.R | 3 ++ 3 files changed, 51 insertions(+), 22 deletions(-) diff --git a/shiny/workflowPlot/helper.R b/shiny/workflowPlot/helper.R index 8e250d2267d..e38adbbd812 100644 --- a/shiny/workflowPlot/helper.R +++ b/shiny/workflowPlot/helper.R @@ -10,6 +10,8 @@ isInstalled <- function(mypkg){ is.element(mypkg, installed.packages()[,1]) } checkAndDownload(c('plotly','scales','dplyr')) +# write.csv(inputs_df,file='/home/carya/pecan/shiny/workflowPlot/inputs_df.csv', +# quote = FALSE,sep = ',',col.names = TRUE,row.names=FALSE) # Stashing Code for file upload to shiny app # Based on https://shiny.rstudio.com/gallery/file-upload.html # ui.R diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 40318819723..e73164c9cfd 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -2,11 +2,12 @@ library(PEcAn.visualization) library(PEcAn.DB) library(PEcAn.settings) library(PEcAn.benchmark) +library(PEcAn.utils) library(shiny) library(ncdf4) library(ggplot2) # Helper allows to load functions and variables that could be shared both by server.R and ui.R -source('helper.R') +# source('helper.R') library(plotly) library(scales) library(lubridate) @@ -99,10 +100,18 @@ server <- shinyServer(function(input, output, session) { # Allows to load actual data (different from model output) following the tutorial # https://github.com/PecanProject/pecan/blob/develop/documentation/tutorials/AnalyzeOutput/modelVSdata.Rmd # @params: bety,settings,File_path,File_format - loadObservationData <- function(bety,settings,File_path,File_format){ - start.year<-as.numeric(lubridate::year(settings$run$start.date)) - end.year<-as.numeric(lubridate::year(settings$run$end.date)) - site.id<-settings$run$site$id + # loadObservationData <- function(bety,settings,File_path,File_format){ + loadObservationData <- function(bety,inputs_df){ + input_id <- inputs_df$input_id + File_format <- getFileFormat(bety,input_id) + # start.year<-as.numeric(lubridate::year(settings$run$start.date)) + # end.year<-as.numeric(lubridate::year(settings$run$end.date)) + # site.id<-settings$run$site$id + # site<-PEcAn.DB::query.site(site.id,bety$con) + start.year <- as.numeric(lubridate::year(inputs_df$start_date)) + end.year <- as.numeric(lubridate::year(inputs_df$end_date)) + File_path <- paste0(inputs_df$filePath,'.csv') + site.id <- inputs_df$site_id site<-PEcAn.DB::query.site(site.id,bety$con) observations<-PEcAn.benchmark::load_data(data.path = File_path, format= File_format, time.row = File_format$time.row, site = site, start_year = start.year, end_year = end.year) return(observations) @@ -147,12 +156,18 @@ server <- shinyServer(function(input, output, session) { inner_join(tbl(bety, 'inputs') %>% filter(site_id %in% site_Id), by = c('container_id' = 'id')) %>% collect() inputs_df <- inputs_df[order(inputs_df$container_id),] - input_selection_list <- paste(inputs_df$container_id, inputs_df$name) - return(input_selection_list) + inputs_df <- inputs_df %>% + mutate(input_selection_list = paste(inputs_df$container_id, inputs_df$name), + filePath = paste0(inputs_df$file_path,'/', inputs_df$file_name)) %>% + dplyr::select(container_id,filePath,input_selection_list,start_date,end_date,site_id,name, + machine_id,file_name,file_path) + colnames(inputs_df)[1] <- 'input_id' + return(inputs_df) } observe({ req(input$all_site_id) - updateSelectizeInput(session, "all_input_id", choices=getInputs(bety,input$all_site_id)) + inputs_df <- getInputs(bety,c(input$all_site_id)) + updateSelectizeInput(session, "all_input_id", choices=inputs_df$input_selection_list) }) # Renders ggplotly @@ -166,14 +181,14 @@ server <- shinyServer(function(input, output, session) { # Load data masterDF <- loadNewData() # masterDF <- rbind(modelData,externalData) - # Convert from factor to character. For subsetting + # Convert from factor to character. For subsetting masterDF$var_name <- as.character(masterDF$var_name) - # Convert to factor. Required for ggplot + # Convert to factor. Required for ggplot masterDF$run_id <- as.factor(as.character(masterDF$run_id)) # Filter by variable name df <- masterDF %>% dplyr::filter(var_name == input$variable_name) - # make dynamic slider + # make dynamic slider # https://stackoverflow.com/questions/18700589/interactive-reactive-change-of-min-max-values-of-sliderinput # output$slider <- renderUI({ # sliderInput("smooth_n", "Value for smoothing:", min=0, max=nrow(df), value=80) @@ -184,7 +199,7 @@ server <- shinyServer(function(input, output, session) { xlab <- unique(df$xlab) ylab <- unique(df$ylab) # ggplot function for now scatter plots. - plt <- ggplot(df, aes(x=dates, y=vals, color=run_id)) + plt <- ggplot(df, aes(x=dates, y=vals, color=run_id)) # Toggle chart type using switch switch(input$plotType, "scatterPlot" = { @@ -197,21 +212,30 @@ server <- shinyServer(function(input, output, session) { plt <- plt + labs(title=title, x=xlab, y=ylab) + geom_smooth(n=input$smooth_n) # Check if user wants to load external data # Similar to using event reactive - if (input$load_data>0) { + if (input$load_data>0) { # Retaining the code for getting file format using inputRecordID # File_format <- getFileFormat(bety,input$formatID) # Input ID is of the form (ID Name). Split by space and use the first element - input_ID <- strsplit(input$all_input_id,' ')[[1]][1] - File_format <- getFileFormat(bety,input_ID) - ids_DF <- parse_ids_from_input_runID(input$all_run_id) - settings <- getSettingsFromWorkflowId(bety,ids_DF$wID[1]) - filePath <- PEcAn.DB::dbfile.file(type = 'Input', id = input_ID,con = bety$con) - externalData <- loadObservationData(bety,settings,filePath,File_format) - # If variable found in the uploaded file + inputs_df <- getInputs(bety,c(input$all_site_id)) + # output$info <- renderText({ + # paste0(nrow(inputs_df)) + # }) + inputs_df <- inputs_df %>% filter(input_selection_list == input$all_input_id) + # output$info1 <- renderText({ + # paste0(nrow(inputs_df)) + # }) + # input_id <- strsplit(input$all_input_id,' ')[[1]][1] + # File_format <- getFileFormat(bety,input_id) + # ids_DF <- parse_ids_from_input_runID(input$all_run_id) + # settings <- getSettingsFromWorkflowId(bety,ids_DF$wID[1]) + # filePath <- PEcAn.DB::dbfile.file(type = 'Input', id = input_ID,con = bety$con) + # externalData <- loadObservationData(bety,settings,filePath,File_format) + externalData <- loadObservationData(bety,inputs_df) + # If variable found in the uploaded file if (input$variable_name %in% names(externalData)){ externalData <- externalData %>% dplyr::select(posix,dplyr::one_of(input$variable_name)) names(externalData) <- c("dates","vals") - externalData$dates <- as.Date(externalData$dates) + externalData$dates <- as.Date(externalData$dates) data_geom <- switch(input$data_geom, point = geom_point, line = geom_line) plt <- plt + data_geom(data = externalData,aes(x=dates, y=vals),color='black', linetype = 'dashed') output$outputNoVariableFound <- renderText({ @@ -230,7 +254,7 @@ server <- shinyServer(function(input, output, session) { # scale_y_continuous(labels=fancy_scientific) + # Earlier color and fill values # scale_color_manual(name = "", values = "black") + - # scale_fill_manual(name = "", values = "grey50") + # scale_fill_manual(name = "", values = "grey50") plt<-ggplotly(plt) # Not able to add icon over ggplotly # add_icon() diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 9e7874f1bb3..d9ced7ecf6d 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -23,6 +23,7 @@ ui <- shinyUI(fluidPage( tags$hr(), tags$hr(), selectizeInput("all_site_id", "Select Site ID", c()), + # selectizeInput("all_site_id", "Select Site ID", c(), multiple=TRUE), selectizeInput("all_input_id", "Select Input ID", c()), radioButtons("data_geom", "Plot Type (for loaded data)", c("Scatter Plot" = "point", @@ -33,6 +34,8 @@ ui <- shinyUI(fluidPage( mainPanel( plotlyOutput("outputPlot"), verbatimTextOutput("outputNoVariableFound") + # ,verbatimTextOutput("info") + # ,verbatimTextOutput("info1") ) ) )) From 762b09be06be48aeb9dc993aafdf8d6db744a583 Mon Sep 17 00:00:00 2001 From: Betsy Cowdery Date: Sun, 6 Aug 2017 15:27:37 -0400 Subject: [PATCH 269/771] Adding LAI output to DALEC --- models/dalec/R/model2netcdf.DALEC.R | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/models/dalec/R/model2netcdf.DALEC.R b/models/dalec/R/model2netcdf.DALEC.R index a740aae413d..b76507a4d6e 100644 --- a/models/dalec/R/model2netcdf.DALEC.R +++ b/models/dalec/R/model2netcdf.DALEC.R @@ -23,6 +23,11 @@ ##' @export ##' @author Shawn Serbin, Michael Dietze model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { + + runid <- basename(outdir) + DALEC.configs <- read.table(file.path(gsub(pattern = "/out/", + replacement = "/run/", x = outdir), + paste0("CONFIG.",runid)), stringsAsFactors = FALSE) ### Read in model output in DALEC format DALEC.output <- read.table(file.path(outdir, "out.txt"), header = FALSE, sep = "") @@ -70,6 +75,8 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { output[[14]] <- output[[1]] + output[[2]] # Total Respiration output[[15]] <- output[[9]] + output[[10]] + output[[11]] ## TotLivBiom output[[16]] <- output[[12]] + output[[13]] ## TotSoilCarb + nc_var[[17]] <- to_ncvar("LAI", dims) + # ******************** Declare netCDF variables ********************# t <- ncdim_def(name = "time", units = paste0("days since ", y, "-01-01 00:00:00"), @@ -105,6 +112,8 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { nc_var[[14]] <- to_ncvar("TotalResp", dims) nc_var[[15]] <- to_ncvar("TotLivBiom", dims) nc_var[[16]] <- to_ncvar("TotSoilCarb", dims) + output[[17]] <- output[[9]] * DALEC.configs[grep("SLA", DALEC.configs) + 1][[1]] ## LAI + # ******************** Declar netCDF variables ********************# From 88d11f5a72565f5dd7667cd71841ebc3a15a470f Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Sun, 6 Aug 2017 17:35:47 -0400 Subject: [PATCH 270/771] Some modifications from Margaret Evans --- .../R/InventoryGrowthFusionDiagnostics.R | 56 ++++++++++--------- 1 file changed, 29 insertions(+), 27 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusionDiagnostics.R b/modules/data.land/R/InventoryGrowthFusionDiagnostics.R index 9f453808e69..28ed80c4b2b 100644 --- a/modules/data.land/R/InventoryGrowthFusionDiagnostics.R +++ b/modules/data.land/R/InventoryGrowthFusionDiagnostics.R @@ -4,38 +4,40 @@ ##' @param combined data output from matchInventoryRings ##' @author Michael Dietze ##' @export -InventoryGrowthFusionDiagnostics <- function(jags.out, combined) { +InventoryGrowthFusionDiagnostics <- function(jags.out, combined=NULL) { - ### DBH par(mfrow=c(3,2)) - layout(matrix(1:8, 4, 2, byrow = TRUE)) out <- as.matrix(jags.out) x.cols <- which(substr(colnames(out), 1, 1) == "x") - ci <- apply(out[, x.cols], 2, quantile, c(0.025, 0.5, 0.975)) - ci.names <- parse.MatrixNames(colnames(ci), numeric = TRUE) - smp <- sample.int(data$ni, min(8, data$ni)) - for (i in smp) { - sel <- which(ci.names$row == i) - rng <- c(range(ci[, sel], na.rm = TRUE), range(data$z[i, ], na.rm = TRUE)) - - plot(data$time, ci[2, sel], type = "n", - ylim = range(rng), ylab = "DBH (cm)", main = i) - PEcAn.visualization::ciEnvelope(data$time, ci[1, sel], ci[3, sel], col = "lightBlue") - points(data$time, data$z[i, ], pch = "+", cex = 1.5) - # lines(data$time,z0[i,],lty=2) - - ## growth - sel <- which(ci.names$row == i) - inc.mcmc <- apply(out[, x.cols[sel]], 1, diff) - inc.ci <- apply(inc.mcmc, 1, quantile, c(0.025, 0.5, 0.975)) * 5 - # inc.names = parse.MatrixNames(colnames(ci),numeric=TRUE) + ### DBH par(mfrow=c(3,2)) + if(length(x.cols) > 0){ + layout(matrix(1:8, 4, 2, byrow = TRUE)) + ci <- apply(out[, x.cols], 2, quantile, c(0.025, 0.5, 0.975)) + ci.names <- parse.MatrixNames(colnames(ci), numeric = TRUE) - plot(data$time[-1], inc.ci[2, ], type = "n", - ylim = range(inc.ci, na.rm = TRUE), ylab = "Ring Increment (mm)") - PEcAn.visualization::ciEnvelope(data$time[-1], inc.ci[1, ], inc.ci[3, ], col = "lightBlue") - points(data$time, data$y[i, ] * 5, pch = "+", cex = 1.5, type = "b", lty = 2) + smp <- sample.int(data$ni, min(8, data$ni)) + for (i in smp) { + sel <- which(ci.names$row == i) + rng <- c(range(ci[, sel], na.rm = TRUE), range(data$z[i, ], na.rm = TRUE)) + + plot(data$time, ci[2, sel], type = "n", + ylim = range(rng), ylab = "DBH (cm)", main = i) + PEcAn.visualization::ciEnvelope(data$time, ci[1, sel], ci[3, sel], col = "lightBlue") + points(data$time, data$z[i, ], pch = "+", cex = 1.5) + # lines(data$time,z0[i,],lty=2) + + ## growth + sel <- which(ci.names$row == i) + inc.mcmc <- apply(out[, x.cols[sel]], 1, diff) + inc.ci <- apply(inc.mcmc, 1, quantile, c(0.025, 0.5, 0.975)) * 5 + # inc.names = parse.MatrixNames(colnames(ci),numeric=TRUE) + + plot(data$time[-1], inc.ci[2, ], type = "n", + ylim = range(inc.ci, na.rm = TRUE), ylab = "Ring Increment (mm)") + PEcAn.visualization::ciEnvelope(data$time[-1], inc.ci[1, ], inc.ci[3, ], col = "lightBlue") + points(data$time, data$y[i, ] * 5, pch = "+", cex = 1.5, type = "b", lty = 2) + } } - if (FALSE) { ## check a DBH plot(out[, which(colnames(out) == "x[3,31]")]) @@ -111,7 +113,7 @@ InventoryGrowthFusionDiagnostics <- function(jags.out, combined) { ### INDIV ind.cols <- which(substr(colnames(out), 1, 3) == "ind") - if (length(ind.cols) > 0) { + if (length(ind.cols) > 0 & !is.null(combined)) { boxplot(out[, ind.cols], horizontal = TRUE, outline = FALSE, col = as.factor(combined$PLOT)) abline(v = 0, lty = 2) tapply(apply(out[, ind.cols], 2, mean), combined$PLOT, mean) From 8abe75e01b42cd80b35814a9c3bd1f25a7f53633 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Sun, 6 Aug 2017 17:37:36 -0400 Subject: [PATCH 271/771] Keep Travis at Precise until we can get the upgrade to Trusty Ubuntu working --- .travis.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.travis.yml b/.travis.yml index af0676525a7..8a922782349 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,6 +4,7 @@ language: r # use containers +dist: precise sudo: false cache: From c2450d01bf50c4524944ea27db24fcd06301c7c2 Mon Sep 17 00:00:00 2001 From: Betsy Cowdery Date: Sun, 6 Aug 2017 15:27:37 -0400 Subject: [PATCH 272/771] Adding LAI output to DALEC --- models/dalec/R/model2netcdf.DALEC.R | 30 +++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/models/dalec/R/model2netcdf.DALEC.R b/models/dalec/R/model2netcdf.DALEC.R index a740aae413d..e9a21bc49dc 100644 --- a/models/dalec/R/model2netcdf.DALEC.R +++ b/models/dalec/R/model2netcdf.DALEC.R @@ -23,6 +23,11 @@ ##' @export ##' @author Shawn Serbin, Michael Dietze model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { + + runid <- basename(outdir) + DALEC.configs <- read.table(file.path(gsub(pattern = "/out/", + replacement = "/run/", x = outdir), + paste0("CONFIG.",runid)), stringsAsFactors = FALSE) ### Read in model output in DALEC format DALEC.output <- read.table(file.path(outdir, "out.txt"), header = FALSE, sep = "") @@ -46,6 +51,28 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { sub.DALEC.output <- subset(DALEC.output, year == y) sub.DALEC.output.dims <- dim(sub.DALEC.output) + + ## Output names + # ra (autotrophic respiration, gC/m2/day); + # af (flux of carbon entering foliage, gC/m2/day); + # aw (flux of carbon entering woody material, gC/m2/day); + # ar (flux of carbon entering roots, gC/m2/day); + # lf (flux of carbon leaving foliage as litter, gC/m2/day); + # lw (flux of carbon leaving woody material as debris, gC/m2/day); + # lr (flux of carbon leaving roots as debris, gC/m2/day); + # cf (foliar biomass, gC/m2); + # cw (woody biomass, gC/m2); + # cr (root biomass, gC/m2); + # rh1 (heterotrophic flux from litter, gC/m2/day); + # rh2 (heterotrophic flux from soil and woody debris, gC/m2/day); + # d (decompostion flux from litter to soil pool, gC/m2/day); + # cl (litter biomass, gC/m2); + # cs (soil organic matter, gC/m2); + # gpp (gross primary productivity, gC/m2/day); + # nep (net ecosystem productivity, gC/m2/day); + + # names(sub.DALEC.output) <- c("ra", "af", "aw", "ar", "lf", "lw", "lr", "cf", "cw", "cr", "rh1", "rh2", "d", "cl", "cs", "gpp", "nep") + ## Setup outputs for netCDF file in appropriate units output <- list() ## Fluxes @@ -70,6 +97,8 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { output[[14]] <- output[[1]] + output[[2]] # Total Respiration output[[15]] <- output[[9]] + output[[10]] + output[[11]] ## TotLivBiom output[[16]] <- output[[12]] + output[[13]] ## TotSoilCarb + output[[17]] <- sub.DALEC.output[, 15] * DALEC.configs[grep("SLA", DALEC.configs) + 1][[1]] ## LAI + # ******************** Declare netCDF variables ********************# t <- ncdim_def(name = "time", units = paste0("days since ", y, "-01-01 00:00:00"), @@ -105,6 +134,7 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { nc_var[[14]] <- to_ncvar("TotalResp", dims) nc_var[[15]] <- to_ncvar("TotLivBiom", dims) nc_var[[16]] <- to_ncvar("TotSoilCarb", dims) + nc_var[[17]] <- to_ncvar("LAI", dims) # ******************** Declar netCDF variables ********************# From 013d57d926cd4663ab506c0eb77aa497ede00420 Mon Sep 17 00:00:00 2001 From: Ann Raiho Date: Mon, 7 Aug 2017 17:53:44 -0400 Subject: [PATCH 273/771] Changing the imputation model, so that it doesn't alter non-zero values --- modules/assim.sequential/R/sda.enkf.R | 94 ++++++++++++--------------- 1 file changed, 42 insertions(+), 52 deletions(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index 2b86b65ca6a..5c561723ab1 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -210,6 +210,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { start.model.runs(settings, settings$database$bety$write) save(list = ls(envir = environment(), all.names = TRUE), file = file.path(outdir, "sda.initial.runs.Rdata"), envir = environment()) + ###-------------------------------------------------------------------### ### tests before data assimilation ### @@ -312,20 +313,14 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { }) - tobit2space.model <- nimbleCode({ - - for(n in 1:nens){ - y.censored[n,1:N] ~ dmnorm(muf[1:N],pf[1:N,1:N]) - - for(i in 1:N){ - y.ind[n,i] ~ dinterval(y.censored[n,i], interval[i,1:2]) - } + tobit2space.model <- nimbleCode({ + + y.censored[1:N] ~ dmnorm(muf[1:N], prec = pf[1:N,1:N]) + + for(i in 1:N){ + y.ind[i] ~ dconstraint(y.censored[i] > 0) } - - #Priors - pf[1:N,1:N] ~ dwish(aq[1:N,1:N],bq) - muf[1:N] ~ dmnorm(mu.prior[1:N],cov.prior[1:N,1:N]) - + }) t1 <- 1 @@ -339,7 +334,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ###-------------------------------------------------------------------### ### loop over time ### ###-------------------------------------------------------------------### - for(t in 3:5) {# + for(t in 1:nt) {#seq_len(nt) ###-------------------------------------------------------------------### ### read restart ### @@ -386,16 +381,8 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { R[is.na(R)]<-0 if (length(obs.mean[[t]]) > 1) { - for (s in seq_along(obs.mean[[t]])) { - if (diag(R)[s] == 0) { - # if covariance is 0 then set it to half of the minimum covariance to avoid solve() problems - diag(R)[s] <- min(diag(R)[which(diag(R) != 0)])/2 - } - if (diag(Pf)[s] == 0) { - # if covariance is 0 then set it to half of the minimum covariance to avoid solve() problems - diag(Pf)[s] <- min(diag(Pf)[which(diag(Pf) != 0)])/2 - } - } + diag(R)[which(diag(R)==0)] <- min(diag(R)[which(diag(R) != 0)])/2 + diag(Pf)[which(diag(Pf)==0)] <- min(diag(Pf)[which(diag(Pf) != 0)])/5 } ### TO DO: plotting not going to work because of observation operator i.e. y and x are on different scales @@ -511,50 +498,38 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { } #### These vectors are used to categorize data based on censoring from the interval matrix - x.ind <- matrix(NA, nens, ncol(X)) ; x.censored <- x.ind - for(n in 1:nens){ - x.ind[n,] <- as.numeric(X[n,] > intervalX[,1]) - x.censored[n,] <- as.numeric(ifelse(X[n,] > intervalX[,1], X[n,], 0)) - } + x.ind <- as.numeric(mu.f > intervalX[,1]) + x.censored <- as.numeric(ifelse(mu.f > intervalX[,1], mu.f, 0)) #probably not needed until different data + if(t == 1){ #| length(x.ind[1,]) > mu.f #y.obs = Y.dat[1,] - constants.tobit2space = list(N = ncol(X), nens = nens) - data.tobit2space = list(interval = intervalX, - y.ind = x.ind, - y.censored = x.censored, - aq = diag(ncol(X))*ncol(X), - bq = ncol(X), - mu.prior = colMeans(X), #cheating? basically gives us back means - cov.prior = diag(ncol(X))) - - inits.tobit2space = list(pf = diag(ncol(X)), muf = rep(0,ncol(X))) # + constants.tobit2space = list(N = length(mu.f), + muf = mu.f, + pf = Pf) + data.tobit2space = list(y.ind = x.ind, + y.censored = x.censored) #set.seed(0) #ptm <- proc.time() tobit2space_pred <- nimbleModel(tobit2space.model, data = data.tobit2space, - constants = constants.tobit2space, inits = inits.tobit2space) + constants = constants.tobit2space) ## Adding X.mod,q,r as data for building model. conf_tobit2space <- configureMCMC(tobit2space_pred, print=TRUE) - conf_tobit2space$addMonitors(c("pf", "muf")) + conf_tobit2space$addMonitors(c("pf", "muf","y.censored")) ## [1] conjugate_dmnorm_dmnorm sampler: X[1:5] ## important! ## this is needed for correct indexing later samplerNumberOffset_tobit2space <- length(conf_tobit2space$getSamplers()) - for(n in 1:nens){ - for(i in 1:ncol(x.ind)) { - node <- paste0('y.censored[',n,',',i,']') + for(n in 1:length(mu.f)){ + node <- paste0('y.censored[',n,']') conf_tobit2space$addSampler(node, 'toggle', control=list(type='RW')) ## could instead use slice samplers, or any combination thereof, e.g.: ##conf$addSampler(node, 'toggle', control=list(type='slice')) - } } conf_tobit2space$printSamplers() - ## can monitor y.censored, if you wish, to verify correct behaviour - #conf_tobit2space$addMonitors('y.censored') - Rmcmc_tobit2space <- buildMCMC(conf_tobit2space) Cmodel_tobit2space <- compileNimble(tobit2space_pred) @@ -769,7 +744,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { } ###-------------------------------------------------------------------### - ### update state matrix ### + ### update state matrix ### ###-------------------------------------------------------------------### S_f <- svd(Pf) L_f <- S_f$d @@ -802,7 +777,8 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # ## check if ensemble mean is correct # cbind(mu.a,colMeans(X_a)) # ## check if ensemble var is correct - # cbind(as.vector(Pa),as.vector(cov(X_a))) + # cbind(diag(Pa),diag(cov(X_a))) ## just variances + # cbind(as.vector(Pa),as.vector(cov(X_a))) ## full cov # analysis <- as.data.frame(rmvnorm(as.numeric(nens), mu.a, Pa, method = "svd")) @@ -986,6 +962,9 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { sqrt(diag(x)) }))) + Ybar[is.na(Ybar)]<-0 + YCI[is.na(YCI)]<-0 + YCI <- YCI[,Y.order] Xsum <- plyr::laply(FORECAST, function(x) { mean(rowSums(x[,1:length(names.y)], na.rm = TRUE)) })[t1:t] @@ -994,7 +973,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { Xci <- plyr::laply(FORECAST[t1:t], function(x) { quantile(x[, i], c(0.025, 0.975)) }) Xci[is.na(Xci)]<-0 - Xa <- plyr::laply(ANALYSIS[t1:t], function(x) { mean(x[, i], na.rm = TRUE) }) + Xa <- plyr::laply(ANALYSIS[t1:t], function(x) { mean(x[, i]) }) XaCI <- plyr::laply(ANALYSIS[t1:t], function(x) { quantile(x[, i], c(0.025, 0.975)) }) plot(as.Date(obs.times[t1:t]), @@ -1092,8 +1071,19 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { colnames(cor.mat) <- colnames(X) rownames(cor.mat) <- colnames(X) par(mfrow = c(1, 1), mai = c(1, 1, 4, 1)) - corrplot(cor.mat, type = "upper", tl.srt = 45,order='AOE') + corrplot(cor.mat, type = "upper", tl.srt = 45,order='FPC') + + cor.mat1 <- cov2cor(cov(X)) + colnames(cor.mat1) <- colnames(X) + rownames(cor.mat1) <- colnames(X) + corrplot(cor.mat1, type = "upper", tl.srt = 45,order='FPC') + + cor.mat1 <- cov2cor(R) + colnames(cor.mat1) <- colnames(X) + rownames(cor.mat1) <- colnames(X) + corrplot(cor.mat1, type = "upper", tl.srt = 45,order='FPC') + plot(as.Date(obs.times[t1:t]), bqq[t1:t], pch = 16, cex = 1, ylab = "Degrees of Freedom", xlab = "Time") From d03c7a8f3a0583886af7458074d68b9b5053146d Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Wed, 9 Aug 2017 18:36:42 -0400 Subject: [PATCH 274/771] dataone download using pre-release code from dataone r (not yet roxygenized) --- modules/data.land/R/dataone_download.R | 54 ++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 modules/data.land/R/dataone_download.R diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R new file mode 100644 index 00000000000..4687e19618c --- /dev/null +++ b/modules/data.land/R/dataone_download.R @@ -0,0 +1,54 @@ +#' DataONE download +#' +#' @param id "The identifier of a package, package metadata or other package member" -- dataone r +#' @param destdir Name the file that will be created to store the data. +#' @param CNode +#' @param lazyLoad "A logical value. If TRUE, then only package member system metadata is downloaded and not data. The default is FALSE." -- dataone R +#' @param quiet "A 'logical'. If TRUE (the default) then informational messages will not be printed." -- dataone R +#' +#' @author Liam P Burke, \email{lpburke@@bu.edu} +#' @description Adapts the dataone::getDataPackage workflow to allow users to download data from the DataONE federation by simply entering the doi or associated package id +#' +#' @export +#' +#' @examples doi_download(id = doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87, destdir = LTER) +doi_download = function(id, destdir = "MyDataFile", CNode = "PROD", lazyLoad = FALSE, quiet = F){ + ### automatically retrieve mnId + cn <- dataone::CNode(CNode) + locations <- dataone::resolve(cn, pid = id) + mnId <- locations$data[1,"nodeIdentifier"] + + ### begin D1 download process + d1c <- dataone::D1Client("PROD", mnId) + pkg <- dataone::getDataPackage(d1c, id = id, lazyLoad = lazyLoad, quiet = quiet, limit = "1MB") # what is the standard limit for pecan downloads? + files <- datapack::getValue(pkg, name="sysmeta@formatId") + n <- length(files) # number of files + ### create a list containing a readable version of the formats + formats <- list() + # add more formats as we come across them + for(i in 1:n){ + if(files[[i]] == "text/csv"){ + formats[i] <- ".csv" + + }else if(files[[i]] == "text/xml"){ + formats[i] <- ".xml" + + }else{ + formats[i] <- ".xml" # this is for the unknown type... Not sure if this is a universal fix... Please advise best practices here. + } + } + + ### read data in the packets individually + filenames <- names(files) # list of all files because they are stored as headers by default + + # filepath & create new directory with timestamp -- same for all files + fp <- paste("~/downloads/data/", destdir, "_", Sys.time(), "/", sep = "") # what should the destination directory/ filepath be for pecan? + dir.create(fp) + + + for(i in 1:n){ + pkgMember <- datapack::getMember(pkg, filenames[i]) + data <- datapack::getData(pkgMember) + base::writeLines(rawToChar(data), paste(fp, "file_", i, formats[[i]], sep = "")) # file naming is an issue... How to proceed? + } +} \ No newline at end of file From e73e25a95a172ced414a8a48ca35f95dddbca8f7 Mon Sep 17 00:00:00 2001 From: araiho Date: Wed, 9 Aug 2017 20:25:11 -0400 Subject: [PATCH 275/771] making some changes so the ensemble adjustment works --- models/linkages/R/write_restart.LINKAGES.R | 11 ++- modules/assim.sequential/R/sda.enkf.R | 86 +++++++++++++--------- modules/assim.sequential/inst/paleon_sda.R | 1 + 3 files changed, 60 insertions(+), 38 deletions(-) diff --git a/models/linkages/R/write_restart.LINKAGES.R b/models/linkages/R/write_restart.LINKAGES.R index fcde7ef0bb4..282d1d863b2 100644 --- a/models/linkages/R/write_restart.LINKAGES.R +++ b/models/linkages/R/write_restart.LINKAGES.R @@ -214,6 +214,9 @@ write_restart.LINKAGES <- function(outdir, runid, start.time, stop.time, setting new.ntrees[s] = sample(size = 1, x = 50:150) } } + + if(sum(new.ntrees) > 200) new.ntrees <- round((new.ntrees / sum(new.ntrees)) * runif(1,160,199)) + print(paste0("new.ntrees =", new.ntrees)) new.n.index <- c(rep(1, new.ntrees[1])) @@ -221,9 +224,9 @@ write_restart.LINKAGES <- function(outdir, runid, start.time, stop.time, setting new.n.index <- c(new.n.index, rep(i, new.ntrees[i])) } - dbh.temp <- numeric(15000) - iage.temp <- numeric(15000) - nogro.temp <- numeric(15000) + dbh.temp <- numeric(200) + iage.temp <- numeric(200) + nogro.temp <- numeric(200) # sample from individuals to construct new states for (s in seq_len(nspec)) { @@ -297,7 +300,7 @@ write_restart.LINKAGES <- function(outdir, runid, start.time, stop.time, setting dbh <- dbh.temp iage <- iage.temp - nogro <- nogro.temp # numeric(15000)#hack + nogro <- nogro.temp # numeric(200)#hack nogro[nogro < (-2)] <- 1 diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index 5c561723ab1..25c6f2aa5a7 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -219,6 +219,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # at some point add a lot of error checking # read time from data if data is missing you still need # to have NAs or NULL with date name vector to read the correct netcdfs by read_restart + sum.list <- matrix(NA,nens,nt) obs.times <- names(obs.mean) obs.times.POSIX <- ymd_hms(obs.times) @@ -330,11 +331,15 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { alphagreen <- rgb(green[1], green[2], green[3], 75, max = 255) blue <- col2rgb("blue") alphablue <- rgb(blue[1], blue[2], blue[3], 75, max = 255) + purple <- col2rgb("purple") + alphapurple <- rgb(purple[1], purple[2], purple[3], 75, max = 255) + brown <- col2rgb("brown") + alphabrown <- rgb(brown[1], brown[2], brown[3], 75, max = 255) ###-------------------------------------------------------------------### ### loop over time ### ###-------------------------------------------------------------------### - for(t in 1:nt) {#seq_len(nt) + for(t in seq_len(nt)) {#seq_len(nt) ###-------------------------------------------------------------------### ### read restart ### @@ -502,11 +507,13 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { x.censored <- as.numeric(ifelse(mu.f > intervalX[,1], mu.f, 0)) #probably not needed until different data - if(t == 1){ #| length(x.ind[1,]) > mu.f - #y.obs = Y.dat[1,] + if(t == 1){ + #The purpose of this step is to impute data for mu.f + #where there are zero values so that + #mu.f is in 'tobit space' in the full model constants.tobit2space = list(N = length(mu.f), muf = mu.f, - pf = Pf) + pf = solve(Pf)) data.tobit2space = list(y.ind = x.ind, y.censored = x.censored) #set.seed(0) @@ -535,21 +542,26 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { Cmodel_tobit2space <- compileNimble(tobit2space_pred) Cmcmc_tobit2space <- compileNimble(Rmcmc_tobit2space, project = tobit2space_pred) + for(i in 1:length(mu.f)) { + ## ironically, here we have to "toggle" the value of y.ind[i] + ## this specifies that when y.ind[i] = 1, + ## indicator variable is set to 0, which specifies *not* to sample + valueInCompiledNimbleFunction(Cmcmc_tobit2space$samplerFunctions[[samplerNumberOffset_tobit2space+i]], 'toggle', 1-x.ind[i]) + } + }else{ Cmodel_tobit2space$y.ind <- x.ind Cmodel_tobit2space$y.censored <- x.censored - #Cmodel_tobit2space$mu.prior <- as.vector(colMeans(X)) #doesn't work - #Error in envRefSetField(x, what, refObjectClass(x), selfEnv, value) : - #‘mu.prior’ is not a field in class “Ccode” + Cmodel_tobit2space$muf <- mu.f + Cmodel_tobit2space$pf <- solve(Pf) - for(n in 1:nens){ - for(i in 1:ncol(x.ind)) { + for(i in 1:length(mu.f)) { ## ironically, here we have to "toggle" the value of y.ind[i] ## this specifies that when y.ind[i] = 1, ## indicator variable is set to 0, which specifies *not* to sample - valueInCompiledNimbleFunction(Cmcmc_tobit2space$samplerFunctions[[samplerNumberOffset_tobit2space+i]], 'toggle', 1-x.ind[n,i]) - } + valueInCompiledNimbleFunction(Cmcmc_tobit2space$samplerFunctions[[samplerNumberOffset_tobit2space+i]], 'toggle', 1-x.ind[i]) } + } set.seed(0) @@ -557,12 +569,8 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ## update parameters dat.tobit2space <- dat.tobit2space[3000:10000, ] - iPf <- grep("pf", colnames(dat.tobit2space)) - imuf <- grep("muf[", colnames(dat.tobit2space), fixed = TRUE) + imuf <- grep("y.censored", colnames(dat.tobit2space)) mu.f <- colMeans(dat.tobit2space[, imuf]) - mPf <- dat.tobit2space[, iPf] # Omega, Precision - Pf <- matrix(apply(mPf, 2, mean), length(mu.f), length(mu.f)) # Mean Omega, Precision - ###-------------------------------------------------------------------### ### Generalized Ensemble Filter ### @@ -642,6 +650,13 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { Cmodel <- compileNimble(model_pred) Cmcmc <- compileNimble(Rmcmc, project = model_pred) + for(i in 1:length(y.ind)) { + ## ironically, here we have to "toggle" the value of y.ind[i] + ## this specifies that when y.ind[i] = 1, + ## indicator variable is set to 0, which specifies *not* to sample + valueInCompiledNimbleFunction(Cmcmc$samplerFunctions[[samplerNumberOffset+i]], 'toggle', 1-y.ind[i]) + } + }else{ Cmodel$y.ind <- y.ind Cmodel$y.censored <- y.censored @@ -769,20 +784,27 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ## analysis ensemble X_a <- X*0 for(i in seq_len(nens)){ - X_a[i,] <- V_a %*%diag(sqrt(L_a))%*%Z[i,]+mu.a + X_a[i,] <- V_a %*%diag(sqrt(L_a))%*%Z[i,] + mu.a + } + + + for(i in seq_len(nens)){ + sum.list[i,t]<-sum(V_a %*%diag(sqrt(L_a))%*%Z[i,] - mu.a) } # par(mfrow=c(1,1)) # plot(X_a) # ## check if ensemble mean is correct # cbind(mu.a,colMeans(X_a)) + if(sum(mu.a-colMeans(X_a))>1) logger.warn('Problem with ensemble adjustment (1)') + if(sum(diag(Pa),diag(cov(X_a)))>5) logger.warn('Problem with ensemble adjustment (2)') # ## check if ensemble var is correct # cbind(diag(Pa),diag(cov(X_a))) ## just variances # cbind(as.vector(Pa),as.vector(cov(X_a))) ## full cov # - analysis <- as.data.frame(rmvnorm(as.numeric(nens), mu.a, Pa, method = "svd")) + #analysis <- as.data.frame(rmvnorm(as.numeric(nens), mu.a, Pa, method = "svd")) - #analysis <- as.data.frame(X_a) + analysis <- as.data.frame(X_a) colnames(analysis) <- colnames(X) ##### Mapping analysis vectors to be in bounds of state variables @@ -811,19 +833,24 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { tmp[mch] <- x[mch] tmp })) + + if(any(obs)){ Y.order <- na.omit(pmatch(colnames(X), colnames(Ybar))) Ybar <- Ybar[,Y.order] YCI <- t(as.matrix(sapply(obs.cov[t1:t], function(x) { - if (is.null(x)) { + if (length(x)<2) { rep(NA, length(names.y)) } sqrt(diag(x)) }))) YCI <- YCI[,Y.order] + }else{ + YCI <- matrix(NA,nrow=length(t1:t), ncol=length(names.y)) + } par(mfrow = c(2, 1)) - for (i in 1:ncol(FORECAST[[t]])) {# + for (i in 1:ncol(FORECAST[[t]])) { t1 <- 1 Xbar <- plyr::laply(FORECAST[t1:t], function(x) { mean(x[, i], na.rm = TRUE) }) Xci <- plyr::laply(FORECAST[t1:t], function(x) { quantile(x[, i], c(0.025, 0.975)) }) @@ -1030,7 +1057,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ciEnvelope(rev(t1:t), rev(Xci[, 1] - unlist(Ybar[, i])), rev(Xci[, 2] - unlist(Ybar[, i])), - col = alphapink) + col = alphabrown) abline(h = 0, lty = 2, lwd = 2) abline(reg) mtext(paste("slope =", signif(summary(reg)$coefficients[2], digits = 3), @@ -1049,7 +1076,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ciEnvelope(rev(t1:t), rev(Xbar - XaCI[, 1]), rev(Xbar - XaCI[, 2]), - col = alphagreen) + col = alphapurple) abline(h = 0, lty = 2, lwd = 2) abline(reg1) mtext(paste("slope =", signif(summary(reg1)$coefficients[2], digits = 3), @@ -1073,22 +1100,13 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { par(mfrow = c(1, 1), mai = c(1, 1, 4, 1)) corrplot(cor.mat, type = "upper", tl.srt = 45,order='FPC') - cor.mat1 <- cov2cor(cov(X)) - colnames(cor.mat1) <- colnames(X) - rownames(cor.mat1) <- colnames(X) - corrplot(cor.mat1, type = "upper", tl.srt = 45,order='FPC') - - cor.mat1 <- cov2cor(R) - colnames(cor.mat1) <- colnames(X) - rownames(cor.mat1) <- colnames(X) - corrplot(cor.mat1, type = "upper", tl.srt = 45,order='FPC') - - + par(mfrow=c(1,1)) plot(as.Date(obs.times[t1:t]), bqq[t1:t], pch = 16, cex = 1, ylab = "Degrees of Freedom", xlab = "Time") dev.off() + } ###-------------------------------------------------------------------### diff --git a/modules/assim.sequential/inst/paleon_sda.R b/modules/assim.sequential/inst/paleon_sda.R index a4c43769ce0..3c424c47b1b 100644 --- a/modules/assim.sequential/inst/paleon_sda.R +++ b/modules/assim.sequential/inst/paleon_sda.R @@ -13,6 +13,7 @@ ciEnvelope <- function(x,ylo,yhi,...){ #LINKAGES #AGB.pft #Harvard Forest setwd('/fs/data2/output//PEcAn_1000003314/') +setwd('/fs/data2/output//PEcAn_1000007999/') #TO DO: Having problem with running proc.var == TRUE because nimble isn't keeping the toggle sampler in the function environment. #TO DO: Intial conditions for linkages are messed up. Need to calibrate. From 66bc7a2c65fa974ea88e952d288a6498f3a92465 Mon Sep 17 00:00:00 2001 From: Ann Raiho Date: Wed, 9 Aug 2017 20:33:45 -0400 Subject: [PATCH 276/771] small changes --- models/linkages/R/model2netcdf.LINKAGES.R | 4 +- models/linkages/R/write_restart.LINKAGES.R | 15 ++-- modules/assim.batch/R/pda.get.model.output.R | 9 +- modules/assim.sequential/R/sda.enkf.R | 94 +++++++++----------- 4 files changed, 62 insertions(+), 60 deletions(-) diff --git a/models/linkages/R/model2netcdf.LINKAGES.R b/models/linkages/R/model2netcdf.LINKAGES.R index 34f0821efa1..79930c7ed67 100644 --- a/models/linkages/R/model2netcdf.LINKAGES.R +++ b/models/linkages/R/model2netcdf.LINKAGES.R @@ -72,7 +72,7 @@ model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, e # ******************** Declare netCDF variables ********************# dim.t <- ncdim_def(name = "time", units = paste0("days since ", years[y], "-01-01 00:00:00"), - vals = as.numeric(years[y]), calendar = "standard", + vals = 0, calendar = "standard", unlim = TRUE) dim.lat <- ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") dim.lon <- ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") @@ -102,7 +102,7 @@ model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, e var[[12]] <- ncvar_def("Fcomp", "kgC/kgC", list(dim.pfts, dim.lat, dim.lon, dim.t), -999) var[[13]] <- ncvar_def("LAI", "m2/m2", list(dim.lat, dim.lon, dim.t), -999) var[[14]] <- ncvar_def("SoilMoist", "m2/m2", list(dim.lat, dim.lon, dim.t), -999) - var[[15]] <- ncvar_def("AbvGrnWood", "kgC/m2", list(dim.lat, dim.lon, dim.t), -999) + var[[15]] <- ncvar_def("AbvGrndWood", "kgC/m2", list(dim.lat, dim.lon, dim.t), -999) # ******************** Declare netCDF variables ********************# diff --git a/models/linkages/R/write_restart.LINKAGES.R b/models/linkages/R/write_restart.LINKAGES.R index fcde7ef0bb4..289b8d2059f 100644 --- a/models/linkages/R/write_restart.LINKAGES.R +++ b/models/linkages/R/write_restart.LINKAGES.R @@ -131,7 +131,7 @@ write_restart.LINKAGES <- function(outdir, runid, start.time, stop.time, setting if (!file.exists(outfile)) { outfile <- file.path(outdir, runid, paste0(start.time, "linkages.out.Rdata")) if (!file.exists(outfile)) { - logger.severe(paste0("missing outfile ens #", runid)) + logger.severe(paste0("missing outfile ens #", runid)) } } print(paste0("runid = ", runid)) @@ -160,7 +160,7 @@ write_restart.LINKAGES <- function(outdir, runid, start.time, stop.time, setting }else{ large.trees <- which(dbh >= 20) } - + for (s in seq_along(settings$pfts)) { ntrees[s] <- length(which(n.index[large.trees] == s)) } @@ -214,6 +214,9 @@ write_restart.LINKAGES <- function(outdir, runid, start.time, stop.time, setting new.ntrees[s] = sample(size = 1, x = 50:150) } } + + if(sum(new.ntrees) > 198) new.ntrees <- round((new.ntrees / sum(new.ntrees)) * runif(1,160,195)) + print(paste0("new.ntrees =", new.ntrees)) new.n.index <- c(rep(1, new.ntrees[1])) @@ -221,9 +224,9 @@ write_restart.LINKAGES <- function(outdir, runid, start.time, stop.time, setting new.n.index <- c(new.n.index, rep(i, new.ntrees[i])) } - dbh.temp <- numeric(15000) - iage.temp <- numeric(15000) - nogro.temp <- numeric(15000) + dbh.temp <- numeric(200) + iage.temp <- numeric(200) + nogro.temp <- numeric(200) # sample from individuals to construct new states for (s in seq_len(nspec)) { @@ -297,7 +300,7 @@ write_restart.LINKAGES <- function(outdir, runid, start.time, stop.time, setting dbh <- dbh.temp iage <- iage.temp - nogro <- nogro.temp # numeric(15000)#hack + nogro <- nogro.temp # numeric(200)#hack nogro[nogro < (-2)] <- 1 diff --git a/modules/assim.batch/R/pda.get.model.output.R b/modules/assim.batch/R/pda.get.model.output.R index 8fe856be228..8d71617d5c6 100644 --- a/modules/assim.batch/R/pda.get.model.output.R +++ b/modules/assim.batch/R/pda.get.model.output.R @@ -107,11 +107,16 @@ pda.get.model.output <- function(settings, run.id, bety, inputs) { ## Handle model time # the model output time is in days since the beginning of the year - model.secs <- udunits2::ud.convert(model$time, "years" ,"seconds") + model.secs <- udunits2::ud.convert(model$time, "days" ,"seconds") # seq.POSIXt returns class "POSIXct" # the model output is since the beginning of the year but 'settings$run$start.date' may not be the first day of the year, using lubridate::floor_date - model$posix <- seq.POSIXt(from = as.POSIXlt(settings$run$start.date, tz="GMT"), by = diff(model.secs)[1], length.out = length(model$time)) + if(diff(model.secs)[1] != 0){ + model$posix <- seq.POSIXt(from = as.POSIXlt(settings$run$start.date, tz="GMT"), by = diff(model.secs)[1], length.out = length(model$time)) + }else{ + # yearly output + model$posix <- seq.POSIXt(from = as.POSIXlt(settings$run$start.date, tz="GMT"), by = "year", length.out = length(model$time)) + } dat <- PEcAn.benchmark::align_data(model.calc = model, obvs.calc = inputs[[k]]$data, var = data.var, align_method = inputs[[k]]$align.method) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index 2b86b65ca6a..52de6923b28 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -82,10 +82,10 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ### model specific split inputs inputs[[i]] <- do.call(my.split_inputs, - args = list(settings = settings, - start.time = settings$run$start.date, - stop.time = settings$run$end.date, - inputs = ens.inputs[[i]])) + args = list(settings = settings, + start.time = settings$run$start.date, + stop.time = settings$run$end.date, + inputs = ens.inputs[[i]])) } ###-------------------------------------------------------------------### @@ -211,6 +211,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { save(list = ls(envir = environment(), all.names = TRUE), file = file.path(outdir, "sda.initial.runs.Rdata"), envir = environment()) + ###-------------------------------------------------------------------### ### tests before data assimilation ### ###-------------------------------------------------------------------### @@ -257,7 +258,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ##### state.interval stays constant and converts new.analysis to be within the correct bounds interval <- NULL state.interval <- cbind(as.numeric(lapply(settings$state.data.assimilation$state.variables,'[[','min_value')), - as.numeric(lapply(settings$state.data.assimilation$state.variables,'[[','max_value'))) + as.numeric(lapply(settings$state.data.assimilation$state.variables,'[[','max_value'))) rownames(state.interval) <- var.names wish.df <- function(Om, X, i, j, col) { @@ -312,20 +313,17 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { }) - tobit2space.model <- nimbleCode({ - + tobit2space.model <- nimbleCode({ for(n in 1:nens){ - y.censored[n,1:N] ~ dmnorm(muf[1:N],pf[1:N,1:N]) - - for(i in 1:N){ - y.ind[n,i] ~ dinterval(y.censored[n,i], interval[i,1:2]) - } + y.censored[n,1:N] ~ dmnorm(muf[1:N], prec = pf[1:N,1:N]) + for(i in 1:N){ + y.ind[n,i] ~ dinterval(y.censored[n,i], interval[i,1:2]) + } } - #Priors - pf[1:N,1:N] ~ dwish(aq[1:N,1:N],bq) - muf[1:N] ~ dmnorm(mu.prior[1:N],cov.prior[1:N,1:N]) - + pf[1:N,1:N] ~ dwish(R = aq[1:N,1:N], df = bq) + muf[1:N] ~ dmnorm(mu.prior[1:N], prec = cov.prior[1:N,1:N]) + #simulate censored values conditional on observations }) t1 <- 1 @@ -339,7 +337,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ###-------------------------------------------------------------------### ### loop over time ### ###-------------------------------------------------------------------### - for(t in 3:5) {# + for(t in 2:5) {#seq_len(nt) ###-------------------------------------------------------------------### ### read restart ### @@ -386,16 +384,8 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { R[is.na(R)]<-0 if (length(obs.mean[[t]]) > 1) { - for (s in seq_along(obs.mean[[t]])) { - if (diag(R)[s] == 0) { - # if covariance is 0 then set it to half of the minimum covariance to avoid solve() problems - diag(R)[s] <- min(diag(R)[which(diag(R) != 0)])/2 - } - if (diag(Pf)[s] == 0) { - # if covariance is 0 then set it to half of the minimum covariance to avoid solve() problems - diag(Pf)[s] <- min(diag(Pf)[which(diag(Pf) != 0)])/2 - } - } + diag(R)[which(diag(R)==0)] <- min(diag(R)[which(diag(R) != 0)])/2 + diag(Pf)[which(diag(Pf)==0)] <- min(diag(Pf)[which(diag(Pf) != 0)])/5 } ### TO DO: plotting not going to work because of observation operator i.e. y and x are on different scales @@ -476,11 +466,11 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { Pf.scale[is.na(Pf.scale)]<-0 R.scale <- t(t(R/as.vector(map.mu.f))/as.vector(map.mu.f)) - # mu.f.scale <- scale(mu.f,center = FALSE, scale = mean(mu.f)) - # Pf.scale <- mu.f*Pf%*%t(t(mu.f)) - # Pf.scale[is.na(Pf.scale)]<-0 - # R.scale <- matrix(scale(as.vector(R), center = mean(mu.f), scale = 1),2,2) - # Y.scale <- scale(Y, center = mean(mu.f[1:2]), scale = 1) + # mu.f.scale <- scale(mu.f,center = FALSE, scale = mean(mu.f)) + # Pf.scale <- mu.f*Pf%*%t(t(mu.f)) + # Pf.scale[is.na(Pf.scale)]<-0 + # R.scale <- matrix(scale(as.vector(R), center = mean(mu.f), scale = 1),2,2) + # Y.scale <- scale(Y, center = mean(mu.f[1:2]), scale = 1) ## Kalman Gain K <- Pf.scale %*% t(H) %*% solve((R.scale + H %*% Pf.scale %*% t(H))) @@ -525,8 +515,8 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { y.censored = x.censored, aq = diag(ncol(X))*ncol(X), bq = ncol(X), - mu.prior = colMeans(X), #cheating? basically gives us back means - cov.prior = diag(ncol(X))) + mu.prior = rep(0,ncol(X)), #cheating? basically gives us back means + cov.prior = diag(.01, nrow = ncol(X))) inits.tobit2space = list(pf = diag(ncol(X)), muf = rep(0,ncol(X))) # #set.seed(0) @@ -603,7 +593,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { } } aqq[1, , ] <- diag(length(mu.f)) * bqq[1] - + #### changing diagonal if the covariance is too small for the matrix to be inverted #### This problem is different than R problem because diag(Pf) can be so small it can't be inverted #### Need a different fix here someday @@ -682,7 +672,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ## indicator variable is set to 0, which specifies *not* to sample valueInCompiledNimbleFunction(Cmcmc$samplerFunctions[[samplerNumberOffset+i]], 'toggle', 1-y.ind[i]) } - + } set.seed(0) @@ -769,7 +759,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { } ###-------------------------------------------------------------------### - ### update state matrix ### + ### update state matrix ### ###-------------------------------------------------------------------### S_f <- svd(Pf) L_f <- S_f$d @@ -802,7 +792,8 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # ## check if ensemble mean is correct # cbind(mu.a,colMeans(X_a)) # ## check if ensemble var is correct - # cbind(as.vector(Pa),as.vector(cov(X_a))) + # cbind(diag(Pa),diag(cov(X_a))) ## just variances + # cbind(as.vector(Pa),as.vector(cov(X_a))) ## full cov # analysis <- as.data.frame(rmvnorm(as.numeric(nens), mu.a, Pa, method = "svd")) @@ -818,13 +809,13 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { analysis[analysis[,i] > int.save[2],i] <- int.save[2] } } - + ## in the future will have to be separated from analysis new.state <- analysis new.params <- params ANALYSIS[[t]] <- analysis - + if (interactive() & t > 1) { # t1 <- 1 names.y <- unique(unlist(lapply(obs.mean[t1:t], function(x) { names(x) }))) @@ -907,14 +898,14 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ###-------------------------------------------------------------------### ### split model specific inputs for current runs ### ###-------------------------------------------------------------------### - + inputs <- list() for(i in seq_len(nens)){ inputs[[i]] <- do.call(my.split_inputs, - args = list(settings = settings, - start.time = (ymd_hms(obs.times[t],truncated = 3) + second(hms("00:00:01"))), - stop.time = obs.times[t + 1], - inputs = ens.inputs[[i]])) + args = list(settings = settings, + start.time = (ymd_hms(obs.times[t],truncated = 3) + second(hms("00:00:01"))), + stop.time = obs.times[t + 1], + inputs = ens.inputs[[i]])) } @@ -986,15 +977,18 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { sqrt(diag(x)) }))) + Ybar[is.na(Ybar)]<-0 + YCI[is.na(YCI)]<-0 + YCI <- YCI[,Y.order] Xsum <- plyr::laply(FORECAST, function(x) { mean(rowSums(x[,1:length(names.y)], na.rm = TRUE)) })[t1:t] - + for (i in seq_len(ncol(X))) { Xbar <- plyr::laply(FORECAST[t1:t], function(x) { mean(x[, i], na.rm = TRUE) }) Xci <- plyr::laply(FORECAST[t1:t], function(x) { quantile(x[, i], c(0.025, 0.975)) }) Xci[is.na(Xci)]<-0 - Xa <- plyr::laply(ANALYSIS[t1:t], function(x) { mean(x[, i], na.rm = TRUE) }) + Xa <- plyr::laply(ANALYSIS[t1:t], function(x) { mean(x[, i]) }) XaCI <- plyr::laply(ANALYSIS[t1:t], function(x) { quantile(x[, i], c(0.025, 0.975)) }) plot(as.Date(obs.times[t1:t]), @@ -1023,10 +1017,10 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # analysis ciEnvelope(as.Date(obs.times[t1:t]), XaCI[, 1], XaCI[, 2], col = alphapink) lines(as.Date(obs.times[t1:t]), Xa, col = "black", lty = 2, lwd = 2) - + legend('topright',c('Forecast','Data','Analysis'),col=c(alphablue,alphagreen,alphapink),lty=1,lwd=5) - } + } dev.off() ###-------------------------------------------------------------------### ### bias diagnostics ### @@ -1092,7 +1086,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { colnames(cor.mat) <- colnames(X) rownames(cor.mat) <- colnames(X) par(mfrow = c(1, 1), mai = c(1, 1, 4, 1)) - corrplot(cor.mat, type = "upper", tl.srt = 45,order='AOE') + corrplot(cor.mat, type = "upper", tl.srt = 45,order='FPC') plot(as.Date(obs.times[t1:t]), bqq[t1:t], pch = 16, cex = 1, From 37ebd32fadde77e2af09308de64bc85540ef8abd Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Wed, 9 Aug 2017 20:43:03 -0400 Subject: [PATCH 277/771] deleted duplicate 'description' field --- modules/data.land/NAMESPACE | 1 + modules/data.mining/DESCRIPTION | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index bfa07bff22a..f9b8f61e7ae 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -5,6 +5,7 @@ export(InventoryGrowthFusion) export(InventoryGrowthFusionDiagnostics) export(Read_Tucson) export(buildJAGSdata_InventoryRings) +export(doi_download) export(download_package_rm) export(extract.stringCode) export(extract_FIA) diff --git a/modules/data.mining/DESCRIPTION b/modules/data.mining/DESCRIPTION index ff6002bbb27..ce475137847 100644 --- a/modules/data.mining/DESCRIPTION +++ b/modules/data.mining/DESCRIPTION @@ -6,7 +6,6 @@ Version: 1.5.0 Date: 2017-07-14 Author: Mike Dietze Maintainer: Mike Dietze -Description: Depends: dplR Suggests: From 261bcb570b4a430e61f05458f4e6768e5cedac18 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Wed, 9 Aug 2017 20:58:46 -0400 Subject: [PATCH 278/771] roxygen doc for doi_download --- modules/data.land/man/doi_download.Rd | 29 +++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 modules/data.land/man/doi_download.Rd diff --git a/modules/data.land/man/doi_download.Rd b/modules/data.land/man/doi_download.Rd new file mode 100644 index 00000000000..c535e6008a2 --- /dev/null +++ b/modules/data.land/man/doi_download.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dataone_download.R +\name{doi_download} +\alias{doi_download} +\title{DataONE download} +\usage{ +doi_download(id, destdir = "MyDataFile", CNode = "PROD", lazyLoad = FALSE, + quiet = F) +} +\arguments{ +\item{id}{"The identifier of a package, package metadata or other package member" -- dataone r} + +\item{destdir}{Name the file that will be created to store the data.} + +\item{CNode}{} + +\item{lazyLoad}{"A logical value. If TRUE, then only package member system metadata is downloaded and not data. The default is FALSE." -- dataone R} + +\item{quiet}{"A 'logical'. If TRUE (the default) then informational messages will not be printed." -- dataone R} +} +\description{ +Adapts the dataone::getDataPackage workflow to allow users to download data from the DataONE federation by simply entering the doi or associated package id +} +\examples{ +doi_download(id = doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87, destdir = LTER) +} +\author{ +Liam P Burke, \email{lpburke@bu.edu} +} From 7e074bc1c1c7767309682458791e21075b5a907d Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 10 Aug 2017 11:43:52 -0400 Subject: [PATCH 279/771] removed duplication description that was breaking make --- modules/data.mining/DESCRIPTION | 1 - 1 file changed, 1 deletion(-) diff --git a/modules/data.mining/DESCRIPTION b/modules/data.mining/DESCRIPTION index ff6002bbb27..ce475137847 100644 --- a/modules/data.mining/DESCRIPTION +++ b/modules/data.mining/DESCRIPTION @@ -6,7 +6,6 @@ Version: 1.5.0 Date: 2017-07-14 Author: Mike Dietze Maintainer: Mike Dietze -Description: Depends: dplR Suggests: From 08a5c2a59233eef345db2f771313b0c21964e1a1 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Thu, 10 Aug 2017 22:15:53 +0530 Subject: [PATCH 280/771] Added client side script for sync --- web/setups/clientsyncscript.php | 70 +++++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100644 web/setups/clientsyncscript.php diff --git a/web/setups/clientsyncscript.php b/web/setups/clientsyncscript.php new file mode 100644 index 00000000000..169b41f6dcb --- /dev/null +++ b/web/setups/clientsyncscript.php @@ -0,0 +1,70 @@ + $client_sceret, 'server_auth_token' => $server_auth_token, 'fqdn' => $fqdn ); +// +// // Build Http query using params +// $query = http_build_query ($params); +// +// // Create Http context details +// $contextData = array ( +// 'method' => 'POST', +// 'header' => "Connection: close\r\n". +// "Content-Length: ".strlen($query)."\r\n", +// 'content'=> $query ); +// +// // Create context resource for our request +// $context = stream_context_create (array ( 'http' => $contextData )); +// +// // Read page rendered as result of your POST request +// $result = file_get_contents ( +// $server_url, // page url +// false, +// $context); + +// +$service_url = $server_url."/web/setups/serversyncscript.php"; + +$curl = curl_init($service_url); + +$curl_post_data = array ('client_sceret' => $client_sceret, + 'server_auth_token' => $server_auth_token, + 'fqdn' => $fqdn ); + +// setting curl to do a POST request +curl_setopt($curl, CURLOPT_RETURNTRANSFER, true); +curl_setopt($curl, CURLOPT_POST, true); +curl_setopt($curl, CURLOPT_POSTFIELDS, $curl_post_data); + +// execute the curl request +$curl_response = curl_exec($curl); + +// if curls execution fails +if ($curl_response === false) { + $info = curl_getinfo($curl); + curl_close($curl); + die('error occured during curl exec. Additioanl info: ' . var_export($info)); +} + +// close curl +curl_close($curl); +$decoded = json_decode($curl_response); +if (isset($decoded->status) && $decoded->status == 'ERROR') { + die('error occured: ' . $decoded->errormessage); +} + +// got wait id +var_export($decoded->waitid); + +// script to handle wait id part +?> From db13ba1462c54b66242c080ad1caccef09de82f1 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Thu, 10 Aug 2017 22:16:28 +0530 Subject: [PATCH 281/771] Added the server side script --- web/setups/serversyncscript.php | 61 +++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 web/setups/serversyncscript.php diff --git a/web/setups/serversyncscript.php b/web/setups/serversyncscript.php new file mode 100644 index 00000000000..a78eabd547b --- /dev/null +++ b/web/setups/serversyncscript.php @@ -0,0 +1,61 @@ +prepare("INSERT + INTO machines (id, hostname, created_at, updated_at , sync_host_id, sync_url, sync_contact, sync_start, sync_end) + VALUES (, :hostname, :created_at, :updated_at , :sync_host_id, :sync_url, :sync_contact, :sync_start, :sync_end );"); + if (!$stmt->execute(array(':hostname' => $fqdn, + ':created_at' => date("Y-m-d"), + ':updated_at' => date("Y-m-d"), + ':sync_host_id' => , + ':sync_url' =>, + ':sync_contact' =>, + ':sync_start' => , + ':sync_end' => ))) { + echo json_encode(array('status' => 'ERROR', + 'errormessage' => 'Invalid query : [' . error_database() . ']' . $pdo->errorInfo())); + die(); + } + +} + +$stmt = $pdo->prepare("SELECT * FROM machines WHERE hostname = ?"); +if (!$stmt->execute(array($fqdn))) { + echo json_encode(array('status' => 'ERROR', + 'errormessage' => 'Invalid query : [' . error_database() . ']' . $pdo->errorInfo())); + die(); +} +$row = $stmt->fetch(PDO::FETCH_ASSOC); +$stmt->closeCursor(); + +// checking for existance and other things + +$wantid = 1; // Generate the wantid + +echo json_encode(array('wantid' => $wantid)); // return the data + +?> From ee73815c16ded1bcc77fd103e279f7002320b3a5 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Thu, 10 Aug 2017 22:16:57 +0530 Subject: [PATCH 282/771] Added corn job script --- web/setups/synccorn.php | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 web/setups/synccorn.php diff --git a/web/setups/synccorn.php b/web/setups/synccorn.php new file mode 100644 index 00000000000..8fa62226903 --- /dev/null +++ b/web/setups/synccorn.php @@ -0,0 +1,17 @@ + From 1f22fd1e57ae82cf6b0ba74c294a3c5397c8d298 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Thu, 10 Aug 2017 22:17:23 +0530 Subject: [PATCH 283/771] Added sync details in config.php --- web/config.example.php | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/web/config.example.php b/web/config.example.php index 9e9066caab5..07234f6c1fd 100644 --- a/web/config.example.php +++ b/web/config.example.php @@ -50,7 +50,7 @@ $fqdn=exec('hostname -f'); # List of all host and options. The list should be the server pointing -# to an array. The second array contains a key value pair used to +# to an array. The second array contains a key value pair used to # configure the host. Currenly the following options are available: # - qsub : if specified the jobs are launched using qsub, this can # be an empty value to indicate to use default settings. @@ -65,13 +65,13 @@ # - postrun : any special options to add at the end of the job. # - folder : folder on remote machine, will add username and the # workflowid to the folder name -# - models : any special options to add to a specific model that is +# - models : any special options to add to a specific model that is # launched. This is an array of the modeltype and # additional parameters for the job.sh. # - scratchdir : folder to be used for scratchspace when running certain # models (such as ED) $hostlist=array($fqdn => array(), - "geo.bu.edu" => + "geo.bu.edu" => array("qsub" => "qsub -V -N @NAME@ -o @STDOUT@ -e @STDERR@ -S /bin/bash", "jobid" => "Your job ([0-9]+) .*", "qstat" => "qstat -j @JOBID@ || echo DONE", @@ -109,5 +109,10 @@ # uncomment the following variable to enable the simple interface #$simpleBETY = TRUE; +# syncing details + +$server_url="192.168.0.5"; // local test server +$client_sceret=""; +$server_auth_token=""; ?> From 2585bb03417496dadc46b05ecfcd8352993dcc6b Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Thu, 10 Aug 2017 15:55:11 -0700 Subject: [PATCH 284/771] tree ring diagnostics update --- .../R/InventoryGrowthFusionDiagnostics.R | 44 ++++++++++++++++--- 1 file changed, 39 insertions(+), 5 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusionDiagnostics.R b/modules/data.land/R/InventoryGrowthFusionDiagnostics.R index 54a5cfe5f1a..e7131aba9f3 100644 --- a/modules/data.land/R/InventoryGrowthFusionDiagnostics.R +++ b/modules/data.land/R/InventoryGrowthFusionDiagnostics.R @@ -12,6 +12,7 @@ InventoryGrowthFusionDiagnostics <- function(jags.out, combined) { layout(matrix(1:8, 4, 2, byrow = TRUE)) out <- as.matrix(jags.out) x.cols <- which(substr(colnames(out), 1, 1) == "x") + if(length(x.cols) > 0){ ci <- apply(out[, x.cols], 2, quantile, c(0.025, 0.5, 0.975)) ci.names <- parse.MatrixNames(colnames(ci), numeric = TRUE) @@ -37,7 +38,7 @@ InventoryGrowthFusionDiagnostics <- function(jags.out, combined) { ciEnvelope(data$time[-1], inc.ci[1, ], inc.ci[3, ], col = "lightBlue") points(data$time, data$y[i, ] * 5, pch = "+", cex = 1.5, type = "b", lty = 2) } - + } if (FALSE) { ## check a DBH plot(out[, which(colnames(out) == "x[3,31]")]) @@ -47,25 +48,58 @@ InventoryGrowthFusionDiagnostics <- function(jags.out, combined) { } ## process model - vars <- (1:ncol(out))[-c(which(substr(colnames(out), 1, 1) == "x"), grep("tau", colnames(out)), - grep("year", colnames(out)), grep("ind", colnames(out)))] + vars <- (1:ncol(out))[-c(which(substr(colnames(out), 1, 1) == "x"), + grep("tau", colnames(out)), + grep("year", colnames(out)), + grep("ind", colnames(out)), + grep("alpha",colnames(out)), + grep("deviance",colnames(out)))] + par(mfrow = c(1, 1)) for (i in vars) { hist(out[, i], main = colnames(out)[i]) + abline(v=0,lwd=3) } - if (length(vars) > 1) { + if (length(vars) > 1 && length(vars) < 10) { pairs(out[, vars]) } + if("deviance" %in% colnames(out)){ + hist(out[,"deviance"]) + vars <- c(vars,which(colnames(out)=="deviance")) + } + + ## rebuild coda for just vars + var.out <- as.mcmc.list(lapply(jags.out,function(x){ x[,vars]})) + + ## convergence + gelman.diag(var.out) + + #### Diagnostic plots + plot(var.out) + + ## Standard Deviations layout(matrix(c(1,2,3,3),2,2,byrow=TRUE)) par(mfrow = c(2, 3)) prec <- out[, grep("tau", colnames(out))] - for (i in seq_along(prec)) { + for (i in seq_len(ncol(prec))) { hist(1 / sqrt(prec[, i]), main = colnames(prec)[i]) } cor(prec) # pairs(prec) + ### alpha + par(mfrow = c(1, 1)) + alpha.cols <- grep("alpha", colnames(out)) + if (length(alpha.cols) > 0) { + alpha.ord <- 1:length(alpha.cols) + ci.alpha <- apply(out[, alpha.cols], 2, quantile, c(0.025, 0.5, 0.975)) + plot(alpha.ord, ci.alpha[2, ], type = "n", + ylim = range(ci.alpha, na.rm = TRUE), ylab = "Random Effects") + PEcAn.visualization::ciEnvelope(alpha.ord, ci.alpha[1, ], ci.alpha[3, ], col = "lightBlue") + lines(alpha.ord, ci.alpha[2, ], lty = 1, lwd = 2) + abline(h = 0, lty = 2) + } par(mfrow = c(1, 1)) ### YEAR From 806512f07b2f909130bf6142d84b078378daadef Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Fri, 11 Aug 2017 07:03:29 -0700 Subject: [PATCH 285/771] tree ring doc roxygen --- modules/data.land/man/InventoryGrowthFusion.Rd | 9 +++++++-- .../data.land/man/InventoryGrowthFusionDiagnostics.Rd | 2 +- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/modules/data.land/man/InventoryGrowthFusion.Rd b/modules/data.land/man/InventoryGrowthFusion.Rd index a06c640bc58..c568e3ec3b5 100644 --- a/modules/data.land/man/InventoryGrowthFusion.Rd +++ b/modules/data.land/man/InventoryGrowthFusion.Rd @@ -5,13 +5,18 @@ \title{InventoryGrowthFusion} \usage{ InventoryGrowthFusion(data, cov.data = NULL, time_data = NULL, - n.iter = 5000, random = NULL, fixed = NULL, time_varying = NULL, - burnin_plot = FALSE, save.jags = "IGF.txt") + n.iter = 5000, n.chunk = n.iter, random = NULL, fixed = NULL, + time_varying = NULL, burnin_plot = FALSE, save.jags = "IGF.txt", + z0 = NULL, save.state = TRUE) } \arguments{ \item{data}{list of data inputs} +\item{n.chunk}{number of MCMC steps to evaluate at a time. Will only return LAST} + \item{random}{= whether or not to include random effects} + +\item{save.state}{whether or not to include inferred DBH in output (can be large)} } \value{ an mcmc.list object diff --git a/modules/data.land/man/InventoryGrowthFusionDiagnostics.Rd b/modules/data.land/man/InventoryGrowthFusionDiagnostics.Rd index 9602bb5b88b..83b022ae864 100644 --- a/modules/data.land/man/InventoryGrowthFusionDiagnostics.Rd +++ b/modules/data.land/man/InventoryGrowthFusionDiagnostics.Rd @@ -4,7 +4,7 @@ \alias{InventoryGrowthFusionDiagnostics} \title{InventoryGrowthFusionDiagnostics} \usage{ -InventoryGrowthFusionDiagnostics(jags.out, combined) +InventoryGrowthFusionDiagnostics(jags.out, combined = NULL) } \arguments{ \item{jags.out}{output mcmc.list from InventoryGrowthFusion} From d97db82f45ba1cd4e60b0d9cf3f9323a3e2470eb Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Fri, 11 Aug 2017 21:45:35 +0530 Subject: [PATCH 286/771] Minor fixes in client and server sync scripts --- web/setups/clientsyncscript.php | 14 +++++++++++--- web/setups/serversyncscript.php | 20 ++++++++++++-------- 2 files changed, 23 insertions(+), 11 deletions(-) diff --git a/web/setups/clientsyncscript.php b/web/setups/clientsyncscript.php index 169b41f6dcb..c7736d25715 100644 --- a/web/setups/clientsyncscript.php +++ b/web/setups/clientsyncscript.php @@ -33,7 +33,9 @@ // $context); // -$service_url = $server_url."/web/setups/serversyncscript.php"; +include_once '../config.php'; + +$service_url = $server_url."/pecan/setups/serversyncscript.php"; $curl = curl_init($service_url); @@ -58,13 +60,19 @@ // close curl curl_close($curl); -$decoded = json_decode($curl_response); +$decoded = json_decode($curl_response, FALSE); if (isset($decoded->status) && $decoded->status == 'ERROR') { die('error occured: ' . $decoded->errormessage); } // got wait id -var_export($decoded->waitid); + +var_dump($decoded); + +echo $decoded->wantid; + + +//var_export($decoded['waitid']); // script to handle wait id part ?> diff --git a/web/setups/serversyncscript.php b/web/setups/serversyncscript.php index a78eabd547b..9fa5152aa59 100644 --- a/web/setups/serversyncscript.php +++ b/web/setups/serversyncscript.php @@ -13,43 +13,47 @@ include_once('../common.php'); header("Content-Type: application/json"); +//header("HTTP/1.0 404 Not Found"); $client_sceret = $_POST['client_sceret']; $server_auth_token = $_POST['server_auth_token']; $fqdn = $_POST['fqdn']; +open_database(); + if (!(isset($client_sceret) && isset($server_auth_token))){ /** * token not set means client is a new one so add new data to the table and send * back the client tokens and sync id */ //add code to create new client - open_database(); $stmt = $pdo->prepare("INSERT INTO machines (id, hostname, created_at, updated_at , sync_host_id, sync_url, sync_contact, sync_start, sync_end) VALUES (, :hostname, :created_at, :updated_at , :sync_host_id, :sync_url, :sync_contact, :sync_start, :sync_end );"); if (!$stmt->execute(array(':hostname' => $fqdn, ':created_at' => date("Y-m-d"), ':updated_at' => date("Y-m-d"), - ':sync_host_id' => , - ':sync_url' =>, - ':sync_contact' =>, - ':sync_start' => , - ':sync_end' => ))) { + ':sync_host_id' => ' ', + ':sync_url' => ' ', + ':sync_contact' => ' ', + ':sync_start' => ' ', + ':sync_end' => ' ' ))) { echo json_encode(array('status' => 'ERROR', 'errormessage' => 'Invalid query : [' . error_database() . ']' . $pdo->errorInfo())); die(); } } +$stmt = $pdo->prepare("SELECT * FROM machines WHERE hostname = :hostname;",array(PDO::ATTR_CURSOR => PDO::CURSOR_FWDONLY)); -$stmt = $pdo->prepare("SELECT * FROM machines WHERE hostname = ?"); -if (!$stmt->execute(array($fqdn))) { +if (!$stmt->execute(array(':hostname' => $fqdn))) { echo json_encode(array('status' => 'ERROR', 'errormessage' => 'Invalid query : [' . error_database() . ']' . $pdo->errorInfo())); die(); } + $row = $stmt->fetch(PDO::FETCH_ASSOC); + $stmt->closeCursor(); // checking for existance and other things From e1998b2cc1d07614a83549d95dd56ad1d143d0c0 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 11 Aug 2017 15:09:51 -0700 Subject: [PATCH 287/771] Update Shiny installation docs for Ubuntu --- book_source/installation/centos.shiny.Rmd | 86 ++++++++++++++++------- 1 file changed, 60 insertions(+), 26 deletions(-) diff --git a/book_source/installation/centos.shiny.Rmd b/book_source/installation/centos.shiny.Rmd index 5d4ba4a51e4..448cd3e1004 100755 --- a/book_source/installation/centos.shiny.Rmd +++ b/book_source/installation/centos.shiny.Rmd @@ -2,31 +2,15 @@ authors - Alexey Shiklomanov - Rob Kooper -**NOTE: Instructions are only tested for CentOS 6.5.** +**NOTE: Instructions are only tested for CentOS 6.5 and Ubuntu 16.04** + **NOTE: Pretty much every step here requires root access.** ## Install the Shiny R package and Shiny server -The `shiny` R package can be installed directly in R via `install.packages("shiny")`. - -Download and install the Shiny server binary ([link](https://www.rstudio.com/products/shiny/download-server)). - -## CentOS - -``` -wget https://download3.rstudio.org/centos5.9/x86_64/shiny-server-1.4.2.786-rh5-x86_64.rpm -sudo yum install --nogpgcheck shiny-server-1.4.2.786-rh5-x86_64.rpm -``` - -## Ubuntu - -NOTE: The additional `gdebi` dependence may be optional and `dpkg` may work just fine, but I haven't tested this out. +Follow the instructions on the [Shiny download page][shiny-download] for the operating system you are using. -``` -$ sudo apt-get install gdebi-core -$ wget https://download3.rstudio.org/ubuntu-12.04/x86_64/shiny-server-1.4.2.786-amd64.deb -$ sudo gdebi shiny-server-1.4.2.786-amd64.deb -``` +[shiny-download]: https://www.rstudio.com/products/shiny/download-server/ ## Modify the shiny configuration file @@ -77,9 +61,23 @@ server { } ``` -## Set the httpd proxy +If you change the configuration, for example to add a new location, you will need to restart Shiny server. +*If you are setting up a new instance of Shiny*, skip this step and continue with the guide, since there are a few more steps to get Shiny working. +*If there is an instance of Shiny already running*, you can restart it with: -Create a file `/etc/httpd/conf.d/shiny.conf` containing the following proxy settings: +``` +sudo systemctl stop shiny-server.service +sudo systemctl start shiny-server.service +``` + +## Set the Apache proxy + +Create a file with the following name, based on the version of the operating system you are using: + +* Ubuntu 16.04 (pecan1, pecan2, test-pecan) -- `/etc/apache2/conf-available/shiny.conf` +* CentOS 6.5 (psql-pecan) -- `/etc/httpd/conf.d/shiny.conf` + +Into this file, add the following: ``` ProxyPass /shiny/ http://localhost:3838/ @@ -87,15 +85,21 @@ ProxyPassReverse /shiny/ http://localhost:3838/ RedirectMatch permanent ^/shiny$ /shiny/ ``` -## Create a symbolic link to the shiny server service +### **Ubuntu only:** Enable the new shiny configuration ``` -sudo ln -s /opt/shiny-server/config/init.d/redhat/shiny-server /etc/init.d +sudo a2enconf shiny ``` -## Start the shiny server and restart httpd +This will create a symbolic link to the newly created `shiny.conf` file inside the `/etc/apache2/conf-enabled` directory. +You can do `ls -l /etc/apache2/conf-enabled` to confirm that this worked. + +## Enable and start the shiny server, and restart apache + +### On CentOS ``` +sudo ln -s /opt/shiny-server/config/init.d/redhat/shiny-server /etc/init.d sudo service shiny-server stop sudo service shiny-server start sudo service httpd restart @@ -103,9 +107,39 @@ sudo service httpd restart You can check that Shiny is running with `service shiny-server status`. +### On Ubuntu + +Enable the Shiny server service. +This will make sure Shiny runs automatically on startup. + +``` +sudo systemctl enable shiny-server.service +``` + +Restart Apache. + +``` +sudo apachectl restart +``` + +Start the Shiny server. + +``` +sudo systemctl start shiny-server.service +``` + +If there are problems, you can stop the `shiny-server.service` with... + +``` +sudo systemctl stop shiny-server.service +``` + +...and then use `start` again to restart it. + + ## Troubleshooting -Refer to the log files for shiny (`/var/log/shiny-server.log`) and httpd (`/var/log/httpd/error-log`). +Refer to the log files for shiny (`/var/log/shiny-server.log`) and httpd (on CentOS, `/var/log/httpd/error-log`; on Ubuntu, `/var/log/apache2/error-log`). From 7df1bf9aa5f1a373b9c9158ced055f42a53390fb Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 11 Aug 2017 15:13:51 -0700 Subject: [PATCH 288/771] Minor addition to Shiny install docs Also, rename shiny installation docs file to reflect that it's not just for CentOS. --- book_source/_bookdown.yml | 2 +- book_source/installation/{centos.shiny.Rmd => shiny.Rmd} | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) rename book_source/installation/{centos.shiny.Rmd => shiny.Rmd} (97%) diff --git a/book_source/_bookdown.yml b/book_source/_bookdown.yml index 0a22e44c5ac..a626f8ce472 100644 --- a/book_source/_bookdown.yml +++ b/book_source/_bookdown.yml @@ -77,7 +77,7 @@ rmd_files: [ "installation/Installing-PEcAn-Ubuntu.Rmd", "installation/Installing-PEcAn-models.Rmd", "installation/PEcAn-in-the-Cloud.Rmd", - "installation/centos.shiny.Rmd", + "installation/shiny.Rmd", "installation/thredds.Rmd", "misc/faq.Rmd" ] diff --git a/book_source/installation/centos.shiny.Rmd b/book_source/installation/shiny.Rmd similarity index 97% rename from book_source/installation/centos.shiny.Rmd rename to book_source/installation/shiny.Rmd index 448cd3e1004..bdf5cbacc9a 100755 --- a/book_source/installation/centos.shiny.Rmd +++ b/book_source/installation/shiny.Rmd @@ -3,7 +3,6 @@ authors - Alexey Shiklomanov - Rob Kooper **NOTE: Instructions are only tested for CentOS 6.5 and Ubuntu 16.04** - **NOTE: Pretty much every step here requires root access.** ## Install the Shiny R package and Shiny server @@ -66,6 +65,11 @@ If you change the configuration, for example to add a new location, you will nee *If there is an instance of Shiny already running*, you can restart it with: ``` +## On CentOS +sudo service shiny-server stop +sudo service shiny-server start + +## On Ubuntu sudo systemctl stop shiny-server.service sudo systemctl start shiny-server.service ``` From 60a8ea7019c347aa802649150049aacec1ebec3e Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 12 Aug 2017 22:41:19 +0530 Subject: [PATCH 289/771] Added handles to hanlde the JSON reply --- web/setups/clientsyncscript.php | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/web/setups/clientsyncscript.php b/web/setups/clientsyncscript.php index c7736d25715..ee84a31256e 100644 --- a/web/setups/clientsyncscript.php +++ b/web/setups/clientsyncscript.php @@ -32,13 +32,16 @@ // false, // $context); -// include_once '../config.php'; $service_url = $server_url."/pecan/setups/serversyncscript.php"; $curl = curl_init($service_url); +//var_dump($client_sceret); +//var_dump($server_auth_token); +//var_dump($fqdn); + $curl_post_data = array ('client_sceret' => $client_sceret, 'server_auth_token' => $server_auth_token, 'fqdn' => $fqdn ); @@ -67,12 +70,27 @@ // got wait id -var_dump($decoded); +// var_dump($curl_response); +// echo '
    '; +// var_dump($decoded); -echo $decoded->wantid; +// instructions to update the client secrets +// script to handle wait id part +//echo $decoded->wantid; -//var_export($decoded['waitid']); +$tempfile = tmpfile(); +$line = $decoded->wantid; +fwrite($tempfile, $line); + +$configfile = fopen("syncflag.txt", "w+"); + +rewind($tempfile); + +while (($buffer=fgets($tempfile))!== false) { + fwrite($configfile,$buffer); +} + +fclose($tempfile); // remove tempfile -// script to handle wait id part ?> From 2790dffe7ec99ca6ac73c0a3ccd883ce57a5d4f7 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 12 Aug 2017 22:42:15 +0530 Subject: [PATCH 290/771] Added handlers to handle exceptions --- web/setups/serversyncscript.php | 91 ++++++++++++++++++++++++--------- 1 file changed, 67 insertions(+), 24 deletions(-) diff --git a/web/setups/serversyncscript.php b/web/setups/serversyncscript.php index 9fa5152aa59..5d1cf934d12 100644 --- a/web/setups/serversyncscript.php +++ b/web/setups/serversyncscript.php @@ -21,29 +21,31 @@ open_database(); -if (!(isset($client_sceret) && isset($server_auth_token))){ -/** - * token not set means client is a new one so add new data to the table and send - * back the client tokens and sync id - */ - //add code to create new client - $stmt = $pdo->prepare("INSERT - INTO machines (id, hostname, created_at, updated_at , sync_host_id, sync_url, sync_contact, sync_start, sync_end) - VALUES (, :hostname, :created_at, :updated_at , :sync_host_id, :sync_url, :sync_contact, :sync_start, :sync_end );"); - if (!$stmt->execute(array(':hostname' => $fqdn, - ':created_at' => date("Y-m-d"), - ':updated_at' => date("Y-m-d"), - ':sync_host_id' => ' ', - ':sync_url' => ' ', - ':sync_contact' => ' ', - ':sync_start' => ' ', - ':sync_end' => ' ' ))) { - echo json_encode(array('status' => 'ERROR', - 'errormessage' => 'Invalid query : [' . error_database() . ']' . $pdo->errorInfo())); - die(); - } - -} +// if ( !isset($client_sceret) && !isset($server_auth_token) && empty($client_sceret) && empty($server_auth_token)){ +// /** +// * token not set means client is a new one so add new data to the table and send +// * back the client tokens and sync id +// */ +// //add code to create new client +// $host_id = 1; +// +// $stmt = $pdo->prepare("INSERT +// INTO machines (id, hostname, created_at, updated_at , sync_host_id, sync_url, sync_contact, sync_start, sync_end) +// VALUES ( , :hostname, :created_at, :updated_at , :sync_host_id, :sync_url, :sync_contact, :sync_start, :sync_end );"); +// if (!$stmt->execute(array(':hostname' => $fqdn, +// ':created_at' => date("Y-m-d"), +// ':updated_at' => date("Y-m-d"), +// ':sync_host_id' => ' ', +// ':sync_url' => ' ', +// ':sync_contact' => ' ', +// ':sync_start' => $host_id * (10 ^ 9) , +// ':sync_end' => $host_id * (10 ^ 9) + (10 ^ 9) -1 ))) { +// echo json_encode(array('status' => 'ERROR', +// 'errormessage' => 'Invalid query : [' . error_database() . ']' . $pdo->errorInfo())); +// die(); +// } +// +// } $stmt = $pdo->prepare("SELECT * FROM machines WHERE hostname = :hostname;",array(PDO::ATTR_CURSOR => PDO::CURSOR_FWDONLY)); if (!$stmt->execute(array(':hostname' => $fqdn))) { @@ -54,12 +56,53 @@ $row = $stmt->fetch(PDO::FETCH_ASSOC); +//var_dump($row); + +if ($row == false) { + // means no data exist in database + $host_id = 25; + $id = 0; + $date = date("Y-m-d H:i:s"); + $stmt = $pdo->prepare("INSERT + INTO machines (id, hostname, created_at, updated_at , sync_host_id, sync_url, sync_contact, sync_start, sync_end) + VALUES (:id, :hostname, :created_at, :updated_at , :sync_host_id, :sync_url, :sync_contact, :sync_start, :sync_end );"); + $stmt->bindValue(':id', $id, PDO::PARAM_INT); + $stmt->bindValue(':hostname', $fqdn, PDO::PARAM_STR); + $stmt->bindValue(':created_at', $date, PDO::PARAM_STR); + $stmt->bindValue(':updated_at', $date, PDO::PARAM_STR); + $stmt->bindValue(':sync_host_id', $host_id, PDO::PARAM_INT); + $stmt->bindValue(':sync_url', ' ', PDO::PARAM_STR); + $stmt->bindValue(':sync_contact', ' ', PDO::PARAM_STR); + $stmt->bindValue(':sync_start', $host_id * (10 ^ 9), PDO::PARAM_INT); + $stmt->bindValue(':sync_end', $host_id*(10^9)+(10^9)-1, PDO::PARAM_INT); + if (!$stmt->execute()) { + echo json_encode(array('status' => 'ERROR', + 'errormessage' => 'Invalid query : [' . error_database() . ']' . $pdo->errorInfo())); + die(); + } + + $client_sceret = md5($fqdn.$date); + +} +else { + // means row details exist so verify the client authentication keys + //var_dump($row); + if ($client_sceret != md5($row['hostname'].$row['created_at'])) { + echo json_encode(array('status' => 'ERROR', + 'errormessage' => 'Invalid client_sceret')); + die(); + } + +} + $stmt->closeCursor(); // checking for existance and other things $wantid = 1; // Generate the wantid -echo json_encode(array('wantid' => $wantid)); // return the data +echo json_encode(array('status' => 'OK', + 'wantid' => $wantid, + 'client_sceret' => $client_sceret)); // return the data ?> From 101fb624dbf894971dd8c3dbdd1f812968e3171f Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sat, 12 Aug 2017 22:43:04 +0530 Subject: [PATCH 291/771] Added a small script to perform sync depening on cornjob --- web/setups/sync.php | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 web/setups/sync.php diff --git a/web/setups/sync.php b/web/setups/sync.php new file mode 100644 index 00000000000..70b6d3e0301 --- /dev/null +++ b/web/setups/sync.php @@ -0,0 +1,16 @@ + From 0138d7e53b008dfc445c585ef615e499f1d89305 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Sun, 13 Aug 2017 22:54:21 +0530 Subject: [PATCH 292/771] Front end for the report bug page added --- web/setups/feedback.php | 18 +++++++++ web/setups/submitissues.php | 81 +++++++++++++++++++++++++++++++++++++ web/setups/sync.php | 6 +++ 3 files changed, 105 insertions(+) create mode 100644 web/setups/feedback.php create mode 100644 web/setups/submitissues.php diff --git a/web/setups/feedback.php b/web/setups/feedback.php new file mode 100644 index 00000000000..8560446e554 --- /dev/null +++ b/web/setups/feedback.php @@ -0,0 +1,18 @@ + diff --git a/web/setups/submitissues.php b/web/setups/submitissues.php new file mode 100644 index 00000000000..32bef8f603d --- /dev/null +++ b/web/setups/submitissues.php @@ -0,0 +1,81 @@ + + +
    +

    Report the bug

    + +
    + +
    + +
    +
    +
    + +
    + +
    +
    +
    + +
    + +
    +
    +
    + +
    + +
    + If u don't have Github account you can create one here. +
    + +
    + +
    + +
    +
    +
    +
    + +
    +
    + +
    +
    + + diff --git a/web/setups/sync.php b/web/setups/sync.php index 70b6d3e0301..c67e05d9e58 100644 --- a/web/setups/sync.php +++ b/web/setups/sync.php @@ -11,6 +11,12 @@ // sync $outcome = NULL; +$status = NULL; + +$flagfile = fopen("syncflag.txt","r"); +$want_id = fgets ($flagfile); +fclose($flagfile); + exec('../../scripts/load.bety.sh', $outcome, $status); ?> From 9a316ee97669ce108f3473d9007124269df574eb Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Mon, 14 Aug 2017 00:34:36 +0530 Subject: [PATCH 293/771] removed unwanted codes from setups/clientsyncscript.php --- web/setups/clientsyncscript.php | 22 ---------------------- 1 file changed, 22 deletions(-) diff --git a/web/setups/clientsyncscript.php b/web/setups/clientsyncscript.php index ee84a31256e..13493c49388 100644 --- a/web/setups/clientsyncscript.php +++ b/web/setups/clientsyncscript.php @@ -10,28 +10,6 @@ // client side script -// // Create map with request parameters -// $params = array ('client_sceret' => $client_sceret, 'server_auth_token' => $server_auth_token, 'fqdn' => $fqdn ); -// -// // Build Http query using params -// $query = http_build_query ($params); -// -// // Create Http context details -// $contextData = array ( -// 'method' => 'POST', -// 'header' => "Connection: close\r\n". -// "Content-Length: ".strlen($query)."\r\n", -// 'content'=> $query ); -// -// // Create context resource for our request -// $context = stream_context_create (array ( 'http' => $contextData )); -// -// // Read page rendered as result of your POST request -// $result = file_get_contents ( -// $server_url, // page url -// false, -// $context); - include_once '../config.php'; $service_url = $server_url."/pecan/setups/serversyncscript.php"; From ba52c8177985fb32435721e3c6aeafa7be6065fb Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Mon, 14 Aug 2017 00:35:06 +0530 Subject: [PATCH 294/771] Removed unwanted code from setups/serversyncscript.php --- web/setups/serversyncscript.php | 25 ------------------------- 1 file changed, 25 deletions(-) diff --git a/web/setups/serversyncscript.php b/web/setups/serversyncscript.php index 5d1cf934d12..a6f0300e056 100644 --- a/web/setups/serversyncscript.php +++ b/web/setups/serversyncscript.php @@ -21,31 +21,6 @@ open_database(); -// if ( !isset($client_sceret) && !isset($server_auth_token) && empty($client_sceret) && empty($server_auth_token)){ -// /** -// * token not set means client is a new one so add new data to the table and send -// * back the client tokens and sync id -// */ -// //add code to create new client -// $host_id = 1; -// -// $stmt = $pdo->prepare("INSERT -// INTO machines (id, hostname, created_at, updated_at , sync_host_id, sync_url, sync_contact, sync_start, sync_end) -// VALUES ( , :hostname, :created_at, :updated_at , :sync_host_id, :sync_url, :sync_contact, :sync_start, :sync_end );"); -// if (!$stmt->execute(array(':hostname' => $fqdn, -// ':created_at' => date("Y-m-d"), -// ':updated_at' => date("Y-m-d"), -// ':sync_host_id' => ' ', -// ':sync_url' => ' ', -// ':sync_contact' => ' ', -// ':sync_start' => $host_id * (10 ^ 9) , -// ':sync_end' => $host_id * (10 ^ 9) + (10 ^ 9) -1 ))) { -// echo json_encode(array('status' => 'ERROR', -// 'errormessage' => 'Invalid query : [' . error_database() . ']' . $pdo->errorInfo())); -// die(); -// } -// -// } $stmt = $pdo->prepare("SELECT * FROM machines WHERE hostname = :hostname;",array(PDO::ATTR_CURSOR => PDO::CURSOR_FWDONLY)); if (!$stmt->execute(array(':hostname' => $fqdn))) { From 9e0c68c6f874fb2f7090db84ed7dfa1eec339c48 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Mon, 14 Aug 2017 00:42:03 +0530 Subject: [PATCH 295/771] Added a page to assist in reporting the bugs --- web/setups/submitissues.php | 101 +++++++++++++++++++++++++++++++++--- 1 file changed, 93 insertions(+), 8 deletions(-) diff --git a/web/setups/submitissues.php b/web/setups/submitissues.php index 32bef8f603d..39aaee5acc6 100644 --- a/web/setups/submitissues.php +++ b/web/setups/submitissues.php @@ -10,25 +10,94 @@ // bug reporting page page +$title = $_POST['title']; +$description = $_POST['description']; +$username = $_POST['username']; +$password = $_POST['password']; - +//flags +$isCurlFailed = FALSE; include 'page.template.php'; +echo "

    Report the bug

    "; + +if (isset($title) && !empty($title) && + isset($description) && !empty($description) && + isset($username) && !empty($username) && + isset($password) && !empty($password)) { + + $service_url = "https://api.github.com/repos/PecanProject/pecan/issues"; + + $user_agent = "Pecan-application"; + $curl = curl_init($service_url); + + $curl_post_data = array ('title' => $title, + 'body' => $description, + 'lables' => 'Bug' ); + + $data_string = json_encode($curl_post_data); + + // setting curl to do a POST request + curl_setopt($curl, CURLOPT_USERPWD, $username.":".$password); // authentication + curl_setopt($curl, CURLOPT_USERAGENT, $user_agent); + curl_setopt($curl, CURLOPT_RETURNTRANSFER, true); + curl_setopt($curl, CURLOPT_POST, true); + curl_setopt($curl, CURLOPT_POSTFIELDS, $data_string); + curl_setopt($curl, CURLOPT_HTTPHEADER, array( + 'Content-Type: application/json', + 'Content-Length: ' . strlen($data_string)) + ); + + // execute the curl request + $curl_response = curl_exec($curl); + + $decode = json_decode($curl_response); + + //var_dump($decode); + if (curl_getinfo ($curl, CURLINFO_HTTP_CODE) == 201) + { +// Generate tha page to inform the user ?> + + -
    -

    Report the bug

    + + + + + + + +

    All fields are important

    - +
    + + + Title Needed + +
    - +
    + + + Description Needed + +
    @@ -54,14 +128,24 @@
    - If u don't have Github account you can create one here. + If u don't have Github account you can create one here + + + Github Username / Email is must + +
    -
    + + + Github password is must + + +
    @@ -76,6 +160,7 @@ From 41fc17d54087d95f7b2f7f65d3bcd41f6870e37b Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Mon, 14 Aug 2017 00:42:44 +0530 Subject: [PATCH 296/771] updated the report bug url in setups/page.template.php --- web/setups/page.template.php | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/web/setups/page.template.php b/web/setups/page.template.php index f3fc4be1564..9abe180a4e8 100644 --- a/web/setups/page.template.php +++ b/web/setups/page.template.php @@ -56,7 +56,7 @@
    Chat Room
    - Bug Report + Bug Report

    From de9d1a3f6461660f0477d055f89c95f44acf565a Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Mon, 14 Aug 2017 01:10:29 +0530 Subject: [PATCH 297/771] Added alert in setups/add.php --- web/setups/add.php | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/web/setups/add.php b/web/setups/add.php index cc3b6823059..77dd2689969 100644 --- a/web/setups/add.php +++ b/web/setups/add.php @@ -44,7 +44,7 @@ include 'page.template.php'; ?>

    Configuration details

    -

    Configuration Sucessfully updated

    + From 808b8497a8c77a101f8713996c9f71aa1c821e8e Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Mon, 14 Aug 2017 05:10:08 -0500 Subject: [PATCH 298/771] Call to align data --- db/R/query.dplyr.R | 2 +- shiny/workflowPlot/server.R | 43 +++++++++++++++++-------------------- 2 files changed, 21 insertions(+), 24 deletions(-) diff --git a/db/R/query.dplyr.R b/db/R/query.dplyr.R index 7fdcb5715b6..f392886efce 100644 --- a/db/R/query.dplyr.R +++ b/db/R/query.dplyr.R @@ -269,7 +269,7 @@ load_data_single_run <- function(bety, workflow_id,run_id) { y <- ncdf4::ncvar_get(nc, var_name) b <- !is.na(x) & !is.na(y) & sw != 0 dates <- if(is.na(dates)) x[b] else c(dates, x[b]) - dates <- as.Date(dates) + dates <- as.POSIXct(dates) vals <- if(is.na(vals)) y[b] else c(vals, y[b]) xlab <- "Time" # Values of the data which we will plot diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index e73164c9cfd..5d055abc74f 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -110,6 +110,7 @@ server <- shinyServer(function(input, output, session) { # site<-PEcAn.DB::query.site(site.id,bety$con) start.year <- as.numeric(lubridate::year(inputs_df$start_date)) end.year <- as.numeric(lubridate::year(inputs_df$end_date)) + # File_path <- inputs_df$filePath File_path <- paste0(inputs_df$filePath,'.csv') site.id <- inputs_df$site_id site<-PEcAn.DB::query.site(site.id,bety$con) @@ -146,9 +147,7 @@ server <- shinyServer(function(input, output, session) { }) # Get input id from selected site id getInputs <- function(bety,site_Id){ - # site_Id <- c(772) # inputIds <- tbl(bety, 'inputs') %>% filter(site_id %in% site_Id) %>% distinct(id) %>% pull(id) - # inputIds <- sort(inputIds) my_hostname <- PEcAn.utils::fqdn() my_machine_id <- tbl(bety, 'machines') %>% filter(hostname == my_hostname) %>% pull(id) inputs_df <- tbl(bety, 'dbfiles') %>% @@ -157,11 +156,11 @@ server <- shinyServer(function(input, output, session) { collect() inputs_df <- inputs_df[order(inputs_df$container_id),] inputs_df <- inputs_df %>% - mutate(input_selection_list = paste(inputs_df$container_id, inputs_df$name), + dplyr::mutate(input_selection_list = paste(inputs_df$container_id, inputs_df$name), filePath = paste0(inputs_df$file_path,'/', inputs_df$file_name)) %>% - dplyr::select(container_id,filePath,input_selection_list,start_date,end_date,site_id,name, + dplyr::select(input_id = container_id,filePath,input_selection_list,start_date,end_date,site_id,name, machine_id,file_name,file_path) - colnames(inputs_df)[1] <- 'input_id' + # colnames(inputs_df)[1] <- 'input_id' return(inputs_df) } observe({ @@ -209,7 +208,7 @@ server <- shinyServer(function(input, output, session) { plt <- plt + geom_line() } ) - plt <- plt + labs(title=title, x=xlab, y=ylab) + geom_smooth(n=input$smooth_n) + # model_geom <- switch(input$model_geom, point = geom_point, line = geom_line) # Check if user wants to load external data # Similar to using event reactive if (input$load_data>0) { @@ -217,27 +216,24 @@ server <- shinyServer(function(input, output, session) { # File_format <- getFileFormat(bety,input$formatID) # Input ID is of the form (ID Name). Split by space and use the first element inputs_df <- getInputs(bety,c(input$all_site_id)) - # output$info <- renderText({ - # paste0(nrow(inputs_df)) - # }) - inputs_df <- inputs_df %>% filter(input_selection_list == input$all_input_id) - # output$info1 <- renderText({ - # paste0(nrow(inputs_df)) - # }) - # input_id <- strsplit(input$all_input_id,' ')[[1]][1] - # File_format <- getFileFormat(bety,input_id) - # ids_DF <- parse_ids_from_input_runID(input$all_run_id) - # settings <- getSettingsFromWorkflowId(bety,ids_DF$wID[1]) - # filePath <- PEcAn.DB::dbfile.file(type = 'Input', id = input_ID,con = bety$con) - # externalData <- loadObservationData(bety,settings,filePath,File_format) + inputs_df <- inputs_df %>% dplyr::filter(input_selection_list == input$all_input_id) externalData <- loadObservationData(bety,inputs_df) # If variable found in the uploaded file if (input$variable_name %in% names(externalData)){ - externalData <- externalData %>% dplyr::select(posix,dplyr::one_of(input$variable_name)) - names(externalData) <- c("dates","vals") - externalData$dates <- as.Date(externalData$dates) + # externalData <- externalData %>% dplyr::select(posix,dplyr::one_of(input$variable_name)) + # names(externalData) <- c("dates","vals") + # externalData$dates <- as.Date(externalData$dates) + var = input$variable_name + df = df %>% select(posix = dates, var = vals) + colnames(df)[2]<-paste0(var) + aligned_data = PEcAn.benchmark::align_data(model.calc = df, obvs.calc = externalData, var =var, align_method = "match_timestep") + colnames(aligned_data) <- c("model","observations","Date") + aligned_data <- melt(aligned_data, "Date") + # plot(aligned_dat$NEE.m, aligned_dat$NEE.o) + # abline(0,1,col="red") ## intercept=0, slope=1 data_geom <- switch(input$data_geom, point = geom_point, line = geom_line) - plt <- plt + data_geom(data = externalData,aes(x=dates, y=vals),color='black', linetype = 'dashed') + plt <- ggplot(aligned_data, aes(x=Date, y=value, color=variable)) + data_geom() + # plt <- plt + data_geom(data = externalData,aes(x=dates, y=vals),color='black', linetype = 'dashed') output$outputNoVariableFound <- renderText({ paste0("Plotting data outputs in black") }) @@ -249,6 +245,7 @@ server <- shinyServer(function(input, output, session) { }) } } + plt <- plt + labs(title=title, x=xlab, y=ylab) + geom_smooth(n=input$smooth_n) # Earlier smoothing and y labels # geom_smooth(aes(fill = "Spline fit")) + # scale_y_continuous(labels=fancy_scientific) + From 5b9bea77d15b8adc6c90a5fe3dac9570f9eb6937 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 14 Aug 2017 18:05:21 -0400 Subject: [PATCH 299/771] check to change stat=0 to stat=na --- modules/meta.analysis/R/jagify.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/modules/meta.analysis/R/jagify.R b/modules/meta.analysis/R/jagify.R index f4fabdf47c9..8f4faa61d85 100644 --- a/modules/meta.analysis/R/jagify.R +++ b/modules/meta.analysis/R/jagify.R @@ -60,6 +60,9 @@ jagify <- function(result) { ##' ##' @return A data frame NAs sensibly replaced transform.nas <- function(data) { + #set stat to NA if 0 (uncertainties can only asymptotically approach 0) + data$stat[data$stat == 0] <- NA + # control defaults to 1 data$control[is.na(data$control)] <- 1 From 251352b46e69e22b241982af752625bd22b6b833 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Tue, 15 Aug 2017 12:40:25 -0400 Subject: [PATCH 300/771] GEO branch of dendro code --- modules/data.land/R/InventoryGrowthFusion.R | 23 ++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index f7f35e07fba..a159744fe09 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -291,7 +291,7 @@ model{ ## check for interaction terms it_vars <- t_vars[grep(pattern = "*",x=t_vars,fixed = TRUE)] if(length(it_vars) > 0){ - t_vars <- t_vars[!(t_vars == it_vars)] + t_vars <- t_vars[!(t_vars %in% it_vars)] } ## INTERACTIONS WITH TIME-VARYING VARS @@ -393,7 +393,8 @@ model{ tau_dbh = 1, tau_inc = 1500, tau_ind = 50, - tau_yr = 100, + tau_yr = 100, + betaX2 = 0, ind = rep(0, data$ni), year = rep(0, data$nt)) } @@ -403,9 +404,9 @@ model{ j.model <- jags.model(file = textConnection(TreeDataFusionMV), data = data, inits = init, n.chains = 3) PEcAn.utils::logger.info("BURN IN") - jags.out <- coda.samples(model = j.model, - variable.names = burnin.variables, - n.iter = min(n.iter, 2000)) + # jags.out <- coda.samples(model = j.model, + # variable.names = burnin.variables, + # n.iter = min(n.iter, 2000)) if (burnin_plot) { plot(jags.out) } @@ -413,12 +414,20 @@ model{ PEcAn.utils::logger.info("RUN MCMC") load.module("dic") for(k in seq_len(ceiling(n.iter/n.chunk))){ - jags.out <- coda.samples(model = j.model, variable.names = out.variables, n.iter = n.chunk) + if(k%%50 == 0){ + vnames <- c("x",out.variables) ## save x periodically + } else { + vnames <- out.variables + } + jags.out <- coda.samples(model = j.model, variable.names = vnames, n.iter = n.chunk) + ofile <- paste("IGF",model,k,"RData",sep=".") + print(ofile) + save(jags.out,file=ofile) ## could add code here to check for convergence and break from loop early D <- as.mcmc.list(lapply(jags.out,function(x){x[,'deviance']})) gbr <- coda::gelman.diag(D)$psrf[1,1] trend <- mean(sapply(D,function(x){coef(lm(x~seq_len(n.chunk)))[2]})) - if(gbr < 1.01 & abs(trend) < 0.05) break + if(gbr < 1.005 & abs(trend) < 0.5) break } return(jags.out) } # InventoryGrowthFusion From 327814fa308dcfbadf0fad15495b35b6eccdd42f Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Tue, 15 Aug 2017 14:30:53 -0400 Subject: [PATCH 301/771] tree ring: adding extra parms for burn-in & restart; updating save.state to allow setting of periodicity. Reindent code --- modules/data.land/R/InventoryGrowthFusion.R | 108 +++++++++++--------- 1 file changed, 60 insertions(+), 48 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index a159744fe09..2041280e25a 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -6,17 +6,20 @@ ##' @param data list of data inputs ##' @param random = whether or not to include random effects ##' @param n.chunk number of MCMC steps to evaluate at a time. Will only return LAST -##' @param save.state whether or not to include inferred DBH in output (can be large) +##' @param n.burn number of steps to automatically discard as burn-in +##' @param save.state whether or not to include inferred DBH in output (can be large). Enter numeric value to save.state periodically (in terms of n.chunk) +##' @param restart final mcmc.list from previous execution. NULL for new run. TRUE to save final state for new run. ##' @note Requires JAGS ##' @return an mcmc.list object ##' @export -InventoryGrowthFusion <- function(data, cov.data=NULL, time_data = NULL, n.iter=5000, n.chunk = n.iter, random = NULL, fixed = NULL,time_varying=NULL, burnin_plot = FALSE, save.jags = "IGF.txt", z0 = NULL, save.state=TRUE) { +InventoryGrowthFusion <- function(data, cov.data=NULL, time_data = NULL, n.iter=5000, n.chunk = n.iter, n.burn = min(n.chunk, 2000), random = NULL, fixed = NULL,time_varying=NULL, burnin_plot = FALSE, save.jags = "IGF.txt", z0 = NULL, save.state=TRUE,restart = NULL) { library(rjags) # baseline variables to monitor burnin.variables <- c("tau_add", "tau_dbh", "tau_inc", "mu") # process variability, dbh and tree-ring observation error, intercept out.variables <- c("deviance", "tau_add", "tau_dbh", "tau_inc", "mu") - if(save.state) out.variables <- c(out.variables,"x") + # if(save.state) out.variables <- c(out.variables,"x") + if(!exists("model")) model = 0 # start text object that will be manipulated (to build different linear models, swap in/out covariates) TreeDataFusionMV <- " @@ -127,7 +130,7 @@ model{ TreeDataFusionMV <- sub(pattern = "## RANDOM EFFECT TAUS", Rpriors, TreeDataFusionMV) TreeDataFusionMV <- gsub(pattern = "## RANDOM_EFFECTS", Reffects, TreeDataFusionMV) } ### END RANDOM EFFECTS - + ######################################################################## ### ### FIXED EFFECTS @@ -177,36 +180,36 @@ model{ myIndex <- "[i]" covX <- strsplit(X.terms[i],"*",fixed=TRUE)[[1]] covX <- covX[-which(toupper(covX)=="X")] ## remove X from terms + + ##is covariate fixed or time varying? + tvar <- length(grep("[t]",covX,fixed=TRUE)) > 0 + if(tvar){ + covX <- sub("[t]","",covX,fixed = TRUE) + if(!(covX %in% names(data))){ + ## add cov variables to data object + data[[covX]] <- time_data[[covX]] + } + if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at covX",names(data))} - ##is covariate fixed or time varying? - tvar <- length(grep("[t]",covX,fixed=TRUE)) > 0 - if(tvar){ - covX <- sub("[t]","",covX,fixed = TRUE) + myIndex <- "[i,t]" + } else { + ## variable is fixed + if(covX %in% colnames(cov.data)){ ## covariate present if(!(covX %in% names(data))){ ## add cov variables to data object - data[[covX]] <- time_data[[covX]] + data[[covX]] <- cov.data[,covX] } - if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at covX",names(data))} - - myIndex <- "[i,t]" + if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at covX2",names(data))} } else { - ## variable is fixed - if(covX %in% colnames(cov.data)){ ## covariate present - if(!(covX %in% names(data))){ - ## add cov variables to data object - data[[covX]] <- cov.data[,covX] - } - if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at covX2",names(data))} - } else { - ## covariate absent - print("covariate absent from covariate data:", covX) - } - - } ## end fixed or time varying + ## covariate absent + print("covariate absent from covariate data:", covX) + } - myBeta <- paste0("betaX_",covX) - Xformula <- paste0(myBeta,"*x[i,t-1]*",covX,myIndex) - + } ## end fixed or time varying + + myBeta <- paste0("betaX_",covX) + Xformula <- paste0(myBeta,"*x[i,t-1]*",covX,myIndex) + } else if(length(grep("^",X.terms[i],fixed=TRUE))==1){ ## POLYNOMIAL powX <- strsplit(X.terms[i],"^",fixed=TRUE)[[1]] powX <- powX[-which(toupper(powX)=="X")] ## remove X from terms @@ -220,20 +223,20 @@ model{ ## add variables to Pformula Pformula <- paste(Pformula,"+",Xformula) - + ## add priors Xpriors <- paste(Xpriors," ",myBeta,"~dnorm(0,0.001)\n") - + ## add to out.variables out.variables <- c(out.variables, myBeta) } ## END LOOP OVER X TERMS - + ## create priors TreeDataFusionMV <- sub(pattern = "## ENDOGENOUS BETAS", Xpriors, TreeDataFusionMV) } ## end processing of X terms - + ## build design matrix from formula Xf <- with(cov.data, model.matrix(formula(fixed))) Xf.cols <- colnames(Xf) @@ -264,7 +267,7 @@ model{ data[["Xf"]] <- Xf out.variables <- c(out.variables, paste0("beta", Xf.names)) } - + if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at Xf",names(data))} ######################################################################## @@ -298,7 +301,7 @@ model{ ## TODO: deal with interactions with catagorical variables ## need to create new data matrices on the fly for(i in seq_along(it_vars)){ - + ##is covariate fixed or time varying? covX <- strsplit(it_vars[i],"*",fixed=TRUE)[[1]] tvar <- length(grep("[t]",covX[1],fixed=TRUE)) > 0 @@ -353,18 +356,18 @@ model{ ## append to process model formula Pformula <- paste(Pformula, paste0("+ beta", tvar, "*",tvar,"[i,t]")) - + ## add to list of varibles JAGS is tracking out.variables <- c(out.variables, paste0("beta", tvar)) } ## build prior Xt.priors <- paste0(Xt.priors, paste0(" beta", t_vars, "~dnorm(0,0.001)", collapse = "\n") - ) + ) TreeDataFusionMV <- sub(pattern = "## TIME VARYING BETAS", Xt.priors, TreeDataFusionMV) } ## END time varying covariates - + ## insert process model into JAGS template if (!is.null(Pformula)) { @@ -399,25 +402,27 @@ model{ year = rep(0, data$nt)) } - + PEcAn.utils::logger.info("COMPILE JAGS MODEL") j.model <- jags.model(file = textConnection(TreeDataFusionMV), data = data, inits = init, n.chains = 3) - - PEcAn.utils::logger.info("BURN IN") - # jags.out <- coda.samples(model = j.model, - # variable.names = burnin.variables, - # n.iter = min(n.iter, 2000)) - if (burnin_plot) { - plot(jags.out) + + if(n.burn > 0){ + PEcAn.utils::logger.info("BURN IN") + jags.out <- coda.samples(model = j.model, + variable.names = burnin.variables, + n.iter = n.burn) + if (burnin_plot) { + plot(jags.out) + } } PEcAn.utils::logger.info("RUN MCMC") load.module("dic") for(k in seq_len(ceiling(n.iter/n.chunk))){ - if(k%%50 == 0){ - vnames <- c("x",out.variables) ## save x periodically + if(as.logical(save.state) & k%%as.numeric(save.state) == 0){ + vnames <- c("x",out.variables) ## save x periodically } else { - vnames <- out.variables + vnames <- out.variables } jags.out <- coda.samples(model = j.model, variable.names = vnames, n.iter = n.chunk) ofile <- paste("IGF",model,k,"RData",sep=".") @@ -429,6 +434,13 @@ model{ trend <- mean(sapply(D,function(x){coef(lm(x~seq_len(n.chunk)))[2]})) if(gbr < 1.005 & abs(trend) < 0.5) break } + + ## get final state + if(!is.null(restart) & (as.logical(restart) || is.mcmc.list(restart))){ + ofile <- paste("IGF",model,"RESTART.RData",sep=".") + jags.final <- coda.samples(model = j.model, variable.names = c("x",out.variables), n.iter = 1) + save(jags.final,file=ofile) + } return(jags.out) } # InventoryGrowthFusion From 58a970aa222e4237d4a470446eb5a830a679062b Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Tue, 15 Aug 2017 14:35:50 -0400 Subject: [PATCH 302/771] tree ring: compartmentalize check for duplicated data --- modules/data.land/R/InventoryGrowthFusion.R | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index 2041280e25a..a278535304e 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -21,6 +21,9 @@ InventoryGrowthFusion <- function(data, cov.data=NULL, time_data = NULL, n.iter= # if(save.state) out.variables <- c(out.variables,"x") if(!exists("model")) model = 0 + check.dup.data <- function(data,loc){ + if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at",loc,names(data))} + } # start text object that will be manipulated (to build different linear models, swap in/out covariates) TreeDataFusionMV <- " model{ @@ -104,8 +107,7 @@ model{ data[[length(data)+1]] <- as.numeric(as.factor(as.character(cov.data[,r_var[j]]))) ## multiple conversions to eliminate gaps names(data)[length(data)] <- r_var[j] } - if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at r_var",names(data))} - + check.dup.data(data,"r_var") nr[j] <- max(as.numeric(data[[r_var[j]]])) } index <- paste0("[",index,"]") @@ -189,8 +191,8 @@ model{ ## add cov variables to data object data[[covX]] <- time_data[[covX]] } - if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at covX",names(data))} - + check.dup.data(data,"covX") + myIndex <- "[i,t]" } else { ## variable is fixed @@ -199,7 +201,8 @@ model{ ## add cov variables to data object data[[covX]] <- cov.data[,covX] } - if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at covX2",names(data))} + check.dup.data(data,"covX2") + } else { ## covariate absent print("covariate absent from covariate data:", covX) @@ -268,8 +271,8 @@ model{ out.variables <- c(out.variables, paste0("beta", Xf.names)) } - if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at Xf",names(data))} - + check.dup.data(data,"Xf") + ######################################################################## ### ### TIME-VARYING @@ -351,8 +354,8 @@ model{ ## add cov variables to data object data[[tvar]] <- time_data[[tvar]] } - if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at tvar",names(data))} - + check.dup.data(data,"tvar") + ## append to process model formula Pformula <- paste(Pformula, paste0("+ beta", tvar, "*",tvar,"[i,t]")) From bc9b79cf6958adfed2845b94b689bfce6040ad3b Mon Sep 17 00:00:00 2001 From: Rob Kooper Date: Tue, 15 Aug 2017 12:13:24 -0700 Subject: [PATCH 303/771] fix for #1545 --- web/dataset.php | 144 ++++++++++++++++++++++++++---------------------- 1 file changed, 79 insertions(+), 65 deletions(-) diff --git a/web/dataset.php b/web/dataset.php index 5b15a6646df..bbeaab310b0 100644 --- a/web/dataset.php +++ b/web/dataset.php @@ -12,11 +12,11 @@ require("common.php"); open_database(); if ($authentication) { - if (!check_login()) { - close_database(); - header('HTTP/1.1 403 Unauthorized'); - exit; - } + if (!check_login()) { + close_database(); + header('HTTP/1.1 403 Unauthorized'); + exit; + } if (get_page_acccess_level() > $min_run_level) { header( "Location: history.php"); close_database(); @@ -46,73 +46,87 @@ // return dataset switch ($type) { - case "file": - if (!isset($_REQUEST['name'])) { - die("Need name."); - } - $name = $_REQUEST['name']; - - $file = canonicalize("$folder/$name"); - if (substr($file, 0, strlen($folder)) != $folder) { - die("Invalid file name specified."); - } - - if (substr($name, -4) === ".xml") { - $mime = "text/xml"; - } else if (substr($name, -4) === ".txt") { - $mime = "text/plain"; - } else if (substr($name, -4) === ".log") { - $mime = "text/plain"; - } else if (substr($name, -4) === ".pdf") { - $mime = "application/pdf"; - } else { - $mime = "application/octet-stream"; - } - break; - - case "plot": - if (!isset($_REQUEST['run'])) { - die("Need run."); - } - $run=$_REQUEST['run']; - if (!isset($_REQUEST['year']) || !is_numeric($_REQUEST['year'])) { - die("Need year."); - } - $year=$_REQUEST['year']; - if (!isset($_REQUEST['xvar'])) { - die("Need xvar."); - } - $xvar=$_REQUEST['xvar']; - if (!isset($_REQUEST['yvar'])) { - die("Need yvar."); - } - $yvar=$_REQUEST['yvar']; - $datafile=$folder . "/out/" . $run . "/" . $year . ".nc"; - $width=600; - if (isset($_REQUEST['width']) && ($_REQUEST['width'] > $width)) { - $width=$_REQUEST['width']; - } - $height=400; - if (isset($_REQUEST['height']) && ($_REQUEST['height'] > $height)) { - $height=$_REQUEST['height']; - } - $mime = "image/png"; - $file = tempnam(sys_get_temp_dir(),'plot') . ".png"; - shell_exec("R_LIBS_USER='${R_library_path}' PECANSETTINGS='$folder/pecan.xml' ${Rbinary} CMD BATCH --vanilla '--args $datafile $year $xvar $yvar $width $height $file' plot.netcdf.R /tmp/plot.out"); - break; - - default: - die("unknown type."); + case "file": + if (!isset($_REQUEST['name'])) { + die("Need name."); + } + $name = $_REQUEST['name']; + + $file = canonicalize("$folder/$name"); + if (substr($file, 0, strlen($folder)) != $folder) { + die("Invalid file name specified."); + } + + if (substr($name, -4) === ".xml") { + $mime = "text/xml"; + } else if (substr($name, -4) === ".txt") { + $mime = "text/plain"; + } else if (substr($name, -4) === ".log") { + $mime = "text/plain"; + } else if (substr($name, -4) === ".pdf") { + $mime = "application/pdf"; + } else { + $mime = "application/octet-stream"; + } + break; + + case "plot": + if (!isset($_REQUEST['run'])) { + die("Need run."); + } + $run = $_REQUEST['run']; + if (!isset($_REQUEST['year']) || !is_numeric($_REQUEST['year'])) { + die("Need year."); + } + $year = $_REQUEST['year']; + if (!isset($_REQUEST['xvar'])) { + die("Need xvar."); + } + $xvar = $_REQUEST['xvar']; + if (!isset($_REQUEST['yvar'])) { + die("Need yvar."); + } + $yvar = $_REQUEST['yvar']; + $width = 600; + if (isset($_REQUEST['width']) && ($_REQUEST['width'] > $width)) { + $width = $_REQUEST['width']; + } + $height = 400; + if (isset($_REQUEST['height']) && ($_REQUEST['height'] > $height)) { + $height = $_REQUEST['height']; + } + $datafile = $folder . "/out/" . $run . "/" . $year . ".nc"; + $mime = "image/png"; + $file = tempnam(sys_get_temp_dir(),'plot') . ".png"; + if (!file_exists($datafile)) { + die("Invalid file name specified ${file}."); + } + + # make sure everything is shell safe + $datafile = escapeshellarg($datafile); + $year = escapeshellarg($year); + $xvar = escapeshellarg($xvar); + $yvar = escapeshellarg($yvar); + $width = escapeshellarg($width); + $height = escapeshellarg($height); + $escfile = escapeshellarg($file); + + # execute command to create graph + shell_exec("R_LIBS_USER='${R_library_path}' PECANSETTINGS='$folder/pecan.xml' ${Rbinary} CMD BATCH --vanilla '--args $datafile $year $xvar $yvar $width $height $escfile' plot.netcdf.R /tmp/plot.out"); + break; + + default: + die("unknown type."); } if (!file_exists($file)) { - die("Invalid file name specified ${file}."); + die("Invalid file name specified ${file}."); } if ($mime != "") { - header("Content-type: $mime"); + header("Content-type: $mime"); } if (isset($name)) { - header('Content-Disposition: filename='.basename($name)); + header('Content-Disposition: filename='.basename($name)); } readfile($file); From de9e533a8637ab611b22110d7f2f59c153af5e13 Mon Sep 17 00:00:00 2001 From: Rob Kooper Date: Tue, 15 Aug 2017 12:15:01 -0700 Subject: [PATCH 304/771] update CHANGELOG --- CHANGELOG.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index db3ebf81444..06cdc327c2e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,9 @@ For more information about this file see also [Keep a Changelog](http://keepacha ## [Unreleased] +### Fixes +- Fixed remote code execution #1545 + ## [1.5.10] - Prerelease ### Added - Added PEcAn.utils::download.file() to allow for use of alternative FTP programs From 4f3e289f867b98246f20ef0699813ec666473519 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 15 Aug 2017 16:20:10 -0400 Subject: [PATCH 305/771] Add check for na years --- utils/R/read.output.R | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/utils/R/read.output.R b/utils/R/read.output.R index b615b79c1db..49ba7076f2e 100644 --- a/utils/R/read.output.R +++ b/utils/R/read.output.R @@ -100,10 +100,17 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables # create list of *.nc years nc.years <- as.vector(unlist(strsplit(list.files(path = outdir, pattern = "\\.nc$", full.names = FALSE), ".nc"))) - # select only those *.nc years requested by user - keep <- which(nc.years >= as.numeric(start.year) & nc.years <= as.numeric(end.year)) ncfiles <- list.files(path = outdir, pattern = "\\.nc$", full.names = TRUE) - ncfiles <- ncfiles[keep] + + if(!is.na(start.year) && !is.na(end.year)){ + # select only those *.nc years requested by user + keep <- which(nc.years >= as.numeric(start.year) & nc.years <= as.numeric(end.year)) + ncfiles <- ncfiles[keep] + } else if(length(nc.years) != 0){ + start.year <- min(nc.years) + end.year <- max(nc.years) + } + # throw error if no *.nc files selected/availible nofiles <- FALSE if (length(ncfiles) == 0) { From 4ecfd7c164735ff3b46e35c11822648d0f762e85 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 15 Aug 2017 16:28:33 -0400 Subject: [PATCH 306/771] Adjust logger messages --- utils/R/read.output.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/utils/R/read.output.R b/utils/R/read.output.R index 49ba7076f2e..d545b324238 100644 --- a/utils/R/read.output.R +++ b/utils/R/read.output.R @@ -107,6 +107,7 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables keep <- which(nc.years >= as.numeric(start.year) & nc.years <= as.numeric(end.year)) ncfiles <- ncfiles[keep] } else if(length(nc.years) != 0){ + PEcAn.utils::logger.info("No start or end year provided; reading output for all years") start.year <- min(nc.years) end.year <- max(nc.years) } @@ -115,7 +116,7 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables nofiles <- FALSE if (length(ncfiles) == 0) { logger.warn("read.output: no netCDF files of model output present for runid = ", - runid, " in ", outdir, "will return NA") + runid, " in ", outdir, " for years requested; will return NA") if (length(nc.years) > 0) { logger.info("netCDF files for other years present", nc.years) } From bcaaf0eca11e73ce1c1ca04f6fbabdc802f832f5 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Tue, 15 Aug 2017 16:38:02 -0400 Subject: [PATCH 307/771] tree-ring: make doc --- modules/data.land/man/InventoryGrowthFusion.Rd | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/modules/data.land/man/InventoryGrowthFusion.Rd b/modules/data.land/man/InventoryGrowthFusion.Rd index c568e3ec3b5..50072da50f3 100644 --- a/modules/data.land/man/InventoryGrowthFusion.Rd +++ b/modules/data.land/man/InventoryGrowthFusion.Rd @@ -5,18 +5,22 @@ \title{InventoryGrowthFusion} \usage{ InventoryGrowthFusion(data, cov.data = NULL, time_data = NULL, - n.iter = 5000, n.chunk = n.iter, random = NULL, fixed = NULL, - time_varying = NULL, burnin_plot = FALSE, save.jags = "IGF.txt", - z0 = NULL, save.state = TRUE) + n.iter = 5000, n.chunk = n.iter, n.burn = min(n.chunk, 2000), + random = NULL, fixed = NULL, time_varying = NULL, burnin_plot = FALSE, + save.jags = "IGF.txt", z0 = NULL, save.state = TRUE, restart = NULL) } \arguments{ \item{data}{list of data inputs} \item{n.chunk}{number of MCMC steps to evaluate at a time. Will only return LAST} +\item{n.burn}{number of steps to automatically discard as burn-in} + \item{random}{= whether or not to include random effects} -\item{save.state}{whether or not to include inferred DBH in output (can be large)} +\item{save.state}{whether or not to include inferred DBH in output (can be large). Enter numeric value to save.state periodically (in terms of n.chunk)} + +\item{restart}{final mcmc.list from previous execution. NULL for new run. TRUE to save final state for new run.} } \value{ an mcmc.list object From 584b0d008f405e7ca919fac15f9418bedf2492c2 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 15 Aug 2017 20:46:06 -0400 Subject: [PATCH 308/771] Simplification of script and inclusion of unix 'wget' download --- modules/data.land/R/dataone_download.R | 42 +++++++++++--------------- 1 file changed, 17 insertions(+), 25 deletions(-) diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index 4687e19618c..91111297c43 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -1,7 +1,7 @@ #' DataONE download #' #' @param id "The identifier of a package, package metadata or other package member" -- dataone r -#' @param destdir Name the file that will be created to store the data. +#' @param username used to create a user-specific destdir #' @param CNode #' @param lazyLoad "A logical value. If TRUE, then only package member system metadata is downloaded and not data. The default is FALSE." -- dataone R #' @param quiet "A 'logical'. If TRUE (the default) then informational messages will not be printed." -- dataone R @@ -11,8 +11,8 @@ #' #' @export #' -#' @examples doi_download(id = doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87, destdir = LTER) -doi_download = function(id, destdir = "MyDataFile", CNode = "PROD", lazyLoad = FALSE, quiet = F){ +#' @examples doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", username = "Guest") +dataone_download = function(id, username, CNode = "PROD", lazyLoad = FALSE, quiet = F){ ### automatically retrieve mnId cn <- dataone::CNode(CNode) locations <- dataone::resolve(cn, pid = id) @@ -23,32 +23,24 @@ doi_download = function(id, destdir = "MyDataFile", CNode = "PROD", lazyLoad = F pkg <- dataone::getDataPackage(d1c, id = id, lazyLoad = lazyLoad, quiet = quiet, limit = "1MB") # what is the standard limit for pecan downloads? files <- datapack::getValue(pkg, name="sysmeta@formatId") n <- length(files) # number of files - ### create a list containing a readable version of the formats - formats <- list() - # add more formats as we come across them - for(i in 1:n){ - if(files[[i]] == "text/csv"){ - formats[i] <- ".csv" - - }else if(files[[i]] == "text/xml"){ - formats[i] <- ".xml" - - }else{ - formats[i] <- ".xml" # this is for the unknown type... Not sure if this is a universal fix... Please advise best practices here. - } - } - ### read data in the packets individually - filenames <- names(files) # list of all files because they are stored as headers by default + # fileath to /dbfiles + fp <- "/fs/data1/pecan.data/dbfiles/" - # filepath & create new directory with timestamp -- same for all files - fp <- paste("~/downloads/data/", destdir, "_", Sys.time(), "/", sep = "") # what should the destination directory/ filepath be for pecan? - dir.create(fp) + # make new directory within this directory + newdir <- paste(fp, "NewData_", username, sep = "") + system(paste("mkdir", newdir)) + # switch to new directory -- unsure if I should do this in R or in unix + # system(paste("cd", fp, sep = " ")) + setwd(newdir) for(i in 1:n){ - pkgMember <- datapack::getMember(pkg, filenames[i]) - data <- datapack::getData(pkgMember) - base::writeLines(rawToChar(data), paste(fp, "file_", i, formats[[i]], sep = "")) # file naming is an issue... How to proceed? + rename <- paste("File", i, Sys.time(), sep = "_") # new file name + system(paste("wget", "-O", rename, names(files)[i])) # download files with wget + } + system("ls") # checks that files were downloaded to + + # Naming could still be improved to include part of title or URL } } \ No newline at end of file From ab54bcd33b1328bbe87356975a1b0a3085c9d33d Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 15 Aug 2017 22:09:39 -0400 Subject: [PATCH 309/771] troubleshooting `git push` --- modules/data.land/R/dataone_download.R | 1 + 1 file changed, 1 insertion(+) diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index 91111297c43..a04960a9e33 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -12,6 +12,7 @@ #' @export #' #' @examples doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", username = "Guest") + dataone_download = function(id, username, CNode = "PROD", lazyLoad = FALSE, quiet = F){ ### automatically retrieve mnId cn <- dataone::CNode(CNode) From 63dc2c3907a614ea974ed5683ff4c1ef22443680 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 15 Aug 2017 22:15:26 -0400 Subject: [PATCH 310/771] Removed extraneous '}' and roxygenized (I forgot last time) --- modules/data.land/NAMESPACE | 2 +- modules/data.land/R/dataone_download.R | 1 - modules/data.land/man/dataone_download.Rd | 29 +++++++++++++++++++++++ 3 files changed, 30 insertions(+), 2 deletions(-) create mode 100644 modules/data.land/man/dataone_download.Rd diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index f9b8f61e7ae..e50c7e04bb2 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -5,7 +5,7 @@ export(InventoryGrowthFusion) export(InventoryGrowthFusionDiagnostics) export(Read_Tucson) export(buildJAGSdata_InventoryRings) -export(doi_download) +export(dataone_download) export(download_package_rm) export(extract.stringCode) export(extract_FIA) diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index a04960a9e33..9e3a2abc62f 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -44,4 +44,3 @@ dataone_download = function(id, username, CNode = "PROD", lazyLoad = FALSE, quie # Naming could still be improved to include part of title or URL } -} \ No newline at end of file diff --git a/modules/data.land/man/dataone_download.Rd b/modules/data.land/man/dataone_download.Rd new file mode 100644 index 00000000000..cbf23406051 --- /dev/null +++ b/modules/data.land/man/dataone_download.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dataone_download.R +\name{dataone_download} +\alias{dataone_download} +\title{DataONE download} +\usage{ +dataone_download(id, username, CNode = "PROD", lazyLoad = FALSE, + quiet = F) +} +\arguments{ +\item{id}{"The identifier of a package, package metadata or other package member" -- dataone r} + +\item{username}{used to create a user-specific destdir} + +\item{CNode}{} + +\item{lazyLoad}{"A logical value. If TRUE, then only package member system metadata is downloaded and not data. The default is FALSE." -- dataone R} + +\item{quiet}{"A 'logical'. If TRUE (the default) then informational messages will not be printed." -- dataone R} +} +\description{ +Adapts the dataone::getDataPackage workflow to allow users to download data from the DataONE federation by simply entering the doi or associated package id +} +\examples{ +doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", username = "Guest") +} +\author{ +Liam P Burke, \email{lpburke@bu.edu} +} From 87eccb74d26f2d9c5b361e6d68fabee500a139f6 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 15 Aug 2017 22:30:56 -0400 Subject: [PATCH 311/771] odd roxygen document... --- modules/data.land/man/doi_download.Rd | 29 --------------------------- 1 file changed, 29 deletions(-) delete mode 100644 modules/data.land/man/doi_download.Rd diff --git a/modules/data.land/man/doi_download.Rd b/modules/data.land/man/doi_download.Rd deleted file mode 100644 index c535e6008a2..00000000000 --- a/modules/data.land/man/doi_download.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/dataone_download.R -\name{doi_download} -\alias{doi_download} -\title{DataONE download} -\usage{ -doi_download(id, destdir = "MyDataFile", CNode = "PROD", lazyLoad = FALSE, - quiet = F) -} -\arguments{ -\item{id}{"The identifier of a package, package metadata or other package member" -- dataone r} - -\item{destdir}{Name the file that will be created to store the data.} - -\item{CNode}{} - -\item{lazyLoad}{"A logical value. If TRUE, then only package member system metadata is downloaded and not data. The default is FALSE." -- dataone R} - -\item{quiet}{"A 'logical'. If TRUE (the default) then informational messages will not be printed." -- dataone R} -} -\description{ -Adapts the dataone::getDataPackage workflow to allow users to download data from the DataONE federation by simply entering the doi or associated package id -} -\examples{ -doi_download(id = doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87, destdir = LTER) -} -\author{ -Liam P Burke, \email{lpburke@bu.edu} -} From ad2ca582957bc0c09b6a75859ecae5b667c57d15 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Wed, 16 Aug 2017 06:55:43 -0400 Subject: [PATCH 312/771] utils: addition of mcmc.list2init function for converting final elements in a mcmc.list to a list of initial conditions (e.g. for JAGS) --- modules/data.land/R/InventoryGrowthFusion.R | 29 ++++---- utils/R/mcmc.list2init.R | 78 +++++++++++++++++++++ 2 files changed, 95 insertions(+), 12 deletions(-) create mode 100644 utils/R/mcmc.list2init.R diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index a278535304e..bfbbea56c82 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -390,19 +390,24 @@ model{ } ## JAGS initial conditions - nchain <- 3 init <- list() - for (i in seq_len(nchain)) { - y.samp <- sample(data$y, length(data$y), replace = TRUE) - init[[i]] <- list(x = z0, - tau_add = runif(1, 1, 5) / var(diff(y.samp), na.rm = TRUE), - tau_dbh = 1, - tau_inc = 1500, - tau_ind = 50, - tau_yr = 100, - betaX2 = 0, - ind = rep(0, data$ni), - year = rep(0, data$nt)) + if(is.mcmc.list(restart)){ + init <- mcmc.list2init(restart) + nchain <- length(init) + } else { + nchain <- 3 + for (i in seq_len(nchain)) { + y.samp <- sample(data$y, length(data$y), replace = TRUE) + init[[i]] <- list(x = z0, + tau_add = runif(1, 1, 5) / var(diff(y.samp), na.rm = TRUE), + tau_dbh = 1, + tau_inc = 1500, + tau_ind = 50, + tau_yr = 100, + betaX2 = 0, + ind = rep(0, data$ni), + year = rep(0, data$nt)) + } } diff --git a/utils/R/mcmc.list2init.R b/utils/R/mcmc.list2init.R new file mode 100644 index 00000000000..965c52215fb --- /dev/null +++ b/utils/R/mcmc.list2init.R @@ -0,0 +1,78 @@ +#' Convert mcmc.list to initial condition list +#' +#' Used for restarting MCMC code based on last parameters sampled (e.g. in JAGS) +#' +#' @author Mike Dietze +#' +#' @param dat mcmc.list object +#' +#' @return list +#' @export +#' +#' @examples +mcmc.list2init <- function(dat) { + + ## get unique variable names + allname <- strsplit(colnames(dat[[1]]),"[",fixed = TRUE) + firstname <- sapply(allname,function(x){x[1]}) + dims <- lapply(allname,function(x){ + y <- sub(pattern = "]",replacement = "",x[2]) + y <- as.numeric(strsplit(y,",",fixed=TRUE)[[1]]) + return(y) + }) + ind <- t(sapply(dims,function(x){ + if(length(x)==2){ + return(x) + } else { return(c(NA,NA))} + })) + + uname <- unique(firstname) + + ## define variables + ic <- list() + n <- nrow(dat[[1]]) + nc <- nchain(dat) + for(c in seq_len(nc)) ic[[c]] <- list() + + for(v in seq_along(uname)){ + + ## detect variable type (scalar, vector, matrix) + cols <- which(firstname == uname[v]) + + if(length(cols) == 1){ + ## SCALAR + for(c in seq_len(nc)){ + ic[[c]][[v]] <- dat[[c]][nr,cols] + names(ic[[c]])[v] <- uname[v] + } + + } else { + + dim <- length(dims[[cols[1]]]) + + if(dim == 1){ + ## VECTOR + for(c in seq_len(nc)){ + ic[[c]][[v]] <- dat[[c]][nr,cols] + names(ic[[c]])[v] <- uname[v] + } + + } else if (dim == 2){ + ## MATRIX + for(c in seq_len(nc)){ + ic[[c]][[v]] <- matrix(seq_along(cols),max(ind[cols,1]),max(ind[cols,2])) ## set up matrix for storage + ic[[c]][[v]][ind[cols]] <- dat[[c]][nr,cols] + names(ic[[c]])[v] <- uname[v] + } + + } else { + PEcAn.utils::logger.severe("dimension not supported",dim,uname[v]) + } + + } ## end else VECTOR or MATRIX + + } ## end loop over v + + return(ic) + +} ## end mcmc.list2init \ No newline at end of file From 87f0416d31d87c0c801124a2b387dee5c597dd20 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Wed, 16 Aug 2017 08:13:48 -0400 Subject: [PATCH 313/771] tree ring: update restart --- modules/data.land/R/InventoryGrowthFusion.R | 42 ++++++++++++++++----- 1 file changed, 33 insertions(+), 9 deletions(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index bfbbea56c82..30c7028531c 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -5,7 +5,7 @@ ##' ##' @param data list of data inputs ##' @param random = whether or not to include random effects -##' @param n.chunk number of MCMC steps to evaluate at a time. Will only return LAST +##' @param n.chunk number of MCMC steps to evaluate at a time. Will only return LAST. If restarting, second number in vector is chunk to start from ##' @param n.burn number of steps to automatically discard as burn-in ##' @param save.state whether or not to include inferred DBH in output (can be large). Enter numeric value to save.state periodically (in terms of n.chunk) ##' @param restart final mcmc.list from previous execution. NULL for new run. TRUE to save final state for new run. @@ -21,6 +21,20 @@ InventoryGrowthFusion <- function(data, cov.data=NULL, time_data = NULL, n.iter= # if(save.state) out.variables <- c(out.variables,"x") if(!exists("model")) model = 0 + ## restart + if(length(n.chunk)>1){ + k_restart = n.chunk[2] + n.chunk = n.chunk[1] + } else { + k_restart = 1 + } + max.chunks <- ceiling(n.iter/n.chunk) + if(max.chunks < k_restart){ + PEcAn.utils::logger.warn("MCMC already complete",max.chunks,k_restart) + return(NULL) + } + avail.chunks <- k_restart:ceiling(n.iter/n.chunk) + check.dup.data <- function(data,loc){ if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at",loc,names(data))} } @@ -426,29 +440,39 @@ model{ PEcAn.utils::logger.info("RUN MCMC") load.module("dic") - for(k in seq_len(ceiling(n.iter/n.chunk))){ + for(k in avail.chunks){ + + ## determine whether to sample states if(as.logical(save.state) & k%%as.numeric(save.state) == 0){ vnames <- c("x",out.variables) ## save x periodically } else { vnames <- out.variables } + + ## sample chunk jags.out <- coda.samples(model = j.model, variable.names = vnames, n.iter = n.chunk) + + ## save chunk ofile <- paste("IGF",model,k,"RData",sep=".") print(ofile) save(jags.out,file=ofile) - ## could add code here to check for convergence and break from loop early + + ## update restart + if(!is.null(restart) & ((is.logical(restart) && restart) || is.mcmc.list(restart))){ + ofile <- paste("IGF",model,"RESTART.RData",sep=".") + jags.final <- coda.samples(model = j.model, variable.names = c("x",out.variables), n.iter = 1) + k_restart = k + 1 ## finished k, so would restart at k+1 + save(jags.final,k_restart,file=ofile) + } + + ## check for convergence and break from loop early D <- as.mcmc.list(lapply(jags.out,function(x){x[,'deviance']})) gbr <- coda::gelman.diag(D)$psrf[1,1] trend <- mean(sapply(D,function(x){coef(lm(x~seq_len(n.chunk)))[2]})) if(gbr < 1.005 & abs(trend) < 0.5) break } - ## get final state - if(!is.null(restart) & (as.logical(restart) || is.mcmc.list(restart))){ - ofile <- paste("IGF",model,"RESTART.RData",sep=".") - jags.final <- coda.samples(model = j.model, variable.names = c("x",out.variables), n.iter = 1) - save(jags.final,file=ofile) - } + return(jags.out) } # InventoryGrowthFusion From 6c66ff4c0a6fc2ddef0f515733fe17086540c863 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Wed, 16 Aug 2017 08:30:42 -0400 Subject: [PATCH 314/771] make document --- .../data.land/man/InventoryGrowthFusion.Rd | 2 +- utils/NAMESPACE | 1 + utils/man/mcmc.list2init.Rd | 20 +++++++++++++++++++ 3 files changed, 22 insertions(+), 1 deletion(-) create mode 100644 utils/man/mcmc.list2init.Rd diff --git a/modules/data.land/man/InventoryGrowthFusion.Rd b/modules/data.land/man/InventoryGrowthFusion.Rd index 50072da50f3..13e99ba6558 100644 --- a/modules/data.land/man/InventoryGrowthFusion.Rd +++ b/modules/data.land/man/InventoryGrowthFusion.Rd @@ -12,7 +12,7 @@ InventoryGrowthFusion(data, cov.data = NULL, time_data = NULL, \arguments{ \item{data}{list of data inputs} -\item{n.chunk}{number of MCMC steps to evaluate at a time. Will only return LAST} +\item{n.chunk}{number of MCMC steps to evaluate at a time. Will only return LAST. If restarting, second number in vector is chunk to start from} \item{n.burn}{number of steps to automatically discard as burn-in} diff --git a/utils/NAMESPACE b/utils/NAMESPACE index 4ec10624920..6931341c696 100644 --- a/utils/NAMESPACE +++ b/utils/NAMESPACE @@ -49,6 +49,7 @@ export(logger.setUseConsole) export(logger.setWidth) export(logger.severe) export(logger.warn) +export(mcmc.list2init) export(misc.are.convertible) export(misc.convert) export(model2netcdf) diff --git a/utils/man/mcmc.list2init.Rd b/utils/man/mcmc.list2init.Rd new file mode 100644 index 00000000000..c91a11718f8 --- /dev/null +++ b/utils/man/mcmc.list2init.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mcmc.list2init.R +\name{mcmc.list2init} +\alias{mcmc.list2init} +\title{Convert mcmc.list to initial condition list} +\usage{ +mcmc.list2init(dat) +} +\arguments{ +\item{dat}{mcmc.list object} +} +\value{ +list +} +\description{ +Used for restarting MCMC code based on last parameters sampled (e.g. in JAGS) +} +\author{ +Mike Dietze +} From 0bcd9c1e3bde0e8e1e1acc1f94eac44c9438032c Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 16 Aug 2017 11:00:46 -0400 Subject: [PATCH 315/771] update CHANGELOG for past PRs --- CHANGELOG.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 06cdc327c2e..b8a889f5052 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,12 @@ For more information about this file see also [Keep a Changelog](http://keepacha ### Fixes - Fixed remote code execution #1545 +- Added check for NA end/start year in read.output +- Fixed jagify bug for raw field data +- Fixed bug (order of dims in nc_create) introduced in model2netcdf.DALEC by standard_vars changes + +### Added +- Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) ## [1.5.10] - Prerelease ### Added @@ -19,6 +25,8 @@ For more information about this file see also [Keep a Changelog](http://keepacha - added docker container scrips (.yml) to create docker container for PEcAn - added the configuration edit page to allow easy modification of config via web interface - thredds server documentation and catlog generating script +- added new standard variables table (standard_vars.csv) and to_ncvar and to_ncdim functions in PEcAn.utils +- added initial conditions file io functions for pool-based models in data.land ### Changed - upscale_met now accepts ~any valid CF file (not just full years), retains correct time units, and respects the previously ignored `overwrite` parameter From 373c60757ad431a06922f4c5c7c91bb9e300a230 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Wed, 16 Aug 2017 21:58:19 -0400 Subject: [PATCH 316/771] Adressed all reqests from last review by @mdietze: made filepath a variable, removed sys.time() from newdir, changed naming scheme, now cd's in and out of newdir --- modules/data.land/R/dataone_download.R | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index 9e3a2abc62f..00929baa67d 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -2,6 +2,7 @@ #' #' @param id "The identifier of a package, package metadata or other package member" -- dataone r #' @param username used to create a user-specific destdir +#' @param filepath path to where files will be stored #' @param CNode #' @param lazyLoad "A logical value. If TRUE, then only package member system metadata is downloaded and not data. The default is FALSE." -- dataone R #' @param quiet "A 'logical'. If TRUE (the default) then informational messages will not be printed." -- dataone R @@ -13,7 +14,7 @@ #' #' @examples doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", username = "Guest") -dataone_download = function(id, username, CNode = "PROD", lazyLoad = FALSE, quiet = F){ +dataone_download = function(id, username, filepath = "/fs/data1/pecan.data/dbfiles/", CNode = "PROD", lazyLoad = FALSE, quiet = F){ ### automatically retrieve mnId cn <- dataone::CNode(CNode) locations <- dataone::resolve(cn, pid = id) @@ -24,23 +25,16 @@ dataone_download = function(id, username, CNode = "PROD", lazyLoad = FALSE, quie pkg <- dataone::getDataPackage(d1c, id = id, lazyLoad = lazyLoad, quiet = quiet, limit = "1MB") # what is the standard limit for pecan downloads? files <- datapack::getValue(pkg, name="sysmeta@formatId") n <- length(files) # number of files - - # fileath to /dbfiles - fp <- "/fs/data1/pecan.data/dbfiles/" - + # make new directory within this directory - newdir <- paste(fp, "NewData_", username, sep = "") - system(paste("mkdir", newdir)) - - # switch to new directory -- unsure if I should do this in R or in unix - # system(paste("cd", fp, sep = " ")) - setwd(newdir) + newdir <- paste(filepath, "NewData_", username, sep = "") + dir.create(newdir) for(i in 1:n){ - rename <- paste("File", i, Sys.time(), sep = "_") # new file name - system(paste("wget", "-O", rename, names(files)[i])) # download files with wget + rename <- paste(i, basename(names(files[i])), sep="_") # new file name + system(paste("cd", newdir, "&&", "{", "wget", "-O", rename, names(files)[i], "; cd -; }")) # cd to newdir, download files with wget, cd back } - system("ls") # checks that files were downloaded to + list.files(newdir) # checks that files were downloaded to - # Naming could still be improved to include part of title or URL + # Naming could still be improved to include part of title } From fd94d8eedc8addafd1430cdb27a564a5635bc8d9 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Wed, 16 Aug 2017 22:00:11 -0400 Subject: [PATCH 317/771] updated roxygendocs --- modules/data.land/man/dataone_download.Rd | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/modules/data.land/man/dataone_download.Rd b/modules/data.land/man/dataone_download.Rd index cbf23406051..95421374e1d 100644 --- a/modules/data.land/man/dataone_download.Rd +++ b/modules/data.land/man/dataone_download.Rd @@ -4,14 +4,16 @@ \alias{dataone_download} \title{DataONE download} \usage{ -dataone_download(id, username, CNode = "PROD", lazyLoad = FALSE, - quiet = F) +dataone_download(id, username, filepath = "/fs/data1/pecan.data/dbfiles/", + CNode = "PROD", lazyLoad = FALSE, quiet = F) } \arguments{ \item{id}{"The identifier of a package, package metadata or other package member" -- dataone r} \item{username}{used to create a user-specific destdir} +\item{filepath}{path to where files will be stored} + \item{CNode}{} \item{lazyLoad}{"A logical value. If TRUE, then only package member system metadata is downloaded and not data. The default is FALSE." -- dataone R} From 02f7a0366ec9083adfaf1e4c4c5a3181c5c610d1 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Thu, 17 Aug 2017 09:27:11 -0500 Subject: [PATCH 318/771] Cleaning code for submission. --- shiny/workflowPlot/helper.R | 7 +++- shiny/workflowPlot/server.R | 79 +++++++++++++++++++------------------ shiny/workflowPlot/ui.R | 1 + 3 files changed, 48 insertions(+), 39 deletions(-) diff --git a/shiny/workflowPlot/helper.R b/shiny/workflowPlot/helper.R index e38adbbd812..7e4cee2ba15 100644 --- a/shiny/workflowPlot/helper.R +++ b/shiny/workflowPlot/helper.R @@ -1,3 +1,4 @@ +# Helper function which checks and downloads required packages checkAndDownload<-function(packageNames) { for(packageName in packageNames) { if(!isInstalled(packageName)) { @@ -9,11 +10,14 @@ checkAndDownload<-function(packageNames) { isInstalled <- function(mypkg){ is.element(mypkg, installed.packages()[,1]) } -checkAndDownload(c('plotly','scales','dplyr')) +# checkAndDownload(c('plotly','scales','dplyr')) +# We can also save the csv on the run from the shiny app as well # write.csv(inputs_df,file='/home/carya/pecan/shiny/workflowPlot/inputs_df.csv', # quote = FALSE,sep = ',',col.names = TRUE,row.names=FALSE) + # Stashing Code for file upload to shiny app # Based on https://shiny.rstudio.com/gallery/file-upload.html + # ui.R # tags$hr(), # fileInput('file1', 'Choose CSV File to upload data', @@ -34,6 +38,7 @@ checkAndDownload(c('plotly','scales','dplyr')) # textInput("inputRecordID", "Input Record ID for file", "1000011260"), # textInput("formatID", "Format ID for file (Default CSV)", "5000000002"), # actionButton("load_data", "Load External Data") + # server.R # loadExternalData <-eventReactive(input$load_data,{ # inFile <- input$file1 diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 5d055abc74f..a524b43933c 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -12,15 +12,15 @@ library(plotly) library(scales) library(lubridate) library(dplyr) +library(reshape2) # Maximum size of file allowed to be uploaded: 100MB options(shiny.maxRequestSize=100*1024^2) # Define server logic server <- shinyServer(function(input, output, session) { bety <- betyConnect() - # bety <- betyConnect('/home/carya/pecan/web/config.php') # Update all workflow ids observe({ - # Ideally get_workflow_ids function (line 137) in db/R/query.dplyr.R should take a flag to check + # get_workflow_ids function (line 137) in db/R/query.dplyr.R takes a flag to check # if we want to load all workflow ids. # get_workflow_id function from query.dplyr.R all_ids <- get_workflow_ids(bety, session,all.ids=TRUE) @@ -35,7 +35,7 @@ server <- shinyServer(function(input, output, session) { # Will return a list run_id_list <- c() for(w_id in w_ids){ - # For all the workflow ids + # For all the workflow ids r_ids <- get_run_ids(bety, w_id) for(r_id in r_ids){ # Each workflow id can have more than one run ids @@ -104,29 +104,27 @@ server <- shinyServer(function(input, output, session) { loadObservationData <- function(bety,inputs_df){ input_id <- inputs_df$input_id File_format <- getFileFormat(bety,input_id) - # start.year<-as.numeric(lubridate::year(settings$run$start.date)) - # end.year<-as.numeric(lubridate::year(settings$run$end.date)) - # site.id<-settings$run$site$id - # site<-PEcAn.DB::query.site(site.id,bety$con) start.year <- as.numeric(lubridate::year(inputs_df$start_date)) end.year <- as.numeric(lubridate::year(inputs_df$end_date)) # File_path <- inputs_df$filePath + # TODO There is an issue with the db where file names are not saved properly. + # To make it work with the VM, uncomment the line below File_path <- paste0(inputs_df$filePath,'.csv') site.id <- inputs_df$site_id site<-PEcAn.DB::query.site(site.id,bety$con) observations<-PEcAn.benchmark::load_data(data.path = File_path, format= File_format, time.row = File_format$time.row, site = site, start_year = start.year, end_year = end.year) return(observations) } - # This function as a wrapper over PEcAn.DB::query.format.vars where + # This function is a wrapper over PEcAn.DB::query.format.vars where # file format can be retrieved using either by input or format id. getFileFormat <- function(bety,input.id,format.id=NULL){ - # Retaining the code for getting file format using format Id as in tutorial + # TODO Retaining the code for getting file format using format Id as in tutorial # File_format <- PEcAn.DB::query.format.vars(bety = bety, format.id = format.id) File_format <- PEcAn.DB::query.format.vars(bety = bety, input.id = input.id) return(File_format) } getSettingsFromWorkflowId <- function(bety,workflowID){ - basePath <- tbl(bety, 'workflows') %>% filter(id %in% workflowID) %>% pull(folder) + basePath <- tbl(bety, 'workflows') %>% dplyr::filter(id %in% workflowID) %>% pull(folder) configPath <- file.path(basePath, 'pecan.CONFIGS.xml') # Second way of providing configPath. More of a hack # configPath <- paste0("~/output/PEcAn_",workflowID,"/pecan.CONFIGS.xml") @@ -145,30 +143,34 @@ server <- shinyServer(function(input, output, session) { } updateSelectizeInput(session, "all_site_id", choices=site_id_list) }) - # Get input id from selected site id + # Get input id from selected site id. Returns inputs_df which is used to load observation data getInputs <- function(bety,site_Id){ - # inputIds <- tbl(bety, 'inputs') %>% filter(site_id %in% site_Id) %>% distinct(id) %>% pull(id) + # Subsetting the input id list based on the current (VM) machine my_hostname <- PEcAn.utils::fqdn() - my_machine_id <- tbl(bety, 'machines') %>% filter(hostname == my_hostname) %>% pull(id) + my_machine_id <- tbl(bety, 'machines') %>% dplyr::filter(hostname == my_hostname) %>% pull(id) + # Inner join 'inputs' table with 'dbfiles' table + # inputs_df would contain all the information about the site and input id required for + # the tutorial mentioned above to compare model run with actual observations inputs_df <- tbl(bety, 'dbfiles') %>% - filter(container_type == 'Input', machine_id == my_machine_id) %>% - inner_join(tbl(bety, 'inputs') %>% filter(site_id %in% site_Id), by = c('container_id' = 'id')) %>% + dplyr::filter(container_type == 'Input', machine_id == my_machine_id) %>% + inner_join(tbl(bety, 'inputs') %>% dplyr::filter(site_id %in% site_Id), by = c('container_id' = 'id')) %>% collect() + # Order by container id (==input id) inputs_df <- inputs_df[order(inputs_df$container_id),] + # Mutate column as (input id, name) to be shown to the user inputs_df <- inputs_df %>% dplyr::mutate(input_selection_list = paste(inputs_df$container_id, inputs_df$name), filePath = paste0(inputs_df$file_path,'/', inputs_df$file_name)) %>% dplyr::select(input_id = container_id,filePath,input_selection_list,start_date,end_date,site_id,name, machine_id,file_name,file_path) - # colnames(inputs_df)[1] <- 'input_id' return(inputs_df) } + # Update input id list as (input id, name) observe({ req(input$all_site_id) inputs_df <- getInputs(bety,c(input$all_site_id)) updateSelectizeInput(session, "all_input_id", choices=inputs_df$input_selection_list) }) - # Renders ggplotly output$outputPlot <- renderPlotly({ # Error messages @@ -179,7 +181,6 @@ server <- shinyServer(function(input, output, session) { ) # Load data masterDF <- loadNewData() - # masterDF <- rbind(modelData,externalData) # Convert from factor to character. For subsetting masterDF$var_name <- as.character(masterDF$var_name) # Convert to factor. Required for ggplot @@ -187,7 +188,7 @@ server <- shinyServer(function(input, output, session) { # Filter by variable name df <- masterDF %>% dplyr::filter(var_name == input$variable_name) - # make dynamic slider + # Another way to make dynamic slider # https://stackoverflow.com/questions/18700589/interactive-reactive-change-of-min-max-values-of-sliderinput # output$slider <- renderUI({ # sliderInput("smooth_n", "Value for smoothing:", min=0, max=nrow(df), value=80) @@ -197,8 +198,10 @@ server <- shinyServer(function(input, output, session) { title <- unique(df$title) xlab <- unique(df$xlab) ylab <- unique(df$ylab) - # ggplot function for now scatter plots. + # ggplot function for scatter plots. plt <- ggplot(df, aes(x=dates, y=vals, color=run_id)) + # model_geom <- switch(input$plotType, scatterPlot = geom_point, lineChart = geom_line) + # plt <- plt + model_geom() # Toggle chart type using switch switch(input$plotType, "scatterPlot" = { @@ -208,56 +211,56 @@ server <- shinyServer(function(input, output, session) { plt <- plt + geom_line() } ) - # model_geom <- switch(input$model_geom, point = geom_point, line = geom_line) - # Check if user wants to load external data + # Check if user wants to load external data (==observations) # Similar to using event reactive if (input$load_data>0) { - # Retaining the code for getting file format using inputRecordID + # Retaining the code for getting file format using formatID # File_format <- getFileFormat(bety,input$formatID) - # Input ID is of the form (ID Name). Split by space and use the first element + # Input ID is of the form (input id, Name). Split by space and use the first element inputs_df <- getInputs(bety,c(input$all_site_id)) inputs_df <- inputs_df %>% dplyr::filter(input_selection_list == input$all_input_id) externalData <- loadObservationData(bety,inputs_df) - # If variable found in the uploaded file + # If variable found in the uploaded file. + # TODO for now, actual observations can be plotted again a single model run (particular run id) + # Have to enhance to allow multiple run ids if (input$variable_name %in% names(externalData)){ + # No need for subsetting though as align data returns for now only the provided variable name # externalData <- externalData %>% dplyr::select(posix,dplyr::one_of(input$variable_name)) - # names(externalData) <- c("dates","vals") - # externalData$dates <- as.Date(externalData$dates) var = input$variable_name df = df %>% select(posix = dates, var = vals) - colnames(df)[2]<-paste0(var) + colnames(df)[2]<-paste0(var) # Required for align data to work aligned_data = PEcAn.benchmark::align_data(model.calc = df, obvs.calc = externalData, var =var, align_method = "match_timestep") - colnames(aligned_data) <- c("model","observations","Date") - aligned_data <- melt(aligned_data, "Date") + colnames(aligned_data) <- c("model","observations","Date") # Order returned by align_data + # Melt dataframe to plot two types of columns together + aligned_data <- reshape2::melt(aligned_data, "Date") + # From the tutorial, if want to plot model vs observations # plot(aligned_dat$NEE.m, aligned_dat$NEE.o) # abline(0,1,col="red") ## intercept=0, slope=1 data_geom <- switch(input$data_geom, point = geom_point, line = geom_line) plt <- ggplot(aligned_data, aes(x=Date, y=value, color=variable)) + data_geom() - # plt <- plt + data_geom(data = externalData,aes(x=dates, y=vals),color='black', linetype = 'dashed') output$outputNoVariableFound <- renderText({ - paste0("Plotting data outputs in black") + paste0("Plotting data outputs.") }) } # Shiny output if variable not found else { output$outputNoVariableFound <- renderText({ - paste0("Not plotting uploaded data because the column is absent. Select another variable") + paste0("Data related to variable not found in the observations uploaded. Select another variable") }) } } plt <- plt + labs(title=title, x=xlab, y=ylab) + geom_smooth(n=input$smooth_n) - # Earlier smoothing and y labels + # Earlier code for smoothing, y labels, color and fill values + # Retaining if we want to use ggplot instead of ggplotly # geom_smooth(aes(fill = "Spline fit")) + # scale_y_continuous(labels=fancy_scientific) + - # Earlier color and fill values # scale_color_manual(name = "", values = "black") + # scale_fill_manual(name = "", values = "grey50") plt<-ggplotly(plt) # Not able to add icon over ggplotly # add_icon() }) - # Shiny server closes here -}) - +}) # Shiny server closes here +# To run the shiny app locally # runApp(port=6480, launch.browser=FALSE) # runApp(port=5658, launch.browser=FALSE) diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index d9ced7ecf6d..4ce8cf0fe73 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -23,6 +23,7 @@ ui <- shinyUI(fluidPage( tags$hr(), tags$hr(), selectizeInput("all_site_id", "Select Site ID", c()), + # If loading multiple sites in future # selectizeInput("all_site_id", "Select Site ID", c(), multiple=TRUE), selectizeInput("all_input_id", "Select Input ID", c()), radioButtons("data_geom", "Plot Type (for loaded data)", From 536bb852a72b1ac17dbf27a7c02b8e8ba8831439 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Thu, 17 Aug 2017 09:30:26 -0500 Subject: [PATCH 319/771] Correcting file path related to input id --- shiny/workflowPlot/server.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index a524b43933c..a81e11ced3e 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -106,10 +106,10 @@ server <- shinyServer(function(input, output, session) { File_format <- getFileFormat(bety,input_id) start.year <- as.numeric(lubridate::year(inputs_df$start_date)) end.year <- as.numeric(lubridate::year(inputs_df$end_date)) - # File_path <- inputs_df$filePath + File_path <- inputs_df$filePath # TODO There is an issue with the db where file names are not saved properly. # To make it work with the VM, uncomment the line below - File_path <- paste0(inputs_df$filePath,'.csv') + # File_path <- paste0(inputs_df$filePath,'.csv') site.id <- inputs_df$site_id site<-PEcAn.DB::query.site(site.id,bety$con) observations<-PEcAn.benchmark::load_data(data.path = File_path, format= File_format, time.row = File_format$time.row, site = site, start_year = start.year, end_year = end.year) From d41f4108c2e2a11d7e6cb9b36436d24c18182d90 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 17 Aug 2017 16:09:06 -0400 Subject: [PATCH 320/771] Changed directory naming scheme per review by @mdietze --- modules/data.land/R/dataone_download.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index 00929baa67d..a80dd9e9c59 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -1,7 +1,6 @@ #' DataONE download #' #' @param id "The identifier of a package, package metadata or other package member" -- dataone r -#' @param username used to create a user-specific destdir #' @param filepath path to where files will be stored #' @param CNode #' @param lazyLoad "A logical value. If TRUE, then only package member system metadata is downloaded and not data. The default is FALSE." -- dataone R @@ -14,7 +13,7 @@ #' #' @examples doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", username = "Guest") -dataone_download = function(id, username, filepath = "/fs/data1/pecan.data/dbfiles/", CNode = "PROD", lazyLoad = FALSE, quiet = F){ +dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNode = "PROD", lazyLoad = FALSE, quiet = F){ ### automatically retrieve mnId cn <- dataone::CNode(CNode) locations <- dataone::resolve(cn, pid = id) @@ -27,7 +26,7 @@ dataone_download = function(id, username, filepath = "/fs/data1/pecan.data/dbfil n <- length(files) # number of files # make new directory within this directory - newdir <- paste(filepath, "NewData_", username, sep = "") + newdir <- file.path(filepath, paste0("DataOne_", gsub("/", "-", id))) dir.create(newdir) for(i in 1:n){ From bad397001c74b28d8c3c78dd527337329918bece Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 17 Aug 2017 16:13:08 -0400 Subject: [PATCH 321/771] updated roxygendocs --- modules/data.land/man/dataone_download.Rd | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/modules/data.land/man/dataone_download.Rd b/modules/data.land/man/dataone_download.Rd index 95421374e1d..f7e93350d4d 100644 --- a/modules/data.land/man/dataone_download.Rd +++ b/modules/data.land/man/dataone_download.Rd @@ -4,14 +4,12 @@ \alias{dataone_download} \title{DataONE download} \usage{ -dataone_download(id, username, filepath = "/fs/data1/pecan.data/dbfiles/", +dataone_download(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNode = "PROD", lazyLoad = FALSE, quiet = F) } \arguments{ \item{id}{"The identifier of a package, package metadata or other package member" -- dataone r} -\item{username}{used to create a user-specific destdir} - \item{filepath}{path to where files will be stored} \item{CNode}{} From a6177921a4b2dc086afbe7dd270eeedf1f9a3981 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Fri, 18 Aug 2017 21:13:23 +0530 Subject: [PATCH 322/771] Added the brief documentation on the use of the setup page at /book_source/basic_users_guide/basic_setups.Rmd --- .../basic_users_guide/basic_setups.Rmd | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 book_source/basic_users_guide/basic_setups.Rmd diff --git a/book_source/basic_users_guide/basic_setups.Rmd b/book_source/basic_users_guide/basic_setups.Rmd new file mode 100644 index 00000000000..30367cb31f7 --- /dev/null +++ b/book_source/basic_users_guide/basic_setups.Rmd @@ -0,0 +1,21 @@ +## Basic Setups + +There are few options which you can change via web interface. + +To visit the configuration page either you can just click on the setups link on the introduction page alternatively can type `/setups/`. + +The list of configuration available + +1. **Database configuration** : BETYdb(Biofuel Ecophysiological Traits and Yields database) configuration details, can be edited according to need. + +2. **Browndog configuration** : Browndog configuration details, Used to connect browndog. Its included by default in VM. + +3. **FIA Database** : FIA(Forest Inventory and Analysis) Database configuration details, Can be used to add additional data to models. + +4. **Google MapKey** : Google Map key, used to access the google map by PEcAn. + +5. **Change Password** : A small infomation to change the VM user password. (if using Docker image it won't work) + +6. **Automatic Sync** : If ON then it will sync the database between local machine and the remote servers. **Still unders testing part might be buggy**. + +Still work on the adding other editing feature going on, this page will be updated as new configuration will be available. From 7e73f71f2867fe14b8d467340059bc2517f0a4bc Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Fri, 18 Aug 2017 21:15:15 +0530 Subject: [PATCH 323/771] Added link to setup page in 01-introduction.php --- web/01-introduction.php | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/web/01-introduction.php b/web/01-introduction.php index 81c4cec32dd..1f0f06fef85 100644 --- a/web/01-introduction.php +++ b/web/01-introduction.php @@ -76,11 +76,13 @@ function nextStep() {

    + Basic Setup +
    Documentation
    Chat Room
    - Bug Report + Bug Report

    From 4599871ea287724337d1c657722ba6f794135257 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Fri, 18 Aug 2017 21:59:52 +0530 Subject: [PATCH 324/771] Added condition to check if the host_id is 99 then change it to 100 as it is reserved for the VM --- web/setups/serversyncscript.php | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/web/setups/serversyncscript.php b/web/setups/serversyncscript.php index a6f0300e056..1567be27315 100644 --- a/web/setups/serversyncscript.php +++ b/web/setups/serversyncscript.php @@ -35,8 +35,33 @@ if ($row == false) { // means no data exist in database - $host_id = 25; - $id = 0; + + // finding the max sync_id + $stmt = $pdo->prepare("SELECT max(sync_host_id) FROM machines;",array(PDO::ATTR_CURSOR => PDO::CURSOR_FWDONLY)); + if (!$stmt->execute()) { + echo json_encode(array('status' => 'ERROR', + 'errormessage' => 'Invalid query : [' . error_database() . ']' . $pdo->errorInfo())); + die(); + } + $row = $stmt->fetch(PDO::FETCH_ASSOC); + + $host_id = $row+1; + + // if the host_id == 99 then changing it to 100 as 99 is reserved for the VM + if ($host_id == 99) + $host_id++; + + // finding max id + $stmt = $pdo->prepare("SELECT max(id) FROM machines;",array(PDO::ATTR_CURSOR => PDO::CURSOR_FWDONLY)); + if (!$stmt->execute()) { + echo json_encode(array('status' => 'ERROR', + 'errormessage' => 'Invalid query : [' . error_database() . ']' . $pdo->errorInfo())); + die(); + } + $row = $stmt->fetch(PDO::FETCH_ASSOC); + + $id = $row+1; + $date = date("Y-m-d H:i:s"); $stmt = $pdo->prepare("INSERT INTO machines (id, hostname, created_at, updated_at , sync_host_id, sync_url, sync_contact, sync_start, sync_end) From d2757255abf272c5cd3967e67c03ecdf1793c558 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Fri, 18 Aug 2017 22:23:30 +0530 Subject: [PATCH 325/771] Removed the commented codes and also added a handler to handle the clinet secret for the first time --- web/setups/clientsyncscript.php | 15 +++++++++++---- web/setups/core.php | 1 + 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/web/setups/clientsyncscript.php b/web/setups/clientsyncscript.php index 13493c49388..f0acff9ace3 100644 --- a/web/setups/clientsyncscript.php +++ b/web/setups/clientsyncscript.php @@ -16,10 +16,6 @@ $curl = curl_init($service_url); -//var_dump($client_sceret); -//var_dump($server_auth_token); -//var_dump($fqdn); - $curl_post_data = array ('client_sceret' => $client_sceret, 'server_auth_token' => $server_auth_token, 'fqdn' => $fqdn ); @@ -53,6 +49,17 @@ // var_dump($decoded); // instructions to update the client secrets +if (!isset($client_sceret) && empty($client_sceret)) { + $curl_post_data = array ('client_sceret' => $client_sceret); + $service_url = $server_url."/pecan/setups/add.php"; + $curl = curl_init($service_url); + // set the curl to do POST request to add client secret to the config page + curl_setopt($curl, CURLOPT_RETURNTRANSFER, true); + curl_setopt($curl, CURLOPT_POST, true); + curl_setopt($curl, CURLOPT_POSTFIELDS, $curl_post_data); + // execute the curl request + $curl_response = curl_exec($curl); +} // script to handle wait id part //echo $decoded->wantid; diff --git a/web/setups/core.php b/web/setups/core.php index 7d7635b7766..1088b858018 100644 --- a/web/setups/core.php +++ b/web/setups/core.php @@ -29,6 +29,7 @@ case 'browndog': $pattern = '/\$browndog*/i'; break; case 'database': $pattern = '/\$db_bety_*/i'; break; case 'fiadb': $pattern = '/\$db_fia_*/i'; break; + case 'client_sceret': $pattern = '/\$client_sceret*/i'; break; default: $pattern = '/^\$'.$key.'/i'; } From dff31f7d51b71f69c3b3b4d5e65b50f6ee5077dd Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Fri, 18 Aug 2017 22:28:00 +0530 Subject: [PATCH 326/771] Removed dead codes and minor fixes --- web/setups/clientsyncscript.php | 6 ------ web/setups/serversyncscript.php | 4 ++-- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/web/setups/clientsyncscript.php b/web/setups/clientsyncscript.php index f0acff9ace3..f6f38ddcfac 100644 --- a/web/setups/clientsyncscript.php +++ b/web/setups/clientsyncscript.php @@ -42,12 +42,6 @@ die('error occured: ' . $decoded->errormessage); } -// got wait id - -// var_dump($curl_response); -// echo '
    '; -// var_dump($decoded); - // instructions to update the client secrets if (!isset($client_sceret) && empty($client_sceret)) { $curl_post_data = array ('client_sceret' => $client_sceret); diff --git a/web/setups/serversyncscript.php b/web/setups/serversyncscript.php index 1567be27315..e12df6a0719 100644 --- a/web/setups/serversyncscript.php +++ b/web/setups/serversyncscript.php @@ -51,7 +51,7 @@ if ($host_id == 99) $host_id++; - // finding max id + // finding max id $stmt = $pdo->prepare("SELECT max(id) FROM machines;",array(PDO::ATTR_CURSOR => PDO::CURSOR_FWDONLY)); if (!$stmt->execute()) { echo json_encode(array('status' => 'ERROR', @@ -99,7 +99,7 @@ // checking for existance and other things -$wantid = 1; // Generate the wantid +$wantid = $row->sync_host_id; // Generate the wantid echo json_encode(array('status' => 'OK', 'wantid' => $wantid, From 0df5b44c02a2942abb6ba32e4d2bc41132b96c39 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Fri, 18 Aug 2017 22:33:57 +0530 Subject: [PATCH 327/771] Updated the CHANGELOG.md --- CHANGELOG.md | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index db3ebf81444..48667830add 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,13 +9,14 @@ For more information about this file see also [Keep a Changelog](http://keepacha ## [1.5.10] - Prerelease ### Added +- Added cron job and script for the sync of the database. - Added PEcAn.utils::download.file() to allow for use of alternative FTP programs - Updated downloadAmeriflux and downloadNARR to make use of PEcAn.utils::download.file() - Added -w flag to load.bety.sh script to specify the URL to fetch the data from -- add new table sites_cultivars to betydb sync scripts (dump and load) -- added docker container scrips (.yml) to create docker container for PEcAn -- added the configuration edit page to allow easy modification of config via web interface -- thredds server documentation and catlog generating script +- Add new table sites_cultivars to betydb sync scripts (dump and load) +- Added docker container scrips (.yml) to create docker container for PEcAn +- Added the configuration edit page to allow easy modification of config via web interface +- Thredds server documentation and catlog generating script ### Changed - upscale_met now accepts ~any valid CF file (not just full years), retains correct time units, and respects the previously ignored `overwrite` parameter From 707886826a57452c35125f4eb48595c0dc4b5f9d Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 1 Aug 2017 15:11:39 -0400 Subject: [PATCH 328/771] Use faster effective sample size calc. --- modules/rtm/R/neff.R | 26 ++++++++++++++++---------- 1 file changed, 16 insertions(+), 10 deletions(-) diff --git a/modules/rtm/R/neff.R b/modules/rtm/R/neff.R index 1ff72cde230..d014cb9a312 100644 --- a/modules/rtm/R/neff.R +++ b/modules/rtm/R/neff.R @@ -8,17 +8,23 @@ neff <- function(x) { } #' @export -neff.default <- function(x, ...) { - xna <- is.na(x) - if (any(xna)) { - warning("NA in neff input. Omitting.") - x <- x[!xna] +neff.default <- function(x, lag.max = NULL, min_rho = 0.1) { + x_use <- x[!is.na(x)] + nx <- length(x_use) + if (is.null(lag.max)) { + # Same as in the ACF function + lag.max <- floor(10 * log10(nx)) } - arout <- ar.yw(x, ...) - spec <- arout$var.pred/(1 - sum(arout$ar))^2 - out <- length(x) * var(x) / spec - stopifnot(length(out) == 1) - return(out) + rho_all <- .Call(stats:::C_acf, x_use, lag.max, TRUE) + rho <- rho_all[-1] + too_small <- rho < min_rho + if (any(too_small)) { + rho <- rho[seq_len(which(too_small)[1])] + } + nrho <- length(rho) + tau <- 1 + 2 * sum((1 - seq_len(nrho) / nx) * rho) + n_eff <- nx / tau + return(n_eff) } #' @export From 44a80c5d5b3c8d48b753978077bf843c5ff6428b Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 1 Aug 2017 17:24:15 -0400 Subject: [PATCH 329/771] Revise BayesianTools helpers in `assim.batch` * In the `pda.create.btprior` function, replace `parse-eval` framework, which is unsafe and a bit clunky, with functional programming (`match.fun`, and then). * Move BayesianTools-related functions to their own file. * Add unit tests for `pda.create.btprior`. --- .../assim.batch/R/pda.bayestools.helpers.R | 233 ++++++++++++++++++ modules/assim.batch/R/pda.utils.R | 202 --------------- modules/assim.batch/man/correlationPlot.Rd | 6 +- modules/assim.batch/man/pda.create.btprior.Rd | 18 +- modules/assim.batch/man/pda.settings.bt.Rd | 2 +- .../tests/testthat/test.bt_prior.R | 37 +++ 6 files changed, 287 insertions(+), 211 deletions(-) create mode 100644 modules/assim.batch/R/pda.bayestools.helpers.R create mode 100644 modules/assim.batch/tests/testthat/test.bt_prior.R diff --git a/modules/assim.batch/R/pda.bayestools.helpers.R b/modules/assim.batch/R/pda.bayestools.helpers.R new file mode 100644 index 00000000000..50f754fd80c --- /dev/null +++ b/modules/assim.batch/R/pda.bayestools.helpers.R @@ -0,0 +1,233 @@ +##' Create priors for BayesianTools +##' +##' Helper function for creating log-priors compatible with BayesianTools package +##' +##' @param prior.sel `data.frame` containing prior distributions of the selected parameters +##' +##' @return out Prior class object for BayesianTools package +##' @details `prior.sel` must contain the following columns: +##' * `distn` -- String describing a distribution; e.g. `norm` for `dnorm`, `rnorm`, etc. +##' * `parama`, `paramb` -- First and second parameters, respectively, of the corresponding distribution +##' +##' Optionally, `prior.sel` may also contain the following columns: +##' * `param_name` -- Parameter name, which will be carried through to the prior object and sampler +##' * `lower`, `upper` -- Lower and upper bounds, respectively. These can be leveraged by the BayesianTools samplers. +##' * `best` -- Best guess for a parameter estimate. BayesianTools can also use this, though I'm not sure how... +##' +##' @author Istem Fer, Alexey Shiklomanov +##' @export +pda.create.btprior <- function(prior.sel) { + + # TODO: test exponential -- it only has one argument, so this won't work + + # Returns a function that calculates the density of the specified + # distribution given the parameters + ddist_generator <- function(distn, a, b) { + fun_string <- paste0('d', distn) + f <- match.fun(fun_string) + out <- function(x) f(x, a, b, log = TRUE) + return(out) + } + + # Returns a function that draws from the specified distribution with the + # specified parameters + rdist_generator <- function(distn, a, b) { + fun_string <- paste0('r', distn) + f <- match.fun(fun_string) + out <- function(n = 1) f(n, a, b) + return(out) + } + + # Create a list of density and random draw functions + ddist_funs <- with(prior.sel, mapply(ddist_generator, distn, parama, paramb)) + rdist_funs <- with(prior.sel, mapply(rdist_generator, distn, parama, paramb)) + if ('param_name' %in% names(prior.sel)) { + names(ddist_funs) <- names(rdist_funs) <- prior.sel[['param_name']] + } + + # `mapply` statement returns + density <- function(params) { + dens_vec <- mapply(function(f, x) f(x), ddist_funs, params) # Returns vector of log densities + out <- sum(dens_vec) + return(out) + } + + # Returns vector of random draws + sampler <- function() { + out <- vapply(rdist_funs, function(f) f(), numeric(1)) + return(out) + } + + # BayesianTools lower and upper bounds and best guess, if specified in data.frame + lower <- NULL + if ('lower' %in% names(prior.sel)) { + lower <- prior.sel[['lower']] + } + upper <- NULL + if ('upper' %in% names(prior.sel)) { + upper <- prior.sel[['upper']] + } + best <- NULL + if ('best' %in% names(prior.sel)) { + best <- prior.sel[['best']] + } + + # Use createPrior{BayesianTools} function to create prior class object compatible + # with rest of the functions + out <- BayesianTools::createPrior(density = density, sampler = sampler, + lower = lower, upper = upper, best = best) + return(out) +} # pda.create.btprior + + +##' Helper function for applying BayesianTools specific settings from PEcAn general settings +##' +##' @title Apply settings for BayesianTools +##' @param settings PEcAn settings +##' +##' @return bt.settings list of runMCMC{BayesianTools} settings +##' +##' @author Istem Fer +##' @export +##' +pda.settings.bt <- function(settings) { + + sampler <- settings$assim.batch$bt.settings$sampler + + iterations <- as.numeric(settings$assim.batch$bt.settings$iter) + optimize <- ifelse(!is.null(settings$assim.batch$bt.settings$optimize), + settings$assim.batch$bt.settings$optimize, + TRUE) + # consoleUpdates = ifelse(!is.null(settings$assim.batch$bt.settings$consoleUpdates), + # as.numeric(settings$assim.batch$bt.settings$consoleUpdates), max(round(iterations/10),100)) + adapt <- ifelse(!is.null(settings$assim.batch$bt.settings$adapt), + settings$assim.batch$bt.settings$adapt, + TRUE) + adaptationInverval = ifelse(!is.null(settings$assim.batch$bt.settings$adaptationInverval), + as.numeric(settings$assim.batch$bt.settings$adaptationInverval), + max(round(iterations/100*5),100)) + adaptationNotBefore <- ifelse(!is.null(settings$assim.batch$bt.settings$adaptationNotBefore), + as.numeric(settings$assim.batch$bt.settings$adaptationNotBefore), + adaptationInverval) + DRlevels <- ifelse(!is.null(settings$assim.batch$bt.settings$DRlevels), + as.numeric(settings$assim.batch$bt.settings$DRlevels), + 1) + if (!is.null(settings$assim.batch$bt.settings$gibbsProbabilities)) { + gibbsProbabilities <- as.numeric(unlist(settings$assim.batch$bt.settings$gibbsProbabilities)) + } else { + gibbsProbabilities <- NULL + } + + if (sampler == "Metropolis") { + bt.settings <- list(iterations = iterations, + optimize = optimize, + DRlevels = DRlevels, + adapt = adapt, + adaptationNotBefore = adaptationNotBefore, + gibbsProbabilities = gibbsProbabilities) + } else if (sampler %in% c("AM", "M", "DRAM", "DR")) { + bt.settings <- list(iterations = iterations, startValue = "prior") + } else if (sampler %in% c("DE", "DEzs", "DREAM", "DREAMzs", "Twalk")) { + bt.settings <- list(iterations = iterations) + } else if (sampler == "SMC") { + bt.settings <- list(initialParticles = list("prior", iterations)) + } else { + logger.error(paste0(sampler, " sampler not found!")) + } + + return(bt.settings) +} # pda.settings.bt + +#' Flexible function to create correlation density plots +#' +#' numeric matrix or data.frame +#' @author Florian Hartig +#' @param mat matrix or data frame of variables +#' @param density type of plot to do +#' @param thin thinning of the matrix to make things faster. Default is to thin to 5000 +#' @param method method for calculating correlations +#' @import IDPmisc +#' @import ellipse +#' @references The code for the correlation density plot originates from Hartig, F.; Dislich, C.; Wiegand, T. & Huth, A. (2014) Technical Note: Approximate Bayesian parameterization of a process-based tropical forest model. Biogeosciences, 11, 1261-1272. +#' @export +#' +correlationPlot <- function(mat, density = "smooth", thin = "auto", method = "pearson", whichParameters = NULL) { + + if (inherits(mat, "bayesianOutput")) { + mat <- getSample(mat, thin = thin, whichParameters = whichParameters, ...) + } + + numPars <- ncol(mat) + names <- colnames(mat) + + panel.hist.dens <- function(x, ...) { + usr <- par("usr") + on.exit(par(usr)) + par(usr = c(usr[1:2], 0, 1.5)) + h <- hist(x, plot = FALSE) + breaks <- h$breaks + nB <- length(breaks) + y <- h$counts + y <- y/max(y) + rect(breaks[-nB], 0, breaks[-1], y, col = "blue4", ...) + } # panel.hist.dens + + # replaced by spearman + panel.cor <- function(x, y, digits = 2, prefix = "", cex.cor, ...) { + usr <- par("usr") + on.exit(par(usr)) + par(usr = c(0, 1, 0, 1)) + r <- cor(x, y, use = "complete.obs", method = method) + txt <- format(c(r, 0.123456789), digits = digits)[1] + txt <- paste0(prefix, txt) + if (missing(cex.cor)) { + cex.cor <- 0.8/strwidth(txt) + } + text(0.5, 0.5, txt, cex = cex.cor * abs(r)) + } # panel.cor + + plotEllipse <- function(x, y) { + usr <- par("usr") + on.exit(par(usr)) + par(usr = c(usr[1:2], 0, 1.5)) + cor <- cor(x, y) + el <- ellipse::ellipse(cor) + polygon(el[, 1] + mean(x), el[, 2] + mean(y), col = "red") + } # plotEllipse + + correlationEllipse <- function(x) { + cor <- cor(x) + ToRGB <- function(x) { + rgb(x[1] / 255, x[2] / 255, x[3] / 255) + } + C1 <- ToRGB(c(178, 24, 43)) + C2 <- ToRGB(c(214, 96, 77)) + C3 <- ToRGB(c(244, 165, 130)) + C4 <- ToRGB(c(253, 219, 199)) + C5 <- ToRGB(c(247, 247, 247)) + C6 <- ToRGB(c(209, 229, 240)) + C7 <- ToRGB(c(146, 197, 222)) + C8 <- ToRGB(c(67, 147, 195)) + C9 <- ToRGB(c(33, 102, 172)) + CustomPalette <- colorRampPalette(rev(c(C1, C2, C3, C4, C5, C6, C7, C8, C9))) + ord <- order(cor[1, ]) + xc <- cor[ord, ord] + colors <- unlist(CustomPalette(100)) + ellipse::plotcorr(xc, col = colors[xc * 50 + 50]) + } # correlationEllipse + + if (density == "smooth") { + pairs(mat, lower.panel = function(...) { + par(new = TRUE) + IDPmisc::ipanel.smooth(...) + }, diag.panel = panel.hist.dens, upper.panel = panel.cor) + } else if (density == "corellipseCor") { + pairs(mat, lower.panel = plotEllipse, diag.panel = panel.hist.dens, upper.panel = panel.cor) + } else if (density == "ellipse") { + correlationEllipse(mat) + } else if (density == F) { + pairs(mat, lower.panel = panel.cor, diag.panel = panel.hist.dens, upper.panel = panel.cor) + } else stop("wrong sensity argument") + + # The if block above is generating return values +} # correlationPlot diff --git a/modules/assim.batch/R/pda.utils.R b/modules/assim.batch/R/pda.utils.R index 765fe2a776a..649c73a38ed 100644 --- a/modules/assim.batch/R/pda.utils.R +++ b/modules/assim.batch/R/pda.utils.R @@ -665,208 +665,6 @@ pda.generate.sf <- function(n.knot, sf, prior.list){ } - -##' Helper function for creating log-priors compatible with BayesianTools package -##' -##' @title Create priors for BayesianTools -##' @param prior.sel prior distributions of the selected parameters -##' -##' @return out prior class object for BayesianTools package -##' -##' @author Istem Fer -##' @export -pda.create.btprior <- function(prior.sel) { - - dens.fn <- samp.fn <- list() - - # TODO: test exponential - for (i in seq_len(nrow(prior.sel))) { - # if(prior.sel$distn[i] == 'exp'){ - # dens.fn[[i]]=paste('d',prior.sel$distn[i],'(x[',i,'],',prior.sel$parama[i],',log=TRUE)',sep='') - # samp.fn[[i]] <- paste('x[',i,']=r',prior.sel$distn[i],'(1,',prior.sel$parama[i],')',sep='') - # }else{ - dens.fn[[i]] <- paste0("d", - prior.sel$distn[i], - "(x[", i, "],", - prior.sel$parama[i], - ",", - prior.sel$paramb[i], - ",log=TRUE)") - samp.fn[[i]] <- paste0("x[", i, "]=r", - prior.sel$distn[i], - "(1,", prior.sel$parama[i], - ",", - prior.sel$paramb[i], - ")") - # } - } - - to.density <- paste(dens.fn, collapse = ",") - to.sampler <- paste(samp.fn, collapse = " ", "\n") - - density <- eval(parse(text = paste0("function(x){ \n return(sum(", to.density, ")) \n }"))) - sampler <- eval(parse(text = paste0("function(){ \n x=rep(NA,", nrow(prior.sel), ") \n", to.sampler, - "return(x) \n ", "}"))) - - # Use createPrior{BayesianTools} function to create prior class object compatible - # with rest of the functions - out <- createPrior(density = density, sampler = sampler) - return(out) -} # pda.create.btprior - - -##' Helper function for applying BayesianTools specific settings from PEcAn general settings -##' -##' @title Apply settings for BayesianTools -##' @param settings PEcAn settings -##' -##' @return bt.settings list of runMCMC{BayesianTools} settings -##' -##' @author Istem Fer -##' @export -##' -pda.settings.bt <- function(settings) { - - sampler <- settings$assim.batch$bt.settings$sampler - - iterations <- as.numeric(settings$assim.batch$bt.settings$iter) - optimize <- ifelse(!is.null(settings$assim.batch$bt.settings$optimize), - settings$assim.batch$bt.settings$optimize, - TRUE) - # consoleUpdates = ifelse(!is.null(settings$assim.batch$bt.settings$consoleUpdates), - # as.numeric(settings$assim.batch$bt.settings$consoleUpdates), max(round(iterations/10),100)) - adapt <- ifelse(!is.null(settings$assim.batch$bt.settings$adapt), - settings$assim.batch$bt.settings$adapt, - TRUE) - adaptationInverval = ifelse(!is.null(settings$assim.batch$bt.settings$adaptationInverval), - as.numeric(settings$assim.batch$bt.settings$adaptationInverval), - max(round(iterations/100*5),100)) - adaptationNotBefore <- ifelse(!is.null(settings$assim.batch$bt.settings$adaptationNotBefore), - as.numeric(settings$assim.batch$bt.settings$adaptationNotBefore), - adaptationInverval) - DRlevels <- ifelse(!is.null(settings$assim.batch$bt.settings$DRlevels), - as.numeric(settings$assim.batch$bt.settings$DRlevels), - 1) - if (!is.null(settings$assim.batch$bt.settings$gibbsProbabilities)) { - gibbsProbabilities <- as.numeric(unlist(settings$assim.batch$bt.settings$gibbsProbabilities)) - } else { - gibbsProbabilities <- NULL - } - - if (sampler == "Metropolis") { - bt.settings <- list(iterations = iterations, - optimize = optimize, - DRlevels = DRlevels, - adapt = adapt, - adaptationNotBefore = adaptationNotBefore, - gibbsProbabilities = gibbsProbabilities) - } else if (sampler %in% c("AM", "M", "DRAM", "DR")) { - bt.settings <- list(iterations = iterations, startValue = "prior") - } else if (sampler %in% c("DE", "DEzs", "DREAM", "DREAMzs", "Twalk")) { - bt.settings <- list(iterations = iterations) - } else if (sampler == "SMC") { - bt.settings <- list(initialParticles = list("prior", iterations)) - } else { - logger.error(paste0(sampler, " sampler not found!")) - } - - return(bt.settings) -} # pda.settings.bt - - -#' Flexible function to create correlation density plots -#' numeric matrix or data.frame -#' @author Florian Hartig -#' @param mat matrix or data frame of variables -#' @param density type of plot to do -#' @param thin thinning of the matrix to make things faster. Default is to thin to 5000 -#' @param method method for calculating correlations -#' @import IDPmisc -#' @import ellipse -#' @references The code for the correlation density plot originates from Hartig, F.; Dislich, C.; Wiegand, T. & Huth, A. (2014) Technical Note: Approximate Bayesian parameterization of a process-based tropical forest model. Biogeosciences, 11, 1261-1272. -#' @export -#' -correlationPlot <- function(mat, density = "smooth", thin = "auto", method = "pearson", whichParameters = NULL) { - - if (inherits(mat, "bayesianOutput")) { - mat <- getSample(mat, thin = thin, whichParameters = whichParameters, ...) - } - - numPars <- ncol(mat) - names <- colnames(mat) - - panel.hist.dens <- function(x, ...) { - usr <- par("usr") - on.exit(par(usr)) - par(usr = c(usr[1:2], 0, 1.5)) - h <- hist(x, plot = FALSE) - breaks <- h$breaks - nB <- length(breaks) - y <- h$counts - y <- y/max(y) - rect(breaks[-nB], 0, breaks[-1], y, col = "blue4", ...) - } # panel.hist.dens - - # replaced by spearman - panel.cor <- function(x, y, digits = 2, prefix = "", cex.cor, ...) { - usr <- par("usr") - on.exit(par(usr)) - par(usr = c(0, 1, 0, 1)) - r <- cor(x, y, use = "complete.obs", method = method) - txt <- format(c(r, 0.123456789), digits = digits)[1] - txt <- paste0(prefix, txt) - if (missing(cex.cor)) { - cex.cor <- 0.8/strwidth(txt) - } - text(0.5, 0.5, txt, cex = cex.cor * abs(r)) - } # panel.cor - - plotEllipse <- function(x, y) { - usr <- par("usr") - on.exit(par(usr)) - par(usr = c(usr[1:2], 0, 1.5)) - cor <- cor(x, y) - el <- ellipse::ellipse(cor) - polygon(el[, 1] + mean(x), el[, 2] + mean(y), col = "red") - } # plotEllipse - - correlationEllipse <- function(x) { - cor <- cor(x) - ToRGB <- function(x) { - rgb(x[1] / 255, x[2] / 255, x[3] / 255) - } - C1 <- ToRGB(c(178, 24, 43)) - C2 <- ToRGB(c(214, 96, 77)) - C3 <- ToRGB(c(244, 165, 130)) - C4 <- ToRGB(c(253, 219, 199)) - C5 <- ToRGB(c(247, 247, 247)) - C6 <- ToRGB(c(209, 229, 240)) - C7 <- ToRGB(c(146, 197, 222)) - C8 <- ToRGB(c(67, 147, 195)) - C9 <- ToRGB(c(33, 102, 172)) - CustomPalette <- colorRampPalette(rev(c(C1, C2, C3, C4, C5, C6, C7, C8, C9))) - ord <- order(cor[1, ]) - xc <- cor[ord, ord] - colors <- unlist(CustomPalette(100)) - ellipse::plotcorr(xc, col = colors[xc * 50 + 50]) - } # correlationEllipse - - if (density == "smooth") { - pairs(mat, lower.panel = function(...) { - par(new = TRUE) - IDPmisc::ipanel.smooth(...) - }, diag.panel = panel.hist.dens, upper.panel = panel.cor) - } else if (density == "corellipseCor") { - pairs(mat, lower.panel = plotEllipse, diag.panel = panel.hist.dens, upper.panel = panel.cor) - } else if (density == "ellipse") { - correlationEllipse(mat) - } else if (density == F) { - pairs(mat, lower.panel = panel.cor, diag.panel = panel.hist.dens, upper.panel = panel.cor) - } else stop("wrong sensity argument") - - # The if block above is generating return values -} # correlationPlot - ##' @title return.bias ##' @author Istem Fer ##' @export diff --git a/modules/assim.batch/man/correlationPlot.Rd b/modules/assim.batch/man/correlationPlot.Rd index e55004137a8..14d9b0d61c8 100644 --- a/modules/assim.batch/man/correlationPlot.Rd +++ b/modules/assim.batch/man/correlationPlot.Rd @@ -1,9 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pda.utils.R +% Please edit documentation in R/pda.bayestools.helpers.R \name{correlationPlot} \alias{correlationPlot} -\title{Flexible function to create correlation density plots -numeric matrix or data.frame} +\title{Flexible function to create correlation density plots} \usage{ correlationPlot(mat, density = "smooth", thin = "auto", method = "pearson", whichParameters = NULL) @@ -18,7 +17,6 @@ correlationPlot(mat, density = "smooth", thin = "auto", \item{method}{method for calculating correlations} } \description{ -Flexible function to create correlation density plots numeric matrix or data.frame } \references{ diff --git a/modules/assim.batch/man/pda.create.btprior.Rd b/modules/assim.batch/man/pda.create.btprior.Rd index 141abd81401..d6e4dba940b 100644 --- a/modules/assim.batch/man/pda.create.btprior.Rd +++ b/modules/assim.batch/man/pda.create.btprior.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pda.utils.R +% Please edit documentation in R/pda.bayestools.helpers.R \name{pda.create.btprior} \alias{pda.create.btprior} \title{Create priors for BayesianTools} @@ -7,14 +7,24 @@ pda.create.btprior(prior.sel) } \arguments{ -\item{prior.sel}{prior distributions of the selected parameters} +\item{prior.sel}{`data.frame` containing prior distributions of the selected parameters} } \value{ -out prior class object for BayesianTools package +out Prior class object for BayesianTools package } \description{ Helper function for creating log-priors compatible with BayesianTools package } +\details{ +`prior.sel` must contain the following columns: + * `distn` -- String describing a distribution; e.g. `norm` for `dnorm`, `rnorm`, etc. + * `parama`, `paramb` -- First and second parameters, respectively, of the corresponding distribution + +Optionally, `prior.sel` may also contain the following columns: + * `param_name` -- Parameter name, which will be carried through to the prior object and sampler + * `lower`, `upper` -- Lower and upper bounds, respectively. These can be leveraged by the BayesianTools samplers. + * `best` -- Best guess for a parameter estimate. BayesianTools can also use this, though I'm not sure how... +} \author{ -Istem Fer +Istem Fer, Alexey Shiklomanov } diff --git a/modules/assim.batch/man/pda.settings.bt.Rd b/modules/assim.batch/man/pda.settings.bt.Rd index 361dcbafe59..2e2008913bf 100644 --- a/modules/assim.batch/man/pda.settings.bt.Rd +++ b/modules/assim.batch/man/pda.settings.bt.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pda.utils.R +% Please edit documentation in R/pda.bayestools.helpers.R \name{pda.settings.bt} \alias{pda.settings.bt} \title{Apply settings for BayesianTools} diff --git a/modules/assim.batch/tests/testthat/test.bt_prior.R b/modules/assim.batch/tests/testthat/test.bt_prior.R new file mode 100644 index 00000000000..b892043e0ad --- /dev/null +++ b/modules/assim.batch/tests/testthat/test.bt_prior.R @@ -0,0 +1,37 @@ +library(PEcAn.assim.batch) +library(testthat) +context("BayesianTools prior functions") + +prior_list <- list(list('normal', 'norm', 0.5, 2), + list('lognormal', 'lnorm', 1, 1), + list('gamma', 'gamma', 0.5, 0.5)) +prior_df <- do.call(rbind.data.frame, prior_list) +colnames(prior_df) <- c('param_name', 'distn', 'parama', 'paramb') + +prior <- pda.create.btprior(prior_df) + +x <- c(2, 3, 4) +correct_dens <- with(prior_df, dnorm(x[1], parama[1], paramb[1], log = TRUE) + + dlnorm(x[2], parama[2], paramb[2], log = TRUE) + + dgamma(x[3], parama[3], paramb[3], log = TRUE)) +prior_dens <- prior$density(x) + +test_that('Prior returns correct density', expect_equal(correct_dens, prior_dens)) + +correct_mean <- with(prior_df, c(parama[1], + exp(parama[2] + paramb[2]^2 / 2), + parama[3] / paramb[3])) +correct_var <- with(prior_df, c(paramb[1]^2, + (exp(paramb[2]^2) - 1) * exp(2 * parama[2] + paramb[2]^2), + parama[3] / paramb[3]^2)) +names(correct_mean) <- names(correct_var) <- prior_df[['param_name']] + +nsamp <- 10000 +prior_samples <- vapply(seq_len(nsamp), function(x) prior$sampler(), numeric(3)) +prior_sampmean <- rowMeans(prior_samples) +prior_sampvar <- apply(prior_samples, 1, var) + +test_that('Prior sampler returns reasonable values', { + expect_equal(correct_mean, prior_sampmean, tolerance = 0.1) + expect_equal(correct_var, prior_sampvar, tolerance = 0.25) + }) From 90424290090c8ad050bc7e3e43242e6e9f9d6de0 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 1 Aug 2017 19:31:19 -0400 Subject: [PATCH 330/771] First pass at BayesianTools inversion --- modules/rtm/.gitignore | 2 + modules/rtm/DESCRIPTION | 7 +- modules/rtm/NAMESPACE | 2 + modules/rtm/R/bayestools.R | 133 ++++++++++++++++++++++++ modules/rtm/R/neff.R | 10 +- modules/rtm/man/bt_check_convergence.Rd | 12 +++ modules/rtm/man/corr_max_lag.Rd | 11 ++ modules/rtm/man/invert_bt.Rd | 11 ++ modules/rtm/man/neff.Rd | 2 +- modules/rtm/man/prospect_bt_prior.Rd | 11 ++ modules/rtm/man/rtm_loglike.Rd | 11 ++ modules/rtm/tests/invert_bt.R | 15 +++ 12 files changed, 220 insertions(+), 7 deletions(-) create mode 100644 modules/rtm/R/bayestools.R create mode 100644 modules/rtm/man/bt_check_convergence.Rd create mode 100644 modules/rtm/man/corr_max_lag.Rd create mode 100644 modules/rtm/man/invert_bt.Rd create mode 100644 modules/rtm/man/prospect_bt_prior.Rd create mode 100644 modules/rtm/man/rtm_loglike.Rd create mode 100644 modules/rtm/tests/invert_bt.R diff --git a/modules/rtm/.gitignore b/modules/rtm/.gitignore index f7f39d3c92a..bb44ce8bfba 100644 --- a/modules/rtm/.gitignore +++ b/modules/rtm/.gitignore @@ -17,3 +17,5 @@ check # R profile output */Rprof.out **/Rprof.out + +**/.scratch.R diff --git a/modules/rtm/DESCRIPTION b/modules/rtm/DESCRIPTION index 38e5fb809a5..908115e955b 100644 --- a/modules/rtm/DESCRIPTION +++ b/modules/rtm/DESCRIPTION @@ -20,11 +20,8 @@ Suggests: PEcAn.utils, PEcAn.ED2, testthat (>= 1.0.2), - knitr -Remotes: - github::pecanproject/pecan/modules/assim.batch, - github::pecanproject/pecan/models/ed, - github::pecanproject/pecan/utils + knitr, + pwr OS_type: unix License: FreeBSD + file LICENSE Copyright: Authors diff --git a/modules/rtm/NAMESPACE b/modules/rtm/NAMESPACE index d6f636c40bb..99e65a0c509 100644 --- a/modules/rtm/NAMESPACE +++ b/modules/rtm/NAMESPACE @@ -17,6 +17,7 @@ export(get.EDR.output) export(invert.auto) export(invert.custom) export(invert.lsq) +export(invert_bt) export(load.from.name) export(lognorm.mu) export(lognorm.sigma) @@ -30,6 +31,7 @@ export(priorfunc.prospect) export(pro2s) export(pro4sail) export(prospect) +export(prospect_bt_prior) export(rtnorm) export(sensor.list) export(sensor.proper) diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R new file mode 100644 index 00000000000..dde102512b2 --- /dev/null +++ b/modules/rtm/R/bayestools.R @@ -0,0 +1,133 @@ +#' Generic log-likelihood generator for RTMs +rtm_loglike <- function(nparams, model, observed, lag.max = 0.01, ...) { + fail_ll <- -1e10 + stopifnot(nparams >= 1, nparams %% 1 == 0, is.function(model), is.numeric(observed)) + n_obs <- length(observed) + out <- function(x) { + rtm_params <- x[seq_len(nparams)] + rsd <- x[nparams + 1] + mod <- model(rtm_params, ...) + if (any(is.na(mod))) return(fail_ll) + err <- mod - observed + ss <- sum(err * err) + sigma2 <- rsd * rsd + n_eff <- neff(err, lag.max = lag.max) + sigma2eff <- sigma2 * n_obs / n_eff + ll <- -0.5 * (n_obs * log(sigma2eff) + ss / sigma2eff) + if (is.na(ll)) return(fail_ll) + return(ll) + } + return(out) +} + +#' Check convergence of BayesianTools output +bt_check_convergence <- function(samples, threshold = 1.1, use_CI = TRUE, use_mpsrf = TRUE) { + i <- ifelse(use_CI, 2, 1) + gelman <- BayesianTools::gelmanDiagnostics(samples) + if (use_mpsrf) { + gelman_vec <- c(gelman$psrf[,i], mpsrf = gelman$mpsrf) + } else { + gelman_vec <- gelman$psrf[,i] + } + exceeds <- gelman_vec > threshold + if (any(exceeds)) { + exceeds_vec <- gelman_vec[exceeds] + exceeds_char <- sprintf('%s: %.2f', names(exceeds_vec), exceeds_vec) + exceeds_str <- paste(exceeds_char, collapse = '; ') + message('The following parameters exceed threshold: ', exceeds_str) + return(FALSE) + } else { + return(TRUE) + } +} + +#' Quick BayesianTools prior creator for PROSPECT model +#' +#' @export +prospect_bt_prior <- function(version, custom_prior = list()) { + col_names <- c('param_name', 'distn', 'parama', 'paramb', 'lower') + prior_default_list <- list(N = list('N', 'norm', 1.4, 0.8, 1), + Cab = list('Cab', 'lnorm', log(40), 0.9, 0), + Car = list('Car', 'lnorm', log(10), 1.1, 0), + Cbrown = list('Cbrown', 'lnorm', log(1), 1.1, 0), + Cw = list('Cw', 'lnorm', log(0.01), 1, 0), + Cm = list('Cm', 'lnorm', log(0.009), 1, 0), + residual = list('residual', 'lnorm', log(0.001), 2.5, 0) + ) + prior_list <- modifyList(prior_default_list, custom_prior) + prior_df_all <- do.call(rbind.data.frame, prior_list) + colnames(prior_df_all) <- col_names + default_params <- defparam(paste0('prospect_', tolower(version))) + use_names <- c(names(default_params), 'residual') + prior_df <- prior_df_all[prior_df_all[['param_name']] %in% use_names,] + prior <- PEcAn.assim.batch::pda.create.btprior(prior_df) + return(prior) +} + +#' Perform Bayesian inversion using BayesianTools package +#' +#' @export +invert_bt <- function(observed, model, prior, custom_settings = list()) { + + default_settings <- list(common = list(), + init = list(iterations = 10000), + loop = list(iterations = 2000), + other = list(sampler = 'DEzs', + use_mpsrf = FALSE, + min_samp = 1000)) + + for (s in seq_along(default_settings)) { + s_name <- names(default_settings)[s] + if (s_name %in% names(custom_settings)) { + settings[[s_name]] <- modifyList(default_settings[[s_name]], + custom_settings[[s_name]]) + } else { + settings[[s_name]] <- default_settings[[s_name]] + } + } + + use_mpsrf <- settings[['other']][['use_mpsrf']] + min_samp <- settings[['other']][['min_samp']] + lag.max <- settings[['other']][['lag.max']] + + stopifnot('prior' %in% class(prior)) + test_samp <- prior$sampler() + param_names <- names(test_samp) + nparams <- length(test_samp[param_names != 'residual']) + loglike <- rtm_loglike(nparams = nparams, + model = model, + observed = observed, + lag.max = lag.max) + + + setup <- createBayesianSetup(likelihood = loglike, + prior = prior, + names = param_names) + + + init_settings <- modifyList(settings[['common']], settings[['init']]) + samples <- BayesianTools::runMCMC(bayesianSetup = setup, + sampler = settings[['other']][['sampler']], + settings = init_settings) + converged <- bt_check_convergence(samples = samples, use_mpsrf = settings[['other']][['use_mpsrf']]) + + loop_settings <- modifyList(settings[['common']], settings[['loop']]) + + while(!(converged && enough_samples)) { + samples <- BayesianTools::runMCMC(samples, sampler = sampler, settings = loop_settings) + converged <- bt_check_convergence(samples = samples, use_mpsrf = settings[['other']][['use_mpsrf']]) + if (converged) { + coda_samples <- BayesianTools::getSample(samples, coda = TRUE) + burned_samples <- PEcAn.assim.batch::autoburnin(coda_samples, return.burnin = TRUE, method = 'gelman.plot') + if (burned_samples$burnin == 1) next + n_samples <- coda::niter(burned_samples$samples) + enough_samples <- n_samples > min_samp + if (!enough_samples) { + message(n_samples, ' samples after burnin is less than target ', min_samp, + '. Resuming sampling.') + } + } + } + return(samples) +} + diff --git a/modules/rtm/R/neff.R b/modules/rtm/R/neff.R index d014cb9a312..4f4202d3f26 100644 --- a/modules/rtm/R/neff.R +++ b/modules/rtm/R/neff.R @@ -3,7 +3,7 @@ #' Calculate effective sample size of vector based on its autocorrelation. #' @param x A vector or time series #' @export -neff <- function(x) { +neff <- function(x, ...) { UseMethod("neff") } @@ -32,3 +32,11 @@ neff.matrix <- function(x, ...) { col_neff <- apply(x, 2, neff.default, ...) return(sum(col_neff)) } + +#' Calculate max ACF lag from correlation power analysis +corr_max_lag <- function(nx, r = 0.1, sig.level = 0.05, power = 0.95, ...) { + testForPackage('pwr') + power_analysis <- pwr::pwr.r.test(n = NULL, r = r, sig.level = sig.level, power = power, ...) + nlag <- ceiling(nx - power_analysis$n) + return(nlag) +} diff --git a/modules/rtm/man/bt_check_convergence.Rd b/modules/rtm/man/bt_check_convergence.Rd new file mode 100644 index 00000000000..8e68a505e6f --- /dev/null +++ b/modules/rtm/man/bt_check_convergence.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bayestools.R +\name{bt_check_convergence} +\alias{bt_check_convergence} +\title{Check convergence of BayesianTools output} +\usage{ +bt_check_convergence(samples, threshold = 1.1, use_CI = TRUE, + use_mpsrf = TRUE) +} +\description{ +Check convergence of BayesianTools output +} diff --git a/modules/rtm/man/corr_max_lag.Rd b/modules/rtm/man/corr_max_lag.Rd new file mode 100644 index 00000000000..17eeec2cd93 --- /dev/null +++ b/modules/rtm/man/corr_max_lag.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/neff.R +\name{corr_max_lag} +\alias{corr_max_lag} +\title{Calculate max ACF lag from correlation power analysis} +\usage{ +corr_max_lag(nx, r = 0.1, sig.level = 0.05, power = 0.95, ...) +} +\description{ +Calculate max ACF lag from correlation power analysis +} diff --git a/modules/rtm/man/invert_bt.Rd b/modules/rtm/man/invert_bt.Rd new file mode 100644 index 00000000000..4a4e9360cdf --- /dev/null +++ b/modules/rtm/man/invert_bt.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bayestools.R +\name{invert_bt} +\alias{invert_bt} +\title{Perform Bayesian inversion using BayesianTools package} +\usage{ +invert_bt(observed, model, prior, custom_settings = list()) +} +\description{ +Perform Bayesian inversion using BayesianTools package +} diff --git a/modules/rtm/man/neff.Rd b/modules/rtm/man/neff.Rd index 98551e18b14..97fa3eed012 100644 --- a/modules/rtm/man/neff.Rd +++ b/modules/rtm/man/neff.Rd @@ -4,7 +4,7 @@ \alias{neff} \title{Effective sample size} \usage{ -neff(x) +neff(x, ...) } \arguments{ \item{x}{A vector or time series} diff --git a/modules/rtm/man/prospect_bt_prior.Rd b/modules/rtm/man/prospect_bt_prior.Rd new file mode 100644 index 00000000000..2d2e2854070 --- /dev/null +++ b/modules/rtm/man/prospect_bt_prior.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bayestools.R +\name{prospect_bt_prior} +\alias{prospect_bt_prior} +\title{Quick BayesianTools prior creator for PROSPECT model} +\usage{ +prospect_bt_prior(version, custom_prior = list()) +} +\description{ +Quick BayesianTools prior creator for PROSPECT model +} diff --git a/modules/rtm/man/rtm_loglike.Rd b/modules/rtm/man/rtm_loglike.Rd new file mode 100644 index 00000000000..2eea76e9edd --- /dev/null +++ b/modules/rtm/man/rtm_loglike.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/bayestools.R +\name{rtm_loglike} +\alias{rtm_loglike} +\title{Generic log-likelihood generator for RTMs} +\usage{ +rtm_loglike(nparams, model, observed, lag.max = 0.01, ...) +} +\description{ +Generic log-likelihood generator for RTMs +} diff --git a/modules/rtm/tests/invert_bt.R b/modules/rtm/tests/invert_bt.R new file mode 100644 index 00000000000..92f287bff54 --- /dev/null +++ b/modules/rtm/tests/invert_bt.R @@ -0,0 +1,15 @@ +#devtools::load_all('assim.batch') +#devtools::load_all('rtm') +library(PEcAnRTM) + +#observed <- prospect(defparam('prospect_5'), 5)[,1] + generate.noise() +data(testspec) +observed <- testspec_ACRU[,5] +model <- function(x) prospect(x, 5)[,1] +prior <- PEcAn.assim.batch::prospect_bt_prior(5) +custom_settings <- list() +samples <- invert_bt(observed = observed, model = model, prior = prior, + custom_settings = list()) + +s <- getSample(samples, start = 400, coda = TRUE) +traceplot(s[,2]) From 65a238afc4326001f49f1a3ca99024a861619efb Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 2 Aug 2017 16:33:33 -0400 Subject: [PATCH 331/771] Fully functional BayesianTools inversion --- modules/rtm/R/bayestools.R | 29 ++++++++++++------- modules/rtm/R/invert.auto.R | 2 +- modules/rtm/tests/invert_bt.R | 15 ---------- .../tests/testthat/test.invert_bayestools.R | 18 ++++++++++++ 4 files changed, 37 insertions(+), 27 deletions(-) delete mode 100644 modules/rtm/tests/invert_bt.R create mode 100644 modules/rtm/tests/testthat/test.invert_bayestools.R diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R index dde102512b2..732471ae4b7 100644 --- a/modules/rtm/R/bayestools.R +++ b/modules/rtm/R/bayestools.R @@ -76,14 +76,18 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { use_mpsrf = FALSE, min_samp = 1000)) - for (s in seq_along(default_settings)) { - s_name <- names(default_settings)[s] - if (s_name %in% names(custom_settings)) { - settings[[s_name]] <- modifyList(default_settings[[s_name]], - custom_settings[[s_name]]) - } else { - settings[[s_name]] <- default_settings[[s_name]] - } + if (length(custom_settings) > 0) { + for (s in seq_along(default_settings)) { + s_name <- names(default_settings)[s] + if (s_name %in% names(custom_settings)) { + settings[[s_name]] <- modifyList(default_settings[[s_name]], + custom_settings[[s_name]]) + } else { + settings[[s_name]] <- default_settings[[s_name]] + } + } + } else { + settings <- default_settings } use_mpsrf <- settings[['other']][['use_mpsrf']] @@ -100,9 +104,9 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { lag.max = lag.max) - setup <- createBayesianSetup(likelihood = loglike, - prior = prior, - names = param_names) + setup <- BayesianTools::createBayesianSetup(likelihood = loglike, + prior = prior, + names = param_names) init_settings <- modifyList(settings[['common']], settings[['init']]) @@ -113,6 +117,9 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { loop_settings <- modifyList(settings[['common']], settings[['loop']]) + last_iter <- 1 + current_iter <- + while(!(converged && enough_samples)) { samples <- BayesianTools::runMCMC(samples, sampler = sampler, settings = loop_settings) converged <- bt_check_convergence(samples = samples, use_mpsrf = settings[['other']][['use_mpsrf']]) diff --git a/modules/rtm/R/invert.auto.R b/modules/rtm/R/invert.auto.R index b930e76279c..fc93488bd22 100644 --- a/modules/rtm/R/invert.auto.R +++ b/modules/rtm/R/invert.auto.R @@ -309,7 +309,7 @@ process_output <- function(output.list, message("Passed initial convergence check.") } if (calculate.burnin) { - burn <- PEcAn.assim.batch::autoburnin(out$samples, return.burnin = TRUE) + burn <- PEcAn.assim.batch::autoburnin(out$samples, return.burnin = TRUE, method = 'gelman.plot') out$burnin <- burn$burnin if (out$burnin == 1) { message("Robust convergence check in autoburnin failed. ", diff --git a/modules/rtm/tests/invert_bt.R b/modules/rtm/tests/invert_bt.R deleted file mode 100644 index 92f287bff54..00000000000 --- a/modules/rtm/tests/invert_bt.R +++ /dev/null @@ -1,15 +0,0 @@ -#devtools::load_all('assim.batch') -#devtools::load_all('rtm') -library(PEcAnRTM) - -#observed <- prospect(defparam('prospect_5'), 5)[,1] + generate.noise() -data(testspec) -observed <- testspec_ACRU[,5] -model <- function(x) prospect(x, 5)[,1] -prior <- PEcAn.assim.batch::prospect_bt_prior(5) -custom_settings <- list() -samples <- invert_bt(observed = observed, model = model, prior = prior, - custom_settings = list()) - -s <- getSample(samples, start = 400, coda = TRUE) -traceplot(s[,2]) diff --git a/modules/rtm/tests/testthat/test.invert_bayestools.R b/modules/rtm/tests/testthat/test.invert_bayestools.R new file mode 100644 index 00000000000..0d449f7b067 --- /dev/null +++ b/modules/rtm/tests/testthat/test.invert_bayestools.R @@ -0,0 +1,18 @@ +#devtools::load_all('.') +library(PEcAnRTM) +library(testthat) +context('Inversion using BayesianTools') + +true_params <- defparam('prospect_5') +model <- function(x) prospect(x, 5)[,1] +observed <- model(true_params) + generate.noise() +prior <- prospect_bt_prior(5) +custom_settings <- list() +samples <- invert_bt(observed = observed, model = model, prior = prior, + custom_settings = list()) + +samples_burned <- PEcAn.assim.batch::autoburnin(BayesianTools::getSample(samples, coda = TRUE), method = 'gelman.plot') +mean_estimates <- do.call(cbind, summary(samples_burned)[c('statistics', 'quantiles')]) + +test_that('Mean estimates are within 10% of true values', + expect_equal(true_params, mean_estimates[seq_along(true_params),'Mean'], tol = 0.1)) From 5009d2e88d358f196e657dc7c88c76b49b6a1cc2 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 2 Aug 2017 16:59:52 -0400 Subject: [PATCH 332/771] Cleanup of BayesianTools inversion in PEcAnRTM --- modules/rtm/R/bayestools.R | 30 ++++++++++++++- modules/rtm/man/invert_bt.Rd | 37 ++++++++++++++++++- modules/rtm/man/prospect_bt_prior.Rd | 5 +++ .../tests/testthat/test.invert_bayestools.R | 26 +++++++------ 4 files changed, 85 insertions(+), 13 deletions(-) diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R index 732471ae4b7..005ac6b0545 100644 --- a/modules/rtm/R/bayestools.R +++ b/modules/rtm/R/bayestools.R @@ -42,7 +42,9 @@ bt_check_convergence <- function(samples, threshold = 1.1, use_CI = TRUE, use_mp } #' Quick BayesianTools prior creator for PROSPECT model -#' +#' +#' @param custom_prior List containing `param_name`, `distn`, `parama`, `paramb`, and `lower` +#' @inheritParams prospect #' @export prospect_bt_prior <- function(version, custom_prior = list()) { col_names <- c('param_name', 'distn', 'parama', 'paramb', 'lower') @@ -66,6 +68,32 @@ prospect_bt_prior <- function(version, custom_prior = list()) { #' Perform Bayesian inversion using BayesianTools package #' +#' Use samplers from the BayesianTools package to fit models to data. Like +#' `invert.auto`, this will continue to run until convergence is achieved +#' (based on Gelman diagnostic) _and_ the result has enough samples (as +#' specified by the user; see Details). +#' +#' @details `custom_settings` is a list of lists, containing the following: +#' * `common` -- BayesianTools settings common to both the initial and subsequent samples. +#' * `init` -- BayesianTools settings for just the first round of sampling. +#' This is most common for the initial number of iterations, which is the +#' minimum expected for convergence. +#' * `loop` -- BayesianTools settings for iterations inside the convergence +#' checking `while` loop. This is most commonly for setting a smaller +#' iteration count than in `init`. +#' * `other` -- Miscellaneous (non-BayesianTools) settings, including: +#' - `sampler` -- String describing which sampler to use. Default is `DEzs` +#' - `use_mpsrf` -- Use the multivariate PSRF to check convergence. +#' Default is `FALSE` because it may be an excessively conservative +#' diagnostic. +#' - `min_samp` -- Minimum number of samples after burnin before stopping. +#' +#' See the BayesianTools sampler documentation for what can go in the `BayesianTools` settings lists. +#' @param observed Vector of observations +#' @param model Function called by log-likelihood. Must be `function(params)` +#' and return a vector equal to `length(observed)` or `nrow(observed)`. +#' @param prior BayesianTools prior object. +#' @param custom_settings Nested settings list. See Details. #' @export invert_bt <- function(observed, model, prior, custom_settings = list()) { diff --git a/modules/rtm/man/invert_bt.Rd b/modules/rtm/man/invert_bt.Rd index 4a4e9360cdf..c3faa685c3d 100644 --- a/modules/rtm/man/invert_bt.Rd +++ b/modules/rtm/man/invert_bt.Rd @@ -6,6 +6,41 @@ \usage{ invert_bt(observed, model, prior, custom_settings = list()) } +\arguments{ +\item{observed}{Vector of observations} + +\item{model}{Function called by log-likelihood. Must be \code{function(params)} +and return a vector equal to \code{length(observed)} or \code{nrow(observed)}.} + +\item{prior}{BayesianTools prior object.} + +\item{custom_settings}{Nested settings list. See Details.} +} \description{ -Perform Bayesian inversion using BayesianTools package +Use samplers from the BayesianTools package to fit models to data. Like +\code{invert.auto}, this will continue to run until convergence is achieved +(based on Gelman diagnostic) \emph{and} the result has enough samples (as +specified by the user; see Details). +} +\details{ +\code{custom_settings} is a list of lists, containing the following: +\itemize{ +\item \code{common} -- BayesianTools settings common to both the initial and subsequent samples. +\item \code{init} -- BayesianTools settings for just the first round of sampling. +This is most common for the initial number of iterations, which is the +minimum expected for convergence. +\item \code{loop} -- BayesianTools settings for iterations inside the convergence +checking \code{while} loop. This is most commonly for setting a smaller +iteration count than in \code{init}. +\item \code{other} -- Miscellaneous (non-BayesianTools) settings, including: +\itemize{ +\item \code{sampler} -- String describing which sampler to use. Default is \code{DEzs} +\item \code{use_mpsrf} -- Use the multivariate PSRF to check convergence. +Default is \code{FALSE} because it may be an excessively conservative +diagnostic. +\item \code{min_samp} -- Minimum number of samples after burnin before stopping. +} +} + +See the BayesianTools sampler documentation for what can go in the \code{BayesianTools} settings lists. } diff --git a/modules/rtm/man/prospect_bt_prior.Rd b/modules/rtm/man/prospect_bt_prior.Rd index 2d2e2854070..d27bb26a54b 100644 --- a/modules/rtm/man/prospect_bt_prior.Rd +++ b/modules/rtm/man/prospect_bt_prior.Rd @@ -6,6 +6,11 @@ \usage{ prospect_bt_prior(version, custom_prior = list()) } +\arguments{ +\item{version}{PROSPECT version: 4, 5, or '5B'} + +\item{custom_prior}{List containing \code{param_name}, \code{distn}, \code{parama}, \code{paramb}, and \code{lower}} +} \description{ Quick BayesianTools prior creator for PROSPECT model } diff --git a/modules/rtm/tests/testthat/test.invert_bayestools.R b/modules/rtm/tests/testthat/test.invert_bayestools.R index 0d449f7b067..384831efeb7 100644 --- a/modules/rtm/tests/testthat/test.invert_bayestools.R +++ b/modules/rtm/tests/testthat/test.invert_bayestools.R @@ -3,16 +3,20 @@ library(PEcAnRTM) library(testthat) context('Inversion using BayesianTools') -true_params <- defparam('prospect_5') -model <- function(x) prospect(x, 5)[,1] -observed <- model(true_params) + generate.noise() -prior <- prospect_bt_prior(5) -custom_settings <- list() -samples <- invert_bt(observed = observed, model = model, prior = prior, - custom_settings = list()) +if (Sys.getenv('CI') == 'true') { + message('Skipping inversion tests on CI system') +} else { + true_params <- defparam('prospect_5') + model <- function(x) prospect(x, 5)[,1] + observed <- model(true_params) + generate.noise() + prior <- prospect_bt_prior(5) + custom_settings <- list() + samples <- invert_bt(observed = observed, model = model, prior = prior, + custom_settings = list()) -samples_burned <- PEcAn.assim.batch::autoburnin(BayesianTools::getSample(samples, coda = TRUE), method = 'gelman.plot') -mean_estimates <- do.call(cbind, summary(samples_burned)[c('statistics', 'quantiles')]) + samples_burned <- PEcAn.assim.batch::autoburnin(BayesianTools::getSample(samples, coda = TRUE), method = 'gelman.plot') + mean_estimates <- do.call(cbind, summary(samples_burned)[c('statistics', 'quantiles')]) -test_that('Mean estimates are within 10% of true values', - expect_equal(true_params, mean_estimates[seq_along(true_params),'Mean'], tol = 0.1)) + test_that('Mean estimates are within 10% of true values', + expect_equal(true_params, mean_estimates[seq_along(true_params),'Mean'], tol = 0.1)) +} From 8cd502f0afaef7a829cf21f520c45519bffe1e75 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Sat, 5 Aug 2017 21:09:28 -0400 Subject: [PATCH 333/771] Move base packages inside `base` directory --- CHANGELOG.md | 4 + Makefile | 9 +- {all => base/all}/DESCRIPTION | 0 {all => base/all}/LICENSE | 0 {all => base/all}/NAMESPACE | 0 {all => base/all}/data/pecan.packages.csv | 0 {all => base/all}/inst/CITATION | 0 {all => base/all}/tests/testthat.R | 0 .../all}/tests/testthat/test.workflow.R | 0 {db => base/db}/DESCRIPTION | 0 {db => base/db}/LICENSE | 0 {db => base/db}/NAMESPACE | 0 {db => base/db}/R/dbfiles.R | 0 {db => base/db}/R/get.trait.data.R | 0 {db => base/db}/R/input.name.check.R | 0 {db => base/db}/R/priordupe.R | 0 {db => base/db}/R/query.base.R | 0 {db => base/db}/R/query.dplyr.R | 0 {db => base/db}/R/query.file.path.R | 0 {db => base/db}/R/query.format.vars.R | 0 {db => base/db}/R/query.pft.R | 0 {db => base/db}/R/query.prior.R | 0 {db => base/db}/R/query.site.R | 0 {db => base/db}/R/query.trait.data.R | 0 {db => base/db}/R/query.traits.R | 0 {db => base/db}/R/utils.R | 0 .../db}/inst/PFT_builder/PFT_builder.R | 0 {db => base/db}/inst/bety_mstmip_lookup.csv | 0 {db => base/db}/inst/create.db.subset.sh | 0 {db => base/db}/inst/dump.db.sh | 0 {db => base/db}/inst/dump.db.subset.sh | 0 .../ForestGEO_spp_website.csv | 0 .../import-ForestGEO/import_species_list.R | 0 {db => base/db}/inst/import-try/.gitignore | 0 .../db}/inst/import-try/01.global.subset.R | 0 .../inst/import-try/02.data.specific.subset.R | 0 .../db}/inst/import-try/03.create.try.sites.R | 0 .../db}/inst/import-try/04.match.species.R | 0 .../db}/inst/import-try/05.citations.R | 0 .../db}/inst/import-try/06.load.data.R | 0 {db => base/db}/inst/import-try/README.md | 0 {db => base/db}/inst/import-try/common.R | 0 .../db}/inst/import-try/helpers.species.R | 0 .../db}/inst/import-try/misc/add.self.sql | 0 .../db}/inst/mysql2psql_validation.Rmd | 0 {db => base/db}/man/append.covariate.Rd | 0 .../db}/man/arrhenius.scaling.traits.Rd | 0 {db => base/db}/man/assign.treatments.Rd | 0 {db => base/db}/man/betyConnect.Rd | 0 {db => base/db}/man/check.lists.Rd | 0 {db => base/db}/man/db.close.Rd | 0 {db => base/db}/man/db.exists.Rd | 0 {db => base/db}/man/db.getShowQueries.Rd | 0 {db => base/db}/man/db.open.Rd | 0 {db => base/db}/man/db.print.connections.Rd | 0 {db => base/db}/man/db.query.Rd | 0 {db => base/db}/man/db.showQueries.Rd | 0 {db => base/db}/man/dbHostInfo.Rd | 0 {db => base/db}/man/dbfile.check.Rd | 0 {db => base/db}/man/dbfile.file.Rd | 0 {db => base/db}/man/dbfile.input.check.Rd | 0 {db => base/db}/man/dbfile.input.insert.Rd | 0 {db => base/db}/man/dbfile.insert.Rd | 0 {db => base/db}/man/dbfile.posterior.check.Rd | 0 .../db}/man/dbfile.posterior.insert.Rd | 0 {db => base/db}/man/derive.trait.Rd | 0 {db => base/db}/man/derive.traits.Rd | 0 {db => base/db}/man/dplyr.count.Rd | 0 {db => base/db}/man/fancy_scientific.Rd | 0 {db => base/db}/man/fetch.stats2se.Rd | 0 {db => base/db}/man/filter_sunleaf_traits.Rd | 0 {db => base/db}/man/get.id.Rd | 0 {db => base/db}/man/get.trait.data.Rd | 0 {db => base/db}/man/get.trait.data.pft.Rd | 0 {db => base/db}/man/get_run_ids.Rd | 0 {db => base/db}/man/get_users.Rd | 0 {db => base/db}/man/get_var_names.Rd | 0 {db => base/db}/man/get_workflow_ids.Rd | 0 {db => base/db}/man/killdbcons.Rd | 0 {db => base/db}/man/load_data_single_run.Rd | 0 {db => base/db}/man/ncdays2date.Rd | 0 {db => base/db}/man/priordupe.Rd | 0 {db => base/db}/man/query.base.Rd | 0 {db => base/db}/man/query.base.con.Rd | 0 {db => base/db}/man/query.close.Rd | 0 {db => base/db}/man/query.covariates.Rd | 0 {db => base/db}/man/query.data.Rd | 0 {db => base/db}/man/query.file.path.Rd | 0 {db => base/db}/man/query.format.vars.Rd | 0 {db => base/db}/man/query.pft_species.Rd | 0 {db => base/db}/man/query.priors.Rd | 0 {db => base/db}/man/query.site.Rd | 0 {db => base/db}/man/query.trait.data.Rd | 0 {db => base/db}/man/query.traits.Rd | 0 {db => base/db}/man/query.yields.Rd | 0 {db => base/db}/man/rename.jags.columns.Rd | 0 {db => base/db}/man/runs.Rd | 0 {db => base/db}/man/take.samples.Rd | 0 {db => base/db}/man/var_names_all.Rd | 0 {db => base/db}/man/workflow.Rd | 0 {db => base/db}/man/workflows.Rd | 0 {db => base/db}/tests/testthat.R | 0 {db => base/db}/tests/testthat/db.setup.R | 0 .../db}/tests/testthat/test.contents_sanity.R | 0 .../db}/tests/testthat/test.db.utils.R | 0 .../db}/tests/testthat/test.derive.traits.R | 0 .../db}/tests/testthat/test.query.base.R | 0 {db => base/db}/vignettes/betydb_access.Rmd | 0 .../db}/vignettes/create_sites.geometry.Rmd | 0 {settings => base/settings}/.Rbuildignore | 0 {settings => base/settings}/DESCRIPTION | 0 {settings => base/settings}/LICENSE | 0 {settings => base/settings}/NAMESPACE | 0 {settings => base/settings}/R/MultiSettings.R | 0 {settings => base/settings}/R/Settings.R | 0 {settings => base/settings}/R/addSecrets.R | 0 .../settings}/R/check.all.settings.R | 0 .../settings}/R/clean.settings.R | 0 .../R/createMultisiteMultiSettings.r | 0 .../settings}/R/fix.deprecated.settings.R | 0 {settings => base/settings}/R/papply.R | 0 .../settings}/R/prepare.settings.R | 0 {settings => base/settings}/R/read.settings.R | 0 .../settings}/R/update.settings.R | 0 .../settings}/R/write.settings.R | 0 .../examples.MultiSite.MultiSettings.r | 0 .../settings}/examples/examples.papply.R | 0 {settings => base/settings}/man/.Rapp.history | 0 .../settings}/man/MultiSettings.Rd | 0 {settings => base/settings}/man/Settings.Rd | 0 {settings => base/settings}/man/addSecrets.Rd | 0 .../settings}/man/check.bety.version.Rd | 0 .../settings}/man/check.database.Rd | 0 .../settings}/man/check.database.settings.Rd | 0 .../settings}/man/check.inputs.Rd | 0 .../settings}/man/check.model.settings.Rd | 0 .../settings}/man/check.run.settings.Rd | 0 .../settings}/man/check.settings.Rd | 0 .../settings}/man/check.workflow.settings.Rd | 0 .../settings}/man/clean.settings.Rd | 0 .../settings}/man/createMultiSiteSettings.Rd | 0 .../man/createSitegroupMultiSettings.Rd | 0 .../settings}/man/fix.deprecated.settings.Rd | 0 .../settings}/man/getRunSettings.Rd | 0 {settings => base/settings}/man/papply.Rd | 0 .../settings}/man/prepare.settings.Rd | 0 .../settings}/man/read.settings.Rd | 0 {settings => base/settings}/man/setDates.Rd | 0 {settings => base/settings}/man/setOutDir.Rd | 0 .../settings}/man/update.settings.Rd | 0 .../settings}/man/write.settings.Rd | 0 {settings => base/settings}/tests/testthat.R | 0 .../tests/testthat/get.test.settings.R | 0 .../tests/testthat/test.MultiSettings.class.R | 0 .../tests/testthat/test.Settings.class.R | 0 .../tests/testthat/test.deprecated.settings.R | 0 .../settings}/tests/testthat/test.papply.R | 0 .../tests/testthat/test.read.settings.R | 0 .../testthat/testinput.pecan2.bu.edu.xml | 0 .../settings}/tests/testthat/testinput.xml | 0 .../settings}/tests/testthat/testsettings.xml | 0 {utils => base/utils}/.Rbuildignore | 0 {utils => base/utils}/DESCRIPTION | 0 {utils => base/utils}/LICENSE | 0 {utils => base/utils}/NAMESPACE | 0 {utils => base/utils}/R/SafeList.R | 0 {utils => base/utils}/R/clear.scratch.R | 0 {utils => base/utils}/R/convert.input.R | 0 {utils => base/utils}/R/distn.stats.R | 0 {utils => base/utils}/R/do_conversions.R | 0 {utils => base/utils}/R/download.url.R | 0 {utils => base/utils}/R/ensemble.R | 0 {utils => base/utils}/R/fqdn.R | 0 {utils => base/utils}/R/full.path.R | 0 .../utils}/R/get.analysis.filenames.r | 0 {utils => base/utils}/R/get.ensemble.inputs.R | 0 {utils => base/utils}/R/get.model.output.R | 0 .../utils}/R/get.parameter.samples.R | 0 {utils => base/utils}/R/get.results.R | 0 {utils => base/utils}/R/help.R | 0 {utils => base/utils}/R/kill.tunnel.R | 0 {utils => base/utils}/R/listToArgString.R | 0 {utils => base/utils}/R/logger.R | 0 {utils => base/utils}/R/mail.R | 0 {utils => base/utils}/R/n_leap_day.R | 0 {utils => base/utils}/R/open.tunnel.R | 0 {utils => base/utils}/R/plots.R | 0 .../utils}/R/r2bugs.distributions.R | 0 {utils => base/utils}/R/read.output.R | 0 {utils => base/utils}/R/regrid.R | 0 {utils => base/utils}/R/remote.R | 0 {utils => base/utils}/R/remove.config.R | 0 {utils => base/utils}/R/run.write.configs.R | 0 {utils => base/utils}/R/sensitivity.R | 0 {utils => base/utils}/R/start.model.runs.R | 0 {utils => base/utils}/R/status.R | 0 {utils => base/utils}/R/timezone_hour.R | 0 {utils => base/utils}/R/to_nc.R | 0 {utils => base/utils}/R/transformstats.R | 0 {utils => base/utils}/R/utils.R | 0 {utils => base/utils}/R/write.config.utils.R | 0 {utils => base/utils}/data/madata.RData | Bin {utils => base/utils}/data/mstmip_local.csv | 0 {utils => base/utils}/data/mstmip_vars.csv | 0 {utils => base/utils}/data/output.RData | Bin {utils => base/utils}/data/post.distns.RData | Bin {utils => base/utils}/data/prior.distns.RData | Bin {utils => base/utils}/data/samples.RData | Bin .../utils}/data/sensitivity.results.RData | Bin {utils => base/utils}/data/settings.RData | Bin {utils => base/utils}/data/standard_vars.csv | 0 .../utils}/data/time.constants.RData | Bin {utils => base/utils}/data/trait.data.RData | Bin .../utils}/data/trait.dictionary.csv | 0 {utils => base/utils}/data/trait.mcmc.RData | Bin {utils => base/utils}/inst/LBNL_remote_test.R | 0 {utils => base/utils}/inst/clear.scratch.sh | 0 {utils => base/utils/inst}/get_mstmip_vars.R | 0 {utils => base/utils}/man/PEcAn.Rd | 0 {utils => base/utils}/man/SafeList.Rd | 0 .../utils}/man/arrhenius.scaling.Rd | 0 {utils => base/utils}/man/as.sequence.Rd | 0 {utils => base/utils}/man/bibtexify.Rd | 0 {utils => base/utils}/man/bugs.rdist.Rd | 0 {utils => base/utils}/man/capitalize.Rd | 0 {utils => base/utils}/man/cash-.SafeList.Rd | 0 {utils => base/utils}/man/clear.scratch.Rd | 0 {utils => base/utils}/man/convert.expr.Rd | 0 {utils => base/utils}/man/convert.input.Rd | 0 {utils => base/utils}/man/convert.outputs.Rd | 0 {utils => base/utils}/man/counter.Rd | 0 {utils => base/utils}/man/create.base.plot.Rd | 0 {utils => base/utils}/man/dhist.Rd | 0 {utils => base/utils}/man/distn.stats.Rd | 0 .../utils}/man/distn.table.stats.Rd | 0 {utils => base/utils}/man/do_conversions.Rd | 0 {utils => base/utils}/man/download.file.Rd | 0 {utils => base/utils}/man/download.url.Rd | 0 .../utils}/man/ensemble.filename.Rd | 0 {utils => base/utils}/man/fqdn.Rd | 0 {utils => base/utils}/man/full.path.Rd | 0 .../utils}/man/get.ensemble.inputs.Rd | 0 .../utils}/man/get.ensemble.samples.Rd | 0 {utils => base/utils}/man/get.model.output.Rd | 0 .../utils}/man/get.parameter.samples.Rd | 0 .../utils}/man/get.parameter.stat.Rd | 0 {utils => base/utils}/man/get.quantiles.Rd | 0 {utils => base/utils}/man/get.results.Rd | 0 {utils => base/utils}/man/get.run.id.Rd | 0 .../utils}/man/get.sa.sample.list.Rd | 0 {utils => base/utils}/man/get.sa.samples.Rd | 0 {utils => base/utils}/man/get.stats.mcmc.Rd | 0 {utils => base/utils}/man/grid2netcdf.Rd | 0 {utils => base/utils}/man/iqr.Rd | 0 {utils => base/utils}/man/is.localhost.Rd | 0 {utils => base/utils}/man/kill.tunnel.Rd | 0 {utils => base/utils}/man/left.pad.zeros.Rd | 0 {utils => base/utils}/man/listToArgString.Rd | 0 .../utils}/man/listToXml.default.Rd | 0 {utils => base/utils}/man/load.modelpkg.Rd | 0 {utils => base/utils}/man/logger.debug.Rd | 0 {utils => base/utils}/man/logger.error.Rd | 0 {utils => base/utils}/man/logger.getLevel.Rd | 0 .../utils}/man/logger.getLevelNumber.Rd | 0 {utils => base/utils}/man/logger.info.Rd | 0 {utils => base/utils}/man/logger.message.Rd | 0 {utils => base/utils}/man/logger.setLevel.Rd | 0 .../utils}/man/logger.setOutputFile.Rd | 0 .../utils}/man/logger.setQuitOnSevere.Rd | 0 .../utils}/man/logger.setUseConsole.Rd | 0 {utils => base/utils}/man/logger.setWidth.Rd | 0 {utils => base/utils}/man/logger.severe.Rd | 0 {utils => base/utils}/man/logger.warn.Rd | 0 {utils => base/utils}/man/met2model.exists.Rd | 0 .../utils}/man/misc.are.convertible.Rd | 0 {utils => base/utils}/man/misc.convert.Rd | 0 {utils => base/utils}/man/model2netcdf.Rd | 0 {utils => base/utils}/man/model2netcdfdep.Rd | 0 {utils => base/utils}/man/mstmipvar.Rd | 0 {utils => base/utils}/man/n_leap_day.Rd | 0 {utils => base/utils}/man/newxtable.Rd | 0 {utils => base/utils}/man/open_tunnel.Rd | 0 {utils => base/utils}/man/paste.stats.Rd | 0 {utils => base/utils}/man/pdf.stats.Rd | 0 {utils => base/utils}/man/plot_data.Rd | 0 .../utils}/man/r2bugs.distributions.Rd | 0 .../utils}/man/read.ensemble.output.Rd | 0 {utils => base/utils}/man/read.output.Rd | 0 {utils => base/utils}/man/read.sa.output.Rd | 0 {utils => base/utils}/man/regrid.Rd | 0 {utils => base/utils}/man/remote.copy.from.Rd | 0 {utils => base/utils}/man/remote.copy.to.Rd | 0 .../utils}/man/remote.copy.update.Rd | 0 {utils => base/utils}/man/remote.execute.R.Rd | 0 .../utils}/man/remote.execute.cmd.Rd | 0 {utils => base/utils}/man/rsync.Rd | 0 .../utils}/man/run.write.configs.Rd | 0 {utils => base/utils}/man/sendmail.Rd | 0 .../utils}/man/sensitivity.filename.Rd | 0 {utils => base/utils}/man/ssh.Rd | 0 {utils => base/utils}/man/start.model.runs.Rd | 0 {utils => base/utils}/man/status.check.Rd | 0 {utils => base/utils}/man/status.end.Rd | 0 {utils => base/utils}/man/status.skip.Rd | 0 {utils => base/utils}/man/status.start.Rd | 0 {utils => base/utils}/man/summarize.result.Rd | 0 {utils => base/utils}/man/tabnum.Rd | 0 {utils => base/utils}/man/temp.settings.Rd | 0 {utils => base/utils}/man/test.remote.Rd | 0 {utils => base/utils}/man/theme_border.Rd | 0 {utils => base/utils}/man/timezone_hour.Rd | 0 {utils => base/utils}/man/to_ncdim.Rd | 0 {utils => base/utils}/man/to_ncvar.Rd | 0 {utils => base/utils}/man/trait.lookup.Rd | 0 {utils => base/utils}/man/transformstats.Rd | 0 {utils => base/utils}/man/tryl.Rd | 0 {utils => base/utils}/man/vecpaste.Rd | 0 .../utils}/man/write.ensemble.configs.Rd | 0 {utils => base/utils}/man/write.sa.configs.Rd | 0 .../utils}/man/zero.bounded.density.Rd | 0 {utils => base/utils}/man/zero.truncate.Rd | 0 {utils => base/utils}/scripts/metutils.R | 0 .../utils}/scripts/time.constants.R | 0 {utils => base/utils}/tests/testthat.R | 0 .../tests/testthat/test.SafeList.class.R | 0 .../utils}/tests/testthat/test.distn.stats.R | 0 .../utils}/tests/testthat/test.localhost.R | 0 .../utils}/tests/testthat/test.logger.R | 0 .../utils}/tests/testthat/test.plots.R | 0 .../tests/testthat/test.trait.dictionary.R | 0 .../utils}/tests/testthat/test.utils.R | 0 .../visualization}/DESCRIPTION | 0 {visualization => base/visualization}/LICENSE | 0 .../visualization}/NAMESPACE | 0 .../visualization}/R/add_icon.R | 0 .../visualization}/R/ciEnvelope.R | 0 .../visualization}/R/map.output.R | 0 .../visualization}/R/plot.netcdf.R | 0 .../visualization}/R/points2county.R | 0 .../R/visually.weighted.watercolor.plots.R | 0 .../visualization}/R/worldmap.R | 0 .../visualization}/data/counties.RData | Bin .../visualization}/data/yielddf.RData | Bin .../inst/extdata/miscanthusyield.csv | 0 .../visualization}/inst/favicon.png | Bin .../visualization}/man/add_icon.Rd | 0 .../visualization}/man/ciEnvelope.Rd | 0 .../visualization}/man/map.output.Rd | 0 .../visualization}/man/pecan.worldmap.Rd | 0 .../visualization}/man/plot.hdf5.Rd | 0 .../visualization}/man/points2county.Rd | 0 .../visualization}/man/vwReg.Rd | 0 .../visualization}/tests/testthat.R | 0 .../tests/testthat/test.pecan.worldmap.R | 0 .../visualization}/vignettes/usmap.Rmd | 0 utils/modellauncher/Makefile | 3 - utils/modellauncher/modellauncher.c | 103 ------------------ .../vignettes/figure/unnamed-chunk-1.png | Bin 10036 -> 0 bytes 358 files changed, 9 insertions(+), 110 deletions(-) rename {all => base/all}/DESCRIPTION (100%) rename {all => base/all}/LICENSE (100%) rename {all => base/all}/NAMESPACE (100%) rename {all => base/all}/data/pecan.packages.csv (100%) rename {all => base/all}/inst/CITATION (100%) rename {all => base/all}/tests/testthat.R (100%) rename {all => base/all}/tests/testthat/test.workflow.R (100%) rename {db => base/db}/DESCRIPTION (100%) rename {db => base/db}/LICENSE (100%) rename {db => base/db}/NAMESPACE (100%) rename {db => base/db}/R/dbfiles.R (100%) rename {db => base/db}/R/get.trait.data.R (100%) rename {db => base/db}/R/input.name.check.R (100%) rename {db => base/db}/R/priordupe.R (100%) rename {db => base/db}/R/query.base.R (100%) rename {db => base/db}/R/query.dplyr.R (100%) rename {db => base/db}/R/query.file.path.R (100%) rename {db => base/db}/R/query.format.vars.R (100%) rename {db => base/db}/R/query.pft.R (100%) rename {db => base/db}/R/query.prior.R (100%) rename {db => base/db}/R/query.site.R (100%) rename {db => base/db}/R/query.trait.data.R (100%) rename {db => base/db}/R/query.traits.R (100%) rename {db => base/db}/R/utils.R (100%) rename {db => base/db}/inst/PFT_builder/PFT_builder.R (100%) rename {db => base/db}/inst/bety_mstmip_lookup.csv (100%) rename {db => base/db}/inst/create.db.subset.sh (100%) rename {db => base/db}/inst/dump.db.sh (100%) rename {db => base/db}/inst/dump.db.subset.sh (100%) rename {db => base/db}/inst/import-ForestGEO/ForestGEO_spp_website.csv (100%) rename {db => base/db}/inst/import-ForestGEO/import_species_list.R (100%) rename {db => base/db}/inst/import-try/.gitignore (100%) rename {db => base/db}/inst/import-try/01.global.subset.R (100%) rename {db => base/db}/inst/import-try/02.data.specific.subset.R (100%) rename {db => base/db}/inst/import-try/03.create.try.sites.R (100%) rename {db => base/db}/inst/import-try/04.match.species.R (100%) rename {db => base/db}/inst/import-try/05.citations.R (100%) rename {db => base/db}/inst/import-try/06.load.data.R (100%) rename {db => base/db}/inst/import-try/README.md (100%) rename {db => base/db}/inst/import-try/common.R (100%) rename {db => base/db}/inst/import-try/helpers.species.R (100%) rename {db => base/db}/inst/import-try/misc/add.self.sql (100%) rename {db => base/db}/inst/mysql2psql_validation.Rmd (100%) rename {db => base/db}/man/append.covariate.Rd (100%) rename {db => base/db}/man/arrhenius.scaling.traits.Rd (100%) rename {db => base/db}/man/assign.treatments.Rd (100%) rename {db => base/db}/man/betyConnect.Rd (100%) rename {db => base/db}/man/check.lists.Rd (100%) rename {db => base/db}/man/db.close.Rd (100%) rename {db => base/db}/man/db.exists.Rd (100%) rename {db => base/db}/man/db.getShowQueries.Rd (100%) rename {db => base/db}/man/db.open.Rd (100%) rename {db => base/db}/man/db.print.connections.Rd (100%) rename {db => base/db}/man/db.query.Rd (100%) rename {db => base/db}/man/db.showQueries.Rd (100%) rename {db => base/db}/man/dbHostInfo.Rd (100%) rename {db => base/db}/man/dbfile.check.Rd (100%) rename {db => base/db}/man/dbfile.file.Rd (100%) rename {db => base/db}/man/dbfile.input.check.Rd (100%) rename {db => base/db}/man/dbfile.input.insert.Rd (100%) rename {db => base/db}/man/dbfile.insert.Rd (100%) rename {db => base/db}/man/dbfile.posterior.check.Rd (100%) rename {db => base/db}/man/dbfile.posterior.insert.Rd (100%) rename {db => base/db}/man/derive.trait.Rd (100%) rename {db => base/db}/man/derive.traits.Rd (100%) rename {db => base/db}/man/dplyr.count.Rd (100%) rename {db => base/db}/man/fancy_scientific.Rd (100%) rename {db => base/db}/man/fetch.stats2se.Rd (100%) rename {db => base/db}/man/filter_sunleaf_traits.Rd (100%) rename {db => base/db}/man/get.id.Rd (100%) rename {db => base/db}/man/get.trait.data.Rd (100%) rename {db => base/db}/man/get.trait.data.pft.Rd (100%) rename {db => base/db}/man/get_run_ids.Rd (100%) rename {db => base/db}/man/get_users.Rd (100%) rename {db => base/db}/man/get_var_names.Rd (100%) rename {db => base/db}/man/get_workflow_ids.Rd (100%) rename {db => base/db}/man/killdbcons.Rd (100%) rename {db => base/db}/man/load_data_single_run.Rd (100%) rename {db => base/db}/man/ncdays2date.Rd (100%) rename {db => base/db}/man/priordupe.Rd (100%) rename {db => base/db}/man/query.base.Rd (100%) rename {db => base/db}/man/query.base.con.Rd (100%) rename {db => base/db}/man/query.close.Rd (100%) rename {db => base/db}/man/query.covariates.Rd (100%) rename {db => base/db}/man/query.data.Rd (100%) rename {db => base/db}/man/query.file.path.Rd (100%) rename {db => base/db}/man/query.format.vars.Rd (100%) rename {db => base/db}/man/query.pft_species.Rd (100%) rename {db => base/db}/man/query.priors.Rd (100%) rename {db => base/db}/man/query.site.Rd (100%) rename {db => base/db}/man/query.trait.data.Rd (100%) rename {db => base/db}/man/query.traits.Rd (100%) rename {db => base/db}/man/query.yields.Rd (100%) rename {db => base/db}/man/rename.jags.columns.Rd (100%) rename {db => base/db}/man/runs.Rd (100%) rename {db => base/db}/man/take.samples.Rd (100%) rename {db => base/db}/man/var_names_all.Rd (100%) rename {db => base/db}/man/workflow.Rd (100%) rename {db => base/db}/man/workflows.Rd (100%) rename {db => base/db}/tests/testthat.R (100%) rename {db => base/db}/tests/testthat/db.setup.R (100%) rename {db => base/db}/tests/testthat/test.contents_sanity.R (100%) rename {db => base/db}/tests/testthat/test.db.utils.R (100%) rename {db => base/db}/tests/testthat/test.derive.traits.R (100%) rename {db => base/db}/tests/testthat/test.query.base.R (100%) rename {db => base/db}/vignettes/betydb_access.Rmd (100%) rename {db => base/db}/vignettes/create_sites.geometry.Rmd (100%) rename {settings => base/settings}/.Rbuildignore (100%) rename {settings => base/settings}/DESCRIPTION (100%) rename {settings => base/settings}/LICENSE (100%) rename {settings => base/settings}/NAMESPACE (100%) rename {settings => base/settings}/R/MultiSettings.R (100%) rename {settings => base/settings}/R/Settings.R (100%) rename {settings => base/settings}/R/addSecrets.R (100%) rename {settings => base/settings}/R/check.all.settings.R (100%) rename {settings => base/settings}/R/clean.settings.R (100%) rename {settings => base/settings}/R/createMultisiteMultiSettings.r (100%) rename {settings => base/settings}/R/fix.deprecated.settings.R (100%) rename {settings => base/settings}/R/papply.R (100%) rename {settings => base/settings}/R/prepare.settings.R (100%) rename {settings => base/settings}/R/read.settings.R (100%) rename {settings => base/settings}/R/update.settings.R (100%) rename {settings => base/settings}/R/write.settings.R (100%) rename {settings => base/settings}/examples/examples.MultiSite.MultiSettings.r (100%) rename {settings => base/settings}/examples/examples.papply.R (100%) rename {settings => base/settings}/man/.Rapp.history (100%) rename {settings => base/settings}/man/MultiSettings.Rd (100%) rename {settings => base/settings}/man/Settings.Rd (100%) rename {settings => base/settings}/man/addSecrets.Rd (100%) rename {settings => base/settings}/man/check.bety.version.Rd (100%) rename {settings => base/settings}/man/check.database.Rd (100%) rename {settings => base/settings}/man/check.database.settings.Rd (100%) rename {settings => base/settings}/man/check.inputs.Rd (100%) rename {settings => base/settings}/man/check.model.settings.Rd (100%) rename {settings => base/settings}/man/check.run.settings.Rd (100%) rename {settings => base/settings}/man/check.settings.Rd (100%) rename {settings => base/settings}/man/check.workflow.settings.Rd (100%) rename {settings => base/settings}/man/clean.settings.Rd (100%) rename {settings => base/settings}/man/createMultiSiteSettings.Rd (100%) rename {settings => base/settings}/man/createSitegroupMultiSettings.Rd (100%) rename {settings => base/settings}/man/fix.deprecated.settings.Rd (100%) rename {settings => base/settings}/man/getRunSettings.Rd (100%) rename {settings => base/settings}/man/papply.Rd (100%) rename {settings => base/settings}/man/prepare.settings.Rd (100%) rename {settings => base/settings}/man/read.settings.Rd (100%) rename {settings => base/settings}/man/setDates.Rd (100%) rename {settings => base/settings}/man/setOutDir.Rd (100%) rename {settings => base/settings}/man/update.settings.Rd (100%) rename {settings => base/settings}/man/write.settings.Rd (100%) rename {settings => base/settings}/tests/testthat.R (100%) rename {settings => base/settings}/tests/testthat/get.test.settings.R (100%) rename {settings => base/settings}/tests/testthat/test.MultiSettings.class.R (100%) rename {settings => base/settings}/tests/testthat/test.Settings.class.R (100%) rename {settings => base/settings}/tests/testthat/test.deprecated.settings.R (100%) rename {settings => base/settings}/tests/testthat/test.papply.R (100%) rename {settings => base/settings}/tests/testthat/test.read.settings.R (100%) rename {settings => base/settings}/tests/testthat/testinput.pecan2.bu.edu.xml (100%) rename {settings => base/settings}/tests/testthat/testinput.xml (100%) rename {settings => base/settings}/tests/testthat/testsettings.xml (100%) rename {utils => base/utils}/.Rbuildignore (100%) rename {utils => base/utils}/DESCRIPTION (100%) rename {utils => base/utils}/LICENSE (100%) rename {utils => base/utils}/NAMESPACE (100%) rename {utils => base/utils}/R/SafeList.R (100%) rename {utils => base/utils}/R/clear.scratch.R (100%) rename {utils => base/utils}/R/convert.input.R (100%) rename {utils => base/utils}/R/distn.stats.R (100%) rename {utils => base/utils}/R/do_conversions.R (100%) rename {utils => base/utils}/R/download.url.R (100%) rename {utils => base/utils}/R/ensemble.R (100%) rename {utils => base/utils}/R/fqdn.R (100%) rename {utils => base/utils}/R/full.path.R (100%) rename {utils => base/utils}/R/get.analysis.filenames.r (100%) rename {utils => base/utils}/R/get.ensemble.inputs.R (100%) rename {utils => base/utils}/R/get.model.output.R (100%) rename {utils => base/utils}/R/get.parameter.samples.R (100%) rename {utils => base/utils}/R/get.results.R (100%) rename {utils => base/utils}/R/help.R (100%) rename {utils => base/utils}/R/kill.tunnel.R (100%) rename {utils => base/utils}/R/listToArgString.R (100%) rename {utils => base/utils}/R/logger.R (100%) rename {utils => base/utils}/R/mail.R (100%) rename {utils => base/utils}/R/n_leap_day.R (100%) rename {utils => base/utils}/R/open.tunnel.R (100%) rename {utils => base/utils}/R/plots.R (100%) rename {utils => base/utils}/R/r2bugs.distributions.R (100%) rename {utils => base/utils}/R/read.output.R (100%) rename {utils => base/utils}/R/regrid.R (100%) rename {utils => base/utils}/R/remote.R (100%) rename {utils => base/utils}/R/remove.config.R (100%) rename {utils => base/utils}/R/run.write.configs.R (100%) rename {utils => base/utils}/R/sensitivity.R (100%) rename {utils => base/utils}/R/start.model.runs.R (100%) rename {utils => base/utils}/R/status.R (100%) rename {utils => base/utils}/R/timezone_hour.R (100%) rename {utils => base/utils}/R/to_nc.R (100%) rename {utils => base/utils}/R/transformstats.R (100%) rename {utils => base/utils}/R/utils.R (100%) rename {utils => base/utils}/R/write.config.utils.R (100%) rename {utils => base/utils}/data/madata.RData (100%) rename {utils => base/utils}/data/mstmip_local.csv (100%) rename {utils => base/utils}/data/mstmip_vars.csv (100%) rename {utils => base/utils}/data/output.RData (100%) rename {utils => base/utils}/data/post.distns.RData (100%) rename {utils => base/utils}/data/prior.distns.RData (100%) rename {utils => base/utils}/data/samples.RData (100%) rename {utils => base/utils}/data/sensitivity.results.RData (100%) rename {utils => base/utils}/data/settings.RData (100%) rename {utils => base/utils}/data/standard_vars.csv (100%) rename {utils => base/utils}/data/time.constants.RData (100%) rename {utils => base/utils}/data/trait.data.RData (100%) rename {utils => base/utils}/data/trait.dictionary.csv (100%) rename {utils => base/utils}/data/trait.mcmc.RData (100%) rename {utils => base/utils}/inst/LBNL_remote_test.R (100%) rename {utils => base/utils}/inst/clear.scratch.sh (100%) rename {utils => base/utils/inst}/get_mstmip_vars.R (100%) rename {utils => base/utils}/man/PEcAn.Rd (100%) rename {utils => base/utils}/man/SafeList.Rd (100%) rename {utils => base/utils}/man/arrhenius.scaling.Rd (100%) rename {utils => base/utils}/man/as.sequence.Rd (100%) rename {utils => base/utils}/man/bibtexify.Rd (100%) rename {utils => base/utils}/man/bugs.rdist.Rd (100%) rename {utils => base/utils}/man/capitalize.Rd (100%) rename {utils => base/utils}/man/cash-.SafeList.Rd (100%) rename {utils => base/utils}/man/clear.scratch.Rd (100%) rename {utils => base/utils}/man/convert.expr.Rd (100%) rename {utils => base/utils}/man/convert.input.Rd (100%) rename {utils => base/utils}/man/convert.outputs.Rd (100%) rename {utils => base/utils}/man/counter.Rd (100%) rename {utils => base/utils}/man/create.base.plot.Rd (100%) rename {utils => base/utils}/man/dhist.Rd (100%) rename {utils => base/utils}/man/distn.stats.Rd (100%) rename {utils => base/utils}/man/distn.table.stats.Rd (100%) rename {utils => base/utils}/man/do_conversions.Rd (100%) rename {utils => base/utils}/man/download.file.Rd (100%) rename {utils => base/utils}/man/download.url.Rd (100%) rename {utils => base/utils}/man/ensemble.filename.Rd (100%) rename {utils => base/utils}/man/fqdn.Rd (100%) rename {utils => base/utils}/man/full.path.Rd (100%) rename {utils => base/utils}/man/get.ensemble.inputs.Rd (100%) rename {utils => base/utils}/man/get.ensemble.samples.Rd (100%) rename {utils => base/utils}/man/get.model.output.Rd (100%) rename {utils => base/utils}/man/get.parameter.samples.Rd (100%) rename {utils => base/utils}/man/get.parameter.stat.Rd (100%) rename {utils => base/utils}/man/get.quantiles.Rd (100%) rename {utils => base/utils}/man/get.results.Rd (100%) rename {utils => base/utils}/man/get.run.id.Rd (100%) rename {utils => base/utils}/man/get.sa.sample.list.Rd (100%) rename {utils => base/utils}/man/get.sa.samples.Rd (100%) rename {utils => base/utils}/man/get.stats.mcmc.Rd (100%) rename {utils => base/utils}/man/grid2netcdf.Rd (100%) rename {utils => base/utils}/man/iqr.Rd (100%) rename {utils => base/utils}/man/is.localhost.Rd (100%) rename {utils => base/utils}/man/kill.tunnel.Rd (100%) rename {utils => base/utils}/man/left.pad.zeros.Rd (100%) rename {utils => base/utils}/man/listToArgString.Rd (100%) rename {utils => base/utils}/man/listToXml.default.Rd (100%) rename {utils => base/utils}/man/load.modelpkg.Rd (100%) rename {utils => base/utils}/man/logger.debug.Rd (100%) rename {utils => base/utils}/man/logger.error.Rd (100%) rename {utils => base/utils}/man/logger.getLevel.Rd (100%) rename {utils => base/utils}/man/logger.getLevelNumber.Rd (100%) rename {utils => base/utils}/man/logger.info.Rd (100%) rename {utils => base/utils}/man/logger.message.Rd (100%) rename {utils => base/utils}/man/logger.setLevel.Rd (100%) rename {utils => base/utils}/man/logger.setOutputFile.Rd (100%) rename {utils => base/utils}/man/logger.setQuitOnSevere.Rd (100%) rename {utils => base/utils}/man/logger.setUseConsole.Rd (100%) rename {utils => base/utils}/man/logger.setWidth.Rd (100%) rename {utils => base/utils}/man/logger.severe.Rd (100%) rename {utils => base/utils}/man/logger.warn.Rd (100%) rename {utils => base/utils}/man/met2model.exists.Rd (100%) rename {utils => base/utils}/man/misc.are.convertible.Rd (100%) rename {utils => base/utils}/man/misc.convert.Rd (100%) rename {utils => base/utils}/man/model2netcdf.Rd (100%) rename {utils => base/utils}/man/model2netcdfdep.Rd (100%) rename {utils => base/utils}/man/mstmipvar.Rd (100%) rename {utils => base/utils}/man/n_leap_day.Rd (100%) rename {utils => base/utils}/man/newxtable.Rd (100%) rename {utils => base/utils}/man/open_tunnel.Rd (100%) rename {utils => base/utils}/man/paste.stats.Rd (100%) rename {utils => base/utils}/man/pdf.stats.Rd (100%) rename {utils => base/utils}/man/plot_data.Rd (100%) rename {utils => base/utils}/man/r2bugs.distributions.Rd (100%) rename {utils => base/utils}/man/read.ensemble.output.Rd (100%) rename {utils => base/utils}/man/read.output.Rd (100%) rename {utils => base/utils}/man/read.sa.output.Rd (100%) rename {utils => base/utils}/man/regrid.Rd (100%) rename {utils => base/utils}/man/remote.copy.from.Rd (100%) rename {utils => base/utils}/man/remote.copy.to.Rd (100%) rename {utils => base/utils}/man/remote.copy.update.Rd (100%) rename {utils => base/utils}/man/remote.execute.R.Rd (100%) rename {utils => base/utils}/man/remote.execute.cmd.Rd (100%) rename {utils => base/utils}/man/rsync.Rd (100%) rename {utils => base/utils}/man/run.write.configs.Rd (100%) rename {utils => base/utils}/man/sendmail.Rd (100%) rename {utils => base/utils}/man/sensitivity.filename.Rd (100%) rename {utils => base/utils}/man/ssh.Rd (100%) rename {utils => base/utils}/man/start.model.runs.Rd (100%) rename {utils => base/utils}/man/status.check.Rd (100%) rename {utils => base/utils}/man/status.end.Rd (100%) rename {utils => base/utils}/man/status.skip.Rd (100%) rename {utils => base/utils}/man/status.start.Rd (100%) rename {utils => base/utils}/man/summarize.result.Rd (100%) rename {utils => base/utils}/man/tabnum.Rd (100%) rename {utils => base/utils}/man/temp.settings.Rd (100%) rename {utils => base/utils}/man/test.remote.Rd (100%) rename {utils => base/utils}/man/theme_border.Rd (100%) rename {utils => base/utils}/man/timezone_hour.Rd (100%) rename {utils => base/utils}/man/to_ncdim.Rd (100%) rename {utils => base/utils}/man/to_ncvar.Rd (100%) rename {utils => base/utils}/man/trait.lookup.Rd (100%) rename {utils => base/utils}/man/transformstats.Rd (100%) rename {utils => base/utils}/man/tryl.Rd (100%) rename {utils => base/utils}/man/vecpaste.Rd (100%) rename {utils => base/utils}/man/write.ensemble.configs.Rd (100%) rename {utils => base/utils}/man/write.sa.configs.Rd (100%) rename {utils => base/utils}/man/zero.bounded.density.Rd (100%) rename {utils => base/utils}/man/zero.truncate.Rd (100%) rename {utils => base/utils}/scripts/metutils.R (100%) rename {utils => base/utils}/scripts/time.constants.R (100%) rename {utils => base/utils}/tests/testthat.R (100%) rename {utils => base/utils}/tests/testthat/test.SafeList.class.R (100%) rename {utils => base/utils}/tests/testthat/test.distn.stats.R (100%) rename {utils => base/utils}/tests/testthat/test.localhost.R (100%) rename {utils => base/utils}/tests/testthat/test.logger.R (100%) rename {utils => base/utils}/tests/testthat/test.plots.R (100%) rename {utils => base/utils}/tests/testthat/test.trait.dictionary.R (100%) rename {utils => base/utils}/tests/testthat/test.utils.R (100%) rename {visualization => base/visualization}/DESCRIPTION (100%) rename {visualization => base/visualization}/LICENSE (100%) rename {visualization => base/visualization}/NAMESPACE (100%) rename {visualization => base/visualization}/R/add_icon.R (100%) rename {visualization => base/visualization}/R/ciEnvelope.R (100%) rename {visualization => base/visualization}/R/map.output.R (100%) rename {visualization => base/visualization}/R/plot.netcdf.R (100%) rename {visualization => base/visualization}/R/points2county.R (100%) rename {visualization => base/visualization}/R/visually.weighted.watercolor.plots.R (100%) rename {visualization => base/visualization}/R/worldmap.R (100%) rename {visualization => base/visualization}/data/counties.RData (100%) rename {visualization => base/visualization}/data/yielddf.RData (100%) rename {visualization => base/visualization}/inst/extdata/miscanthusyield.csv (100%) rename {visualization => base/visualization}/inst/favicon.png (100%) rename {visualization => base/visualization}/man/add_icon.Rd (100%) rename {visualization => base/visualization}/man/ciEnvelope.Rd (100%) rename {visualization => base/visualization}/man/map.output.Rd (100%) rename {visualization => base/visualization}/man/pecan.worldmap.Rd (100%) rename {visualization => base/visualization}/man/plot.hdf5.Rd (100%) rename {visualization => base/visualization}/man/points2county.Rd (100%) rename {visualization => base/visualization}/man/vwReg.Rd (100%) rename {visualization => base/visualization}/tests/testthat.R (100%) rename {visualization => base/visualization}/tests/testthat/test.pecan.worldmap.R (100%) rename {visualization => base/visualization}/vignettes/usmap.Rmd (100%) delete mode 100644 utils/modellauncher/Makefile delete mode 100644 utils/modellauncher/modellauncher.c delete mode 100644 visualization/vignettes/figure/unnamed-chunk-1.png diff --git a/CHANGELOG.md b/CHANGELOG.md index b8a889f5052..a85ea601f66 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,6 +16,10 @@ For more information about this file see also [Keep a Changelog](http://keepacha ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) +### Changed +- Clean up directory structure: + * Move `base` packages (`utils`, `settings`, `db`, `visualizaton`) to a `base` directory, for consistency with `modules` and `models` + ## [1.5.10] - Prerelease ### Added - Added PEcAn.utils::download.file() to allow for use of alternative FTP programs diff --git a/Makefile b/Makefile index 1745a59c5c1..a1188a08e4f 100644 --- a/Makefile +++ b/Makefile @@ -10,6 +10,7 @@ MODULES := allometry assim.batch assim.sequential benchmark \ data.mining data.remote emulator meta.analysis \ photosynthesis priors rtm uncertainty +BASE := $(BASE:%=base/%) MODELS := $(MODELS:%=models/%) MODULES := $(MODULES:%=modules/%) ALL_PKGS := $(BASE) $(MODELS) $(MODULES) models/template @@ -49,11 +50,11 @@ test: .test/all .check/all: $(ALL_PKGS_C) .test/all: $(ALL_PKGS_T) -depends = .install/$(1) .doc/$(1) .check/$(1) .test/$(1) +depends = .check/$(1) .test/$(1) -$(call depends,db): .install/utils -$(call depends,settings): .install/utils .install/db -$(call depends,visualization): .install/db +$(call depends,base/db): .install/utils +$(call depends,base/settings): .install/utils .install/db +$(call depends,base/visualization): .install/db $(call depends,modules/data.atmosphere): .install/utils $(call depends,modules/data.land): .install/db .install/utils $(call depends,modules/meta.analysis): .install/utils .install/db diff --git a/all/DESCRIPTION b/base/all/DESCRIPTION similarity index 100% rename from all/DESCRIPTION rename to base/all/DESCRIPTION diff --git a/all/LICENSE b/base/all/LICENSE similarity index 100% rename from all/LICENSE rename to base/all/LICENSE diff --git a/all/NAMESPACE b/base/all/NAMESPACE similarity index 100% rename from all/NAMESPACE rename to base/all/NAMESPACE diff --git a/all/data/pecan.packages.csv b/base/all/data/pecan.packages.csv similarity index 100% rename from all/data/pecan.packages.csv rename to base/all/data/pecan.packages.csv diff --git a/all/inst/CITATION b/base/all/inst/CITATION similarity index 100% rename from all/inst/CITATION rename to base/all/inst/CITATION diff --git a/all/tests/testthat.R b/base/all/tests/testthat.R similarity index 100% rename from all/tests/testthat.R rename to base/all/tests/testthat.R diff --git a/all/tests/testthat/test.workflow.R b/base/all/tests/testthat/test.workflow.R similarity index 100% rename from all/tests/testthat/test.workflow.R rename to base/all/tests/testthat/test.workflow.R diff --git a/db/DESCRIPTION b/base/db/DESCRIPTION similarity index 100% rename from db/DESCRIPTION rename to base/db/DESCRIPTION diff --git a/db/LICENSE b/base/db/LICENSE similarity index 100% rename from db/LICENSE rename to base/db/LICENSE diff --git a/db/NAMESPACE b/base/db/NAMESPACE similarity index 100% rename from db/NAMESPACE rename to base/db/NAMESPACE diff --git a/db/R/dbfiles.R b/base/db/R/dbfiles.R similarity index 100% rename from db/R/dbfiles.R rename to base/db/R/dbfiles.R diff --git a/db/R/get.trait.data.R b/base/db/R/get.trait.data.R similarity index 100% rename from db/R/get.trait.data.R rename to base/db/R/get.trait.data.R diff --git a/db/R/input.name.check.R b/base/db/R/input.name.check.R similarity index 100% rename from db/R/input.name.check.R rename to base/db/R/input.name.check.R diff --git a/db/R/priordupe.R b/base/db/R/priordupe.R similarity index 100% rename from db/R/priordupe.R rename to base/db/R/priordupe.R diff --git a/db/R/query.base.R b/base/db/R/query.base.R similarity index 100% rename from db/R/query.base.R rename to base/db/R/query.base.R diff --git a/db/R/query.dplyr.R b/base/db/R/query.dplyr.R similarity index 100% rename from db/R/query.dplyr.R rename to base/db/R/query.dplyr.R diff --git a/db/R/query.file.path.R b/base/db/R/query.file.path.R similarity index 100% rename from db/R/query.file.path.R rename to base/db/R/query.file.path.R diff --git a/db/R/query.format.vars.R b/base/db/R/query.format.vars.R similarity index 100% rename from db/R/query.format.vars.R rename to base/db/R/query.format.vars.R diff --git a/db/R/query.pft.R b/base/db/R/query.pft.R similarity index 100% rename from db/R/query.pft.R rename to base/db/R/query.pft.R diff --git a/db/R/query.prior.R b/base/db/R/query.prior.R similarity index 100% rename from db/R/query.prior.R rename to base/db/R/query.prior.R diff --git a/db/R/query.site.R b/base/db/R/query.site.R similarity index 100% rename from db/R/query.site.R rename to base/db/R/query.site.R diff --git a/db/R/query.trait.data.R b/base/db/R/query.trait.data.R similarity index 100% rename from db/R/query.trait.data.R rename to base/db/R/query.trait.data.R diff --git a/db/R/query.traits.R b/base/db/R/query.traits.R similarity index 100% rename from db/R/query.traits.R rename to base/db/R/query.traits.R diff --git a/db/R/utils.R b/base/db/R/utils.R similarity index 100% rename from db/R/utils.R rename to base/db/R/utils.R diff --git a/db/inst/PFT_builder/PFT_builder.R b/base/db/inst/PFT_builder/PFT_builder.R similarity index 100% rename from db/inst/PFT_builder/PFT_builder.R rename to base/db/inst/PFT_builder/PFT_builder.R diff --git a/db/inst/bety_mstmip_lookup.csv b/base/db/inst/bety_mstmip_lookup.csv similarity index 100% rename from db/inst/bety_mstmip_lookup.csv rename to base/db/inst/bety_mstmip_lookup.csv diff --git a/db/inst/create.db.subset.sh b/base/db/inst/create.db.subset.sh similarity index 100% rename from db/inst/create.db.subset.sh rename to base/db/inst/create.db.subset.sh diff --git a/db/inst/dump.db.sh b/base/db/inst/dump.db.sh similarity index 100% rename from db/inst/dump.db.sh rename to base/db/inst/dump.db.sh diff --git a/db/inst/dump.db.subset.sh b/base/db/inst/dump.db.subset.sh similarity index 100% rename from db/inst/dump.db.subset.sh rename to base/db/inst/dump.db.subset.sh diff --git a/db/inst/import-ForestGEO/ForestGEO_spp_website.csv b/base/db/inst/import-ForestGEO/ForestGEO_spp_website.csv similarity index 100% rename from db/inst/import-ForestGEO/ForestGEO_spp_website.csv rename to base/db/inst/import-ForestGEO/ForestGEO_spp_website.csv diff --git a/db/inst/import-ForestGEO/import_species_list.R b/base/db/inst/import-ForestGEO/import_species_list.R similarity index 100% rename from db/inst/import-ForestGEO/import_species_list.R rename to base/db/inst/import-ForestGEO/import_species_list.R diff --git a/db/inst/import-try/.gitignore b/base/db/inst/import-try/.gitignore similarity index 100% rename from db/inst/import-try/.gitignore rename to base/db/inst/import-try/.gitignore diff --git a/db/inst/import-try/01.global.subset.R b/base/db/inst/import-try/01.global.subset.R similarity index 100% rename from db/inst/import-try/01.global.subset.R rename to base/db/inst/import-try/01.global.subset.R diff --git a/db/inst/import-try/02.data.specific.subset.R b/base/db/inst/import-try/02.data.specific.subset.R similarity index 100% rename from db/inst/import-try/02.data.specific.subset.R rename to base/db/inst/import-try/02.data.specific.subset.R diff --git a/db/inst/import-try/03.create.try.sites.R b/base/db/inst/import-try/03.create.try.sites.R similarity index 100% rename from db/inst/import-try/03.create.try.sites.R rename to base/db/inst/import-try/03.create.try.sites.R diff --git a/db/inst/import-try/04.match.species.R b/base/db/inst/import-try/04.match.species.R similarity index 100% rename from db/inst/import-try/04.match.species.R rename to base/db/inst/import-try/04.match.species.R diff --git a/db/inst/import-try/05.citations.R b/base/db/inst/import-try/05.citations.R similarity index 100% rename from db/inst/import-try/05.citations.R rename to base/db/inst/import-try/05.citations.R diff --git a/db/inst/import-try/06.load.data.R b/base/db/inst/import-try/06.load.data.R similarity index 100% rename from db/inst/import-try/06.load.data.R rename to base/db/inst/import-try/06.load.data.R diff --git a/db/inst/import-try/README.md b/base/db/inst/import-try/README.md similarity index 100% rename from db/inst/import-try/README.md rename to base/db/inst/import-try/README.md diff --git a/db/inst/import-try/common.R b/base/db/inst/import-try/common.R similarity index 100% rename from db/inst/import-try/common.R rename to base/db/inst/import-try/common.R diff --git a/db/inst/import-try/helpers.species.R b/base/db/inst/import-try/helpers.species.R similarity index 100% rename from db/inst/import-try/helpers.species.R rename to base/db/inst/import-try/helpers.species.R diff --git a/db/inst/import-try/misc/add.self.sql b/base/db/inst/import-try/misc/add.self.sql similarity index 100% rename from db/inst/import-try/misc/add.self.sql rename to base/db/inst/import-try/misc/add.self.sql diff --git a/db/inst/mysql2psql_validation.Rmd b/base/db/inst/mysql2psql_validation.Rmd similarity index 100% rename from db/inst/mysql2psql_validation.Rmd rename to base/db/inst/mysql2psql_validation.Rmd diff --git a/db/man/append.covariate.Rd b/base/db/man/append.covariate.Rd similarity index 100% rename from db/man/append.covariate.Rd rename to base/db/man/append.covariate.Rd diff --git a/db/man/arrhenius.scaling.traits.Rd b/base/db/man/arrhenius.scaling.traits.Rd similarity index 100% rename from db/man/arrhenius.scaling.traits.Rd rename to base/db/man/arrhenius.scaling.traits.Rd diff --git a/db/man/assign.treatments.Rd b/base/db/man/assign.treatments.Rd similarity index 100% rename from db/man/assign.treatments.Rd rename to base/db/man/assign.treatments.Rd diff --git a/db/man/betyConnect.Rd b/base/db/man/betyConnect.Rd similarity index 100% rename from db/man/betyConnect.Rd rename to base/db/man/betyConnect.Rd diff --git a/db/man/check.lists.Rd b/base/db/man/check.lists.Rd similarity index 100% rename from db/man/check.lists.Rd rename to base/db/man/check.lists.Rd diff --git a/db/man/db.close.Rd b/base/db/man/db.close.Rd similarity index 100% rename from db/man/db.close.Rd rename to base/db/man/db.close.Rd diff --git a/db/man/db.exists.Rd b/base/db/man/db.exists.Rd similarity index 100% rename from db/man/db.exists.Rd rename to base/db/man/db.exists.Rd diff --git a/db/man/db.getShowQueries.Rd b/base/db/man/db.getShowQueries.Rd similarity index 100% rename from db/man/db.getShowQueries.Rd rename to base/db/man/db.getShowQueries.Rd diff --git a/db/man/db.open.Rd b/base/db/man/db.open.Rd similarity index 100% rename from db/man/db.open.Rd rename to base/db/man/db.open.Rd diff --git a/db/man/db.print.connections.Rd b/base/db/man/db.print.connections.Rd similarity index 100% rename from db/man/db.print.connections.Rd rename to base/db/man/db.print.connections.Rd diff --git a/db/man/db.query.Rd b/base/db/man/db.query.Rd similarity index 100% rename from db/man/db.query.Rd rename to base/db/man/db.query.Rd diff --git a/db/man/db.showQueries.Rd b/base/db/man/db.showQueries.Rd similarity index 100% rename from db/man/db.showQueries.Rd rename to base/db/man/db.showQueries.Rd diff --git a/db/man/dbHostInfo.Rd b/base/db/man/dbHostInfo.Rd similarity index 100% rename from db/man/dbHostInfo.Rd rename to base/db/man/dbHostInfo.Rd diff --git a/db/man/dbfile.check.Rd b/base/db/man/dbfile.check.Rd similarity index 100% rename from db/man/dbfile.check.Rd rename to base/db/man/dbfile.check.Rd diff --git a/db/man/dbfile.file.Rd b/base/db/man/dbfile.file.Rd similarity index 100% rename from db/man/dbfile.file.Rd rename to base/db/man/dbfile.file.Rd diff --git a/db/man/dbfile.input.check.Rd b/base/db/man/dbfile.input.check.Rd similarity index 100% rename from db/man/dbfile.input.check.Rd rename to base/db/man/dbfile.input.check.Rd diff --git a/db/man/dbfile.input.insert.Rd b/base/db/man/dbfile.input.insert.Rd similarity index 100% rename from db/man/dbfile.input.insert.Rd rename to base/db/man/dbfile.input.insert.Rd diff --git a/db/man/dbfile.insert.Rd b/base/db/man/dbfile.insert.Rd similarity index 100% rename from db/man/dbfile.insert.Rd rename to base/db/man/dbfile.insert.Rd diff --git a/db/man/dbfile.posterior.check.Rd b/base/db/man/dbfile.posterior.check.Rd similarity index 100% rename from db/man/dbfile.posterior.check.Rd rename to base/db/man/dbfile.posterior.check.Rd diff --git a/db/man/dbfile.posterior.insert.Rd b/base/db/man/dbfile.posterior.insert.Rd similarity index 100% rename from db/man/dbfile.posterior.insert.Rd rename to base/db/man/dbfile.posterior.insert.Rd diff --git a/db/man/derive.trait.Rd b/base/db/man/derive.trait.Rd similarity index 100% rename from db/man/derive.trait.Rd rename to base/db/man/derive.trait.Rd diff --git a/db/man/derive.traits.Rd b/base/db/man/derive.traits.Rd similarity index 100% rename from db/man/derive.traits.Rd rename to base/db/man/derive.traits.Rd diff --git a/db/man/dplyr.count.Rd b/base/db/man/dplyr.count.Rd similarity index 100% rename from db/man/dplyr.count.Rd rename to base/db/man/dplyr.count.Rd diff --git a/db/man/fancy_scientific.Rd b/base/db/man/fancy_scientific.Rd similarity index 100% rename from db/man/fancy_scientific.Rd rename to base/db/man/fancy_scientific.Rd diff --git a/db/man/fetch.stats2se.Rd b/base/db/man/fetch.stats2se.Rd similarity index 100% rename from db/man/fetch.stats2se.Rd rename to base/db/man/fetch.stats2se.Rd diff --git a/db/man/filter_sunleaf_traits.Rd b/base/db/man/filter_sunleaf_traits.Rd similarity index 100% rename from db/man/filter_sunleaf_traits.Rd rename to base/db/man/filter_sunleaf_traits.Rd diff --git a/db/man/get.id.Rd b/base/db/man/get.id.Rd similarity index 100% rename from db/man/get.id.Rd rename to base/db/man/get.id.Rd diff --git a/db/man/get.trait.data.Rd b/base/db/man/get.trait.data.Rd similarity index 100% rename from db/man/get.trait.data.Rd rename to base/db/man/get.trait.data.Rd diff --git a/db/man/get.trait.data.pft.Rd b/base/db/man/get.trait.data.pft.Rd similarity index 100% rename from db/man/get.trait.data.pft.Rd rename to base/db/man/get.trait.data.pft.Rd diff --git a/db/man/get_run_ids.Rd b/base/db/man/get_run_ids.Rd similarity index 100% rename from db/man/get_run_ids.Rd rename to base/db/man/get_run_ids.Rd diff --git a/db/man/get_users.Rd b/base/db/man/get_users.Rd similarity index 100% rename from db/man/get_users.Rd rename to base/db/man/get_users.Rd diff --git a/db/man/get_var_names.Rd b/base/db/man/get_var_names.Rd similarity index 100% rename from db/man/get_var_names.Rd rename to base/db/man/get_var_names.Rd diff --git a/db/man/get_workflow_ids.Rd b/base/db/man/get_workflow_ids.Rd similarity index 100% rename from db/man/get_workflow_ids.Rd rename to base/db/man/get_workflow_ids.Rd diff --git a/db/man/killdbcons.Rd b/base/db/man/killdbcons.Rd similarity index 100% rename from db/man/killdbcons.Rd rename to base/db/man/killdbcons.Rd diff --git a/db/man/load_data_single_run.Rd b/base/db/man/load_data_single_run.Rd similarity index 100% rename from db/man/load_data_single_run.Rd rename to base/db/man/load_data_single_run.Rd diff --git a/db/man/ncdays2date.Rd b/base/db/man/ncdays2date.Rd similarity index 100% rename from db/man/ncdays2date.Rd rename to base/db/man/ncdays2date.Rd diff --git a/db/man/priordupe.Rd b/base/db/man/priordupe.Rd similarity index 100% rename from db/man/priordupe.Rd rename to base/db/man/priordupe.Rd diff --git a/db/man/query.base.Rd b/base/db/man/query.base.Rd similarity index 100% rename from db/man/query.base.Rd rename to base/db/man/query.base.Rd diff --git a/db/man/query.base.con.Rd b/base/db/man/query.base.con.Rd similarity index 100% rename from db/man/query.base.con.Rd rename to base/db/man/query.base.con.Rd diff --git a/db/man/query.close.Rd b/base/db/man/query.close.Rd similarity index 100% rename from db/man/query.close.Rd rename to base/db/man/query.close.Rd diff --git a/db/man/query.covariates.Rd b/base/db/man/query.covariates.Rd similarity index 100% rename from db/man/query.covariates.Rd rename to base/db/man/query.covariates.Rd diff --git a/db/man/query.data.Rd b/base/db/man/query.data.Rd similarity index 100% rename from db/man/query.data.Rd rename to base/db/man/query.data.Rd diff --git a/db/man/query.file.path.Rd b/base/db/man/query.file.path.Rd similarity index 100% rename from db/man/query.file.path.Rd rename to base/db/man/query.file.path.Rd diff --git a/db/man/query.format.vars.Rd b/base/db/man/query.format.vars.Rd similarity index 100% rename from db/man/query.format.vars.Rd rename to base/db/man/query.format.vars.Rd diff --git a/db/man/query.pft_species.Rd b/base/db/man/query.pft_species.Rd similarity index 100% rename from db/man/query.pft_species.Rd rename to base/db/man/query.pft_species.Rd diff --git a/db/man/query.priors.Rd b/base/db/man/query.priors.Rd similarity index 100% rename from db/man/query.priors.Rd rename to base/db/man/query.priors.Rd diff --git a/db/man/query.site.Rd b/base/db/man/query.site.Rd similarity index 100% rename from db/man/query.site.Rd rename to base/db/man/query.site.Rd diff --git a/db/man/query.trait.data.Rd b/base/db/man/query.trait.data.Rd similarity index 100% rename from db/man/query.trait.data.Rd rename to base/db/man/query.trait.data.Rd diff --git a/db/man/query.traits.Rd b/base/db/man/query.traits.Rd similarity index 100% rename from db/man/query.traits.Rd rename to base/db/man/query.traits.Rd diff --git a/db/man/query.yields.Rd b/base/db/man/query.yields.Rd similarity index 100% rename from db/man/query.yields.Rd rename to base/db/man/query.yields.Rd diff --git a/db/man/rename.jags.columns.Rd b/base/db/man/rename.jags.columns.Rd similarity index 100% rename from db/man/rename.jags.columns.Rd rename to base/db/man/rename.jags.columns.Rd diff --git a/db/man/runs.Rd b/base/db/man/runs.Rd similarity index 100% rename from db/man/runs.Rd rename to base/db/man/runs.Rd diff --git a/db/man/take.samples.Rd b/base/db/man/take.samples.Rd similarity index 100% rename from db/man/take.samples.Rd rename to base/db/man/take.samples.Rd diff --git a/db/man/var_names_all.Rd b/base/db/man/var_names_all.Rd similarity index 100% rename from db/man/var_names_all.Rd rename to base/db/man/var_names_all.Rd diff --git a/db/man/workflow.Rd b/base/db/man/workflow.Rd similarity index 100% rename from db/man/workflow.Rd rename to base/db/man/workflow.Rd diff --git a/db/man/workflows.Rd b/base/db/man/workflows.Rd similarity index 100% rename from db/man/workflows.Rd rename to base/db/man/workflows.Rd diff --git a/db/tests/testthat.R b/base/db/tests/testthat.R similarity index 100% rename from db/tests/testthat.R rename to base/db/tests/testthat.R diff --git a/db/tests/testthat/db.setup.R b/base/db/tests/testthat/db.setup.R similarity index 100% rename from db/tests/testthat/db.setup.R rename to base/db/tests/testthat/db.setup.R diff --git a/db/tests/testthat/test.contents_sanity.R b/base/db/tests/testthat/test.contents_sanity.R similarity index 100% rename from db/tests/testthat/test.contents_sanity.R rename to base/db/tests/testthat/test.contents_sanity.R diff --git a/db/tests/testthat/test.db.utils.R b/base/db/tests/testthat/test.db.utils.R similarity index 100% rename from db/tests/testthat/test.db.utils.R rename to base/db/tests/testthat/test.db.utils.R diff --git a/db/tests/testthat/test.derive.traits.R b/base/db/tests/testthat/test.derive.traits.R similarity index 100% rename from db/tests/testthat/test.derive.traits.R rename to base/db/tests/testthat/test.derive.traits.R diff --git a/db/tests/testthat/test.query.base.R b/base/db/tests/testthat/test.query.base.R similarity index 100% rename from db/tests/testthat/test.query.base.R rename to base/db/tests/testthat/test.query.base.R diff --git a/db/vignettes/betydb_access.Rmd b/base/db/vignettes/betydb_access.Rmd similarity index 100% rename from db/vignettes/betydb_access.Rmd rename to base/db/vignettes/betydb_access.Rmd diff --git a/db/vignettes/create_sites.geometry.Rmd b/base/db/vignettes/create_sites.geometry.Rmd similarity index 100% rename from db/vignettes/create_sites.geometry.Rmd rename to base/db/vignettes/create_sites.geometry.Rmd diff --git a/settings/.Rbuildignore b/base/settings/.Rbuildignore similarity index 100% rename from settings/.Rbuildignore rename to base/settings/.Rbuildignore diff --git a/settings/DESCRIPTION b/base/settings/DESCRIPTION similarity index 100% rename from settings/DESCRIPTION rename to base/settings/DESCRIPTION diff --git a/settings/LICENSE b/base/settings/LICENSE similarity index 100% rename from settings/LICENSE rename to base/settings/LICENSE diff --git a/settings/NAMESPACE b/base/settings/NAMESPACE similarity index 100% rename from settings/NAMESPACE rename to base/settings/NAMESPACE diff --git a/settings/R/MultiSettings.R b/base/settings/R/MultiSettings.R similarity index 100% rename from settings/R/MultiSettings.R rename to base/settings/R/MultiSettings.R diff --git a/settings/R/Settings.R b/base/settings/R/Settings.R similarity index 100% rename from settings/R/Settings.R rename to base/settings/R/Settings.R diff --git a/settings/R/addSecrets.R b/base/settings/R/addSecrets.R similarity index 100% rename from settings/R/addSecrets.R rename to base/settings/R/addSecrets.R diff --git a/settings/R/check.all.settings.R b/base/settings/R/check.all.settings.R similarity index 100% rename from settings/R/check.all.settings.R rename to base/settings/R/check.all.settings.R diff --git a/settings/R/clean.settings.R b/base/settings/R/clean.settings.R similarity index 100% rename from settings/R/clean.settings.R rename to base/settings/R/clean.settings.R diff --git a/settings/R/createMultisiteMultiSettings.r b/base/settings/R/createMultisiteMultiSettings.r similarity index 100% rename from settings/R/createMultisiteMultiSettings.r rename to base/settings/R/createMultisiteMultiSettings.r diff --git a/settings/R/fix.deprecated.settings.R b/base/settings/R/fix.deprecated.settings.R similarity index 100% rename from settings/R/fix.deprecated.settings.R rename to base/settings/R/fix.deprecated.settings.R diff --git a/settings/R/papply.R b/base/settings/R/papply.R similarity index 100% rename from settings/R/papply.R rename to base/settings/R/papply.R diff --git a/settings/R/prepare.settings.R b/base/settings/R/prepare.settings.R similarity index 100% rename from settings/R/prepare.settings.R rename to base/settings/R/prepare.settings.R diff --git a/settings/R/read.settings.R b/base/settings/R/read.settings.R similarity index 100% rename from settings/R/read.settings.R rename to base/settings/R/read.settings.R diff --git a/settings/R/update.settings.R b/base/settings/R/update.settings.R similarity index 100% rename from settings/R/update.settings.R rename to base/settings/R/update.settings.R diff --git a/settings/R/write.settings.R b/base/settings/R/write.settings.R similarity index 100% rename from settings/R/write.settings.R rename to base/settings/R/write.settings.R diff --git a/settings/examples/examples.MultiSite.MultiSettings.r b/base/settings/examples/examples.MultiSite.MultiSettings.r similarity index 100% rename from settings/examples/examples.MultiSite.MultiSettings.r rename to base/settings/examples/examples.MultiSite.MultiSettings.r diff --git a/settings/examples/examples.papply.R b/base/settings/examples/examples.papply.R similarity index 100% rename from settings/examples/examples.papply.R rename to base/settings/examples/examples.papply.R diff --git a/settings/man/.Rapp.history b/base/settings/man/.Rapp.history similarity index 100% rename from settings/man/.Rapp.history rename to base/settings/man/.Rapp.history diff --git a/settings/man/MultiSettings.Rd b/base/settings/man/MultiSettings.Rd similarity index 100% rename from settings/man/MultiSettings.Rd rename to base/settings/man/MultiSettings.Rd diff --git a/settings/man/Settings.Rd b/base/settings/man/Settings.Rd similarity index 100% rename from settings/man/Settings.Rd rename to base/settings/man/Settings.Rd diff --git a/settings/man/addSecrets.Rd b/base/settings/man/addSecrets.Rd similarity index 100% rename from settings/man/addSecrets.Rd rename to base/settings/man/addSecrets.Rd diff --git a/settings/man/check.bety.version.Rd b/base/settings/man/check.bety.version.Rd similarity index 100% rename from settings/man/check.bety.version.Rd rename to base/settings/man/check.bety.version.Rd diff --git a/settings/man/check.database.Rd b/base/settings/man/check.database.Rd similarity index 100% rename from settings/man/check.database.Rd rename to base/settings/man/check.database.Rd diff --git a/settings/man/check.database.settings.Rd b/base/settings/man/check.database.settings.Rd similarity index 100% rename from settings/man/check.database.settings.Rd rename to base/settings/man/check.database.settings.Rd diff --git a/settings/man/check.inputs.Rd b/base/settings/man/check.inputs.Rd similarity index 100% rename from settings/man/check.inputs.Rd rename to base/settings/man/check.inputs.Rd diff --git a/settings/man/check.model.settings.Rd b/base/settings/man/check.model.settings.Rd similarity index 100% rename from settings/man/check.model.settings.Rd rename to base/settings/man/check.model.settings.Rd diff --git a/settings/man/check.run.settings.Rd b/base/settings/man/check.run.settings.Rd similarity index 100% rename from settings/man/check.run.settings.Rd rename to base/settings/man/check.run.settings.Rd diff --git a/settings/man/check.settings.Rd b/base/settings/man/check.settings.Rd similarity index 100% rename from settings/man/check.settings.Rd rename to base/settings/man/check.settings.Rd diff --git a/settings/man/check.workflow.settings.Rd b/base/settings/man/check.workflow.settings.Rd similarity index 100% rename from settings/man/check.workflow.settings.Rd rename to base/settings/man/check.workflow.settings.Rd diff --git a/settings/man/clean.settings.Rd b/base/settings/man/clean.settings.Rd similarity index 100% rename from settings/man/clean.settings.Rd rename to base/settings/man/clean.settings.Rd diff --git a/settings/man/createMultiSiteSettings.Rd b/base/settings/man/createMultiSiteSettings.Rd similarity index 100% rename from settings/man/createMultiSiteSettings.Rd rename to base/settings/man/createMultiSiteSettings.Rd diff --git a/settings/man/createSitegroupMultiSettings.Rd b/base/settings/man/createSitegroupMultiSettings.Rd similarity index 100% rename from settings/man/createSitegroupMultiSettings.Rd rename to base/settings/man/createSitegroupMultiSettings.Rd diff --git a/settings/man/fix.deprecated.settings.Rd b/base/settings/man/fix.deprecated.settings.Rd similarity index 100% rename from settings/man/fix.deprecated.settings.Rd rename to base/settings/man/fix.deprecated.settings.Rd diff --git a/settings/man/getRunSettings.Rd b/base/settings/man/getRunSettings.Rd similarity index 100% rename from settings/man/getRunSettings.Rd rename to base/settings/man/getRunSettings.Rd diff --git a/settings/man/papply.Rd b/base/settings/man/papply.Rd similarity index 100% rename from settings/man/papply.Rd rename to base/settings/man/papply.Rd diff --git a/settings/man/prepare.settings.Rd b/base/settings/man/prepare.settings.Rd similarity index 100% rename from settings/man/prepare.settings.Rd rename to base/settings/man/prepare.settings.Rd diff --git a/settings/man/read.settings.Rd b/base/settings/man/read.settings.Rd similarity index 100% rename from settings/man/read.settings.Rd rename to base/settings/man/read.settings.Rd diff --git a/settings/man/setDates.Rd b/base/settings/man/setDates.Rd similarity index 100% rename from settings/man/setDates.Rd rename to base/settings/man/setDates.Rd diff --git a/settings/man/setOutDir.Rd b/base/settings/man/setOutDir.Rd similarity index 100% rename from settings/man/setOutDir.Rd rename to base/settings/man/setOutDir.Rd diff --git a/settings/man/update.settings.Rd b/base/settings/man/update.settings.Rd similarity index 100% rename from settings/man/update.settings.Rd rename to base/settings/man/update.settings.Rd diff --git a/settings/man/write.settings.Rd b/base/settings/man/write.settings.Rd similarity index 100% rename from settings/man/write.settings.Rd rename to base/settings/man/write.settings.Rd diff --git a/settings/tests/testthat.R b/base/settings/tests/testthat.R similarity index 100% rename from settings/tests/testthat.R rename to base/settings/tests/testthat.R diff --git a/settings/tests/testthat/get.test.settings.R b/base/settings/tests/testthat/get.test.settings.R similarity index 100% rename from settings/tests/testthat/get.test.settings.R rename to base/settings/tests/testthat/get.test.settings.R diff --git a/settings/tests/testthat/test.MultiSettings.class.R b/base/settings/tests/testthat/test.MultiSettings.class.R similarity index 100% rename from settings/tests/testthat/test.MultiSettings.class.R rename to base/settings/tests/testthat/test.MultiSettings.class.R diff --git a/settings/tests/testthat/test.Settings.class.R b/base/settings/tests/testthat/test.Settings.class.R similarity index 100% rename from settings/tests/testthat/test.Settings.class.R rename to base/settings/tests/testthat/test.Settings.class.R diff --git a/settings/tests/testthat/test.deprecated.settings.R b/base/settings/tests/testthat/test.deprecated.settings.R similarity index 100% rename from settings/tests/testthat/test.deprecated.settings.R rename to base/settings/tests/testthat/test.deprecated.settings.R diff --git a/settings/tests/testthat/test.papply.R b/base/settings/tests/testthat/test.papply.R similarity index 100% rename from settings/tests/testthat/test.papply.R rename to base/settings/tests/testthat/test.papply.R diff --git a/settings/tests/testthat/test.read.settings.R b/base/settings/tests/testthat/test.read.settings.R similarity index 100% rename from settings/tests/testthat/test.read.settings.R rename to base/settings/tests/testthat/test.read.settings.R diff --git a/settings/tests/testthat/testinput.pecan2.bu.edu.xml b/base/settings/tests/testthat/testinput.pecan2.bu.edu.xml similarity index 100% rename from settings/tests/testthat/testinput.pecan2.bu.edu.xml rename to base/settings/tests/testthat/testinput.pecan2.bu.edu.xml diff --git a/settings/tests/testthat/testinput.xml b/base/settings/tests/testthat/testinput.xml similarity index 100% rename from settings/tests/testthat/testinput.xml rename to base/settings/tests/testthat/testinput.xml diff --git a/settings/tests/testthat/testsettings.xml b/base/settings/tests/testthat/testsettings.xml similarity index 100% rename from settings/tests/testthat/testsettings.xml rename to base/settings/tests/testthat/testsettings.xml diff --git a/utils/.Rbuildignore b/base/utils/.Rbuildignore similarity index 100% rename from utils/.Rbuildignore rename to base/utils/.Rbuildignore diff --git a/utils/DESCRIPTION b/base/utils/DESCRIPTION similarity index 100% rename from utils/DESCRIPTION rename to base/utils/DESCRIPTION diff --git a/utils/LICENSE b/base/utils/LICENSE similarity index 100% rename from utils/LICENSE rename to base/utils/LICENSE diff --git a/utils/NAMESPACE b/base/utils/NAMESPACE similarity index 100% rename from utils/NAMESPACE rename to base/utils/NAMESPACE diff --git a/utils/R/SafeList.R b/base/utils/R/SafeList.R similarity index 100% rename from utils/R/SafeList.R rename to base/utils/R/SafeList.R diff --git a/utils/R/clear.scratch.R b/base/utils/R/clear.scratch.R similarity index 100% rename from utils/R/clear.scratch.R rename to base/utils/R/clear.scratch.R diff --git a/utils/R/convert.input.R b/base/utils/R/convert.input.R similarity index 100% rename from utils/R/convert.input.R rename to base/utils/R/convert.input.R diff --git a/utils/R/distn.stats.R b/base/utils/R/distn.stats.R similarity index 100% rename from utils/R/distn.stats.R rename to base/utils/R/distn.stats.R diff --git a/utils/R/do_conversions.R b/base/utils/R/do_conversions.R similarity index 100% rename from utils/R/do_conversions.R rename to base/utils/R/do_conversions.R diff --git a/utils/R/download.url.R b/base/utils/R/download.url.R similarity index 100% rename from utils/R/download.url.R rename to base/utils/R/download.url.R diff --git a/utils/R/ensemble.R b/base/utils/R/ensemble.R similarity index 100% rename from utils/R/ensemble.R rename to base/utils/R/ensemble.R diff --git a/utils/R/fqdn.R b/base/utils/R/fqdn.R similarity index 100% rename from utils/R/fqdn.R rename to base/utils/R/fqdn.R diff --git a/utils/R/full.path.R b/base/utils/R/full.path.R similarity index 100% rename from utils/R/full.path.R rename to base/utils/R/full.path.R diff --git a/utils/R/get.analysis.filenames.r b/base/utils/R/get.analysis.filenames.r similarity index 100% rename from utils/R/get.analysis.filenames.r rename to base/utils/R/get.analysis.filenames.r diff --git a/utils/R/get.ensemble.inputs.R b/base/utils/R/get.ensemble.inputs.R similarity index 100% rename from utils/R/get.ensemble.inputs.R rename to base/utils/R/get.ensemble.inputs.R diff --git a/utils/R/get.model.output.R b/base/utils/R/get.model.output.R similarity index 100% rename from utils/R/get.model.output.R rename to base/utils/R/get.model.output.R diff --git a/utils/R/get.parameter.samples.R b/base/utils/R/get.parameter.samples.R similarity index 100% rename from utils/R/get.parameter.samples.R rename to base/utils/R/get.parameter.samples.R diff --git a/utils/R/get.results.R b/base/utils/R/get.results.R similarity index 100% rename from utils/R/get.results.R rename to base/utils/R/get.results.R diff --git a/utils/R/help.R b/base/utils/R/help.R similarity index 100% rename from utils/R/help.R rename to base/utils/R/help.R diff --git a/utils/R/kill.tunnel.R b/base/utils/R/kill.tunnel.R similarity index 100% rename from utils/R/kill.tunnel.R rename to base/utils/R/kill.tunnel.R diff --git a/utils/R/listToArgString.R b/base/utils/R/listToArgString.R similarity index 100% rename from utils/R/listToArgString.R rename to base/utils/R/listToArgString.R diff --git a/utils/R/logger.R b/base/utils/R/logger.R similarity index 100% rename from utils/R/logger.R rename to base/utils/R/logger.R diff --git a/utils/R/mail.R b/base/utils/R/mail.R similarity index 100% rename from utils/R/mail.R rename to base/utils/R/mail.R diff --git a/utils/R/n_leap_day.R b/base/utils/R/n_leap_day.R similarity index 100% rename from utils/R/n_leap_day.R rename to base/utils/R/n_leap_day.R diff --git a/utils/R/open.tunnel.R b/base/utils/R/open.tunnel.R similarity index 100% rename from utils/R/open.tunnel.R rename to base/utils/R/open.tunnel.R diff --git a/utils/R/plots.R b/base/utils/R/plots.R similarity index 100% rename from utils/R/plots.R rename to base/utils/R/plots.R diff --git a/utils/R/r2bugs.distributions.R b/base/utils/R/r2bugs.distributions.R similarity index 100% rename from utils/R/r2bugs.distributions.R rename to base/utils/R/r2bugs.distributions.R diff --git a/utils/R/read.output.R b/base/utils/R/read.output.R similarity index 100% rename from utils/R/read.output.R rename to base/utils/R/read.output.R diff --git a/utils/R/regrid.R b/base/utils/R/regrid.R similarity index 100% rename from utils/R/regrid.R rename to base/utils/R/regrid.R diff --git a/utils/R/remote.R b/base/utils/R/remote.R similarity index 100% rename from utils/R/remote.R rename to base/utils/R/remote.R diff --git a/utils/R/remove.config.R b/base/utils/R/remove.config.R similarity index 100% rename from utils/R/remove.config.R rename to base/utils/R/remove.config.R diff --git a/utils/R/run.write.configs.R b/base/utils/R/run.write.configs.R similarity index 100% rename from utils/R/run.write.configs.R rename to base/utils/R/run.write.configs.R diff --git a/utils/R/sensitivity.R b/base/utils/R/sensitivity.R similarity index 100% rename from utils/R/sensitivity.R rename to base/utils/R/sensitivity.R diff --git a/utils/R/start.model.runs.R b/base/utils/R/start.model.runs.R similarity index 100% rename from utils/R/start.model.runs.R rename to base/utils/R/start.model.runs.R diff --git a/utils/R/status.R b/base/utils/R/status.R similarity index 100% rename from utils/R/status.R rename to base/utils/R/status.R diff --git a/utils/R/timezone_hour.R b/base/utils/R/timezone_hour.R similarity index 100% rename from utils/R/timezone_hour.R rename to base/utils/R/timezone_hour.R diff --git a/utils/R/to_nc.R b/base/utils/R/to_nc.R similarity index 100% rename from utils/R/to_nc.R rename to base/utils/R/to_nc.R diff --git a/utils/R/transformstats.R b/base/utils/R/transformstats.R similarity index 100% rename from utils/R/transformstats.R rename to base/utils/R/transformstats.R diff --git a/utils/R/utils.R b/base/utils/R/utils.R similarity index 100% rename from utils/R/utils.R rename to base/utils/R/utils.R diff --git a/utils/R/write.config.utils.R b/base/utils/R/write.config.utils.R similarity index 100% rename from utils/R/write.config.utils.R rename to base/utils/R/write.config.utils.R diff --git a/utils/data/madata.RData b/base/utils/data/madata.RData similarity index 100% rename from utils/data/madata.RData rename to base/utils/data/madata.RData diff --git a/utils/data/mstmip_local.csv b/base/utils/data/mstmip_local.csv similarity index 100% rename from utils/data/mstmip_local.csv rename to base/utils/data/mstmip_local.csv diff --git a/utils/data/mstmip_vars.csv b/base/utils/data/mstmip_vars.csv similarity index 100% rename from utils/data/mstmip_vars.csv rename to base/utils/data/mstmip_vars.csv diff --git a/utils/data/output.RData b/base/utils/data/output.RData similarity index 100% rename from utils/data/output.RData rename to base/utils/data/output.RData diff --git a/utils/data/post.distns.RData b/base/utils/data/post.distns.RData similarity index 100% rename from utils/data/post.distns.RData rename to base/utils/data/post.distns.RData diff --git a/utils/data/prior.distns.RData b/base/utils/data/prior.distns.RData similarity index 100% rename from utils/data/prior.distns.RData rename to base/utils/data/prior.distns.RData diff --git a/utils/data/samples.RData b/base/utils/data/samples.RData similarity index 100% rename from utils/data/samples.RData rename to base/utils/data/samples.RData diff --git a/utils/data/sensitivity.results.RData b/base/utils/data/sensitivity.results.RData similarity index 100% rename from utils/data/sensitivity.results.RData rename to base/utils/data/sensitivity.results.RData diff --git a/utils/data/settings.RData b/base/utils/data/settings.RData similarity index 100% rename from utils/data/settings.RData rename to base/utils/data/settings.RData diff --git a/utils/data/standard_vars.csv b/base/utils/data/standard_vars.csv similarity index 100% rename from utils/data/standard_vars.csv rename to base/utils/data/standard_vars.csv diff --git a/utils/data/time.constants.RData b/base/utils/data/time.constants.RData similarity index 100% rename from utils/data/time.constants.RData rename to base/utils/data/time.constants.RData diff --git a/utils/data/trait.data.RData b/base/utils/data/trait.data.RData similarity index 100% rename from utils/data/trait.data.RData rename to base/utils/data/trait.data.RData diff --git a/utils/data/trait.dictionary.csv b/base/utils/data/trait.dictionary.csv similarity index 100% rename from utils/data/trait.dictionary.csv rename to base/utils/data/trait.dictionary.csv diff --git a/utils/data/trait.mcmc.RData b/base/utils/data/trait.mcmc.RData similarity index 100% rename from utils/data/trait.mcmc.RData rename to base/utils/data/trait.mcmc.RData diff --git a/utils/inst/LBNL_remote_test.R b/base/utils/inst/LBNL_remote_test.R similarity index 100% rename from utils/inst/LBNL_remote_test.R rename to base/utils/inst/LBNL_remote_test.R diff --git a/utils/inst/clear.scratch.sh b/base/utils/inst/clear.scratch.sh similarity index 100% rename from utils/inst/clear.scratch.sh rename to base/utils/inst/clear.scratch.sh diff --git a/utils/get_mstmip_vars.R b/base/utils/inst/get_mstmip_vars.R similarity index 100% rename from utils/get_mstmip_vars.R rename to base/utils/inst/get_mstmip_vars.R diff --git a/utils/man/PEcAn.Rd b/base/utils/man/PEcAn.Rd similarity index 100% rename from utils/man/PEcAn.Rd rename to base/utils/man/PEcAn.Rd diff --git a/utils/man/SafeList.Rd b/base/utils/man/SafeList.Rd similarity index 100% rename from utils/man/SafeList.Rd rename to base/utils/man/SafeList.Rd diff --git a/utils/man/arrhenius.scaling.Rd b/base/utils/man/arrhenius.scaling.Rd similarity index 100% rename from utils/man/arrhenius.scaling.Rd rename to base/utils/man/arrhenius.scaling.Rd diff --git a/utils/man/as.sequence.Rd b/base/utils/man/as.sequence.Rd similarity index 100% rename from utils/man/as.sequence.Rd rename to base/utils/man/as.sequence.Rd diff --git a/utils/man/bibtexify.Rd b/base/utils/man/bibtexify.Rd similarity index 100% rename from utils/man/bibtexify.Rd rename to base/utils/man/bibtexify.Rd diff --git a/utils/man/bugs.rdist.Rd b/base/utils/man/bugs.rdist.Rd similarity index 100% rename from utils/man/bugs.rdist.Rd rename to base/utils/man/bugs.rdist.Rd diff --git a/utils/man/capitalize.Rd b/base/utils/man/capitalize.Rd similarity index 100% rename from utils/man/capitalize.Rd rename to base/utils/man/capitalize.Rd diff --git a/utils/man/cash-.SafeList.Rd b/base/utils/man/cash-.SafeList.Rd similarity index 100% rename from utils/man/cash-.SafeList.Rd rename to base/utils/man/cash-.SafeList.Rd diff --git a/utils/man/clear.scratch.Rd b/base/utils/man/clear.scratch.Rd similarity index 100% rename from utils/man/clear.scratch.Rd rename to base/utils/man/clear.scratch.Rd diff --git a/utils/man/convert.expr.Rd b/base/utils/man/convert.expr.Rd similarity index 100% rename from utils/man/convert.expr.Rd rename to base/utils/man/convert.expr.Rd diff --git a/utils/man/convert.input.Rd b/base/utils/man/convert.input.Rd similarity index 100% rename from utils/man/convert.input.Rd rename to base/utils/man/convert.input.Rd diff --git a/utils/man/convert.outputs.Rd b/base/utils/man/convert.outputs.Rd similarity index 100% rename from utils/man/convert.outputs.Rd rename to base/utils/man/convert.outputs.Rd diff --git a/utils/man/counter.Rd b/base/utils/man/counter.Rd similarity index 100% rename from utils/man/counter.Rd rename to base/utils/man/counter.Rd diff --git a/utils/man/create.base.plot.Rd b/base/utils/man/create.base.plot.Rd similarity index 100% rename from utils/man/create.base.plot.Rd rename to base/utils/man/create.base.plot.Rd diff --git a/utils/man/dhist.Rd b/base/utils/man/dhist.Rd similarity index 100% rename from utils/man/dhist.Rd rename to base/utils/man/dhist.Rd diff --git a/utils/man/distn.stats.Rd b/base/utils/man/distn.stats.Rd similarity index 100% rename from utils/man/distn.stats.Rd rename to base/utils/man/distn.stats.Rd diff --git a/utils/man/distn.table.stats.Rd b/base/utils/man/distn.table.stats.Rd similarity index 100% rename from utils/man/distn.table.stats.Rd rename to base/utils/man/distn.table.stats.Rd diff --git a/utils/man/do_conversions.Rd b/base/utils/man/do_conversions.Rd similarity index 100% rename from utils/man/do_conversions.Rd rename to base/utils/man/do_conversions.Rd diff --git a/utils/man/download.file.Rd b/base/utils/man/download.file.Rd similarity index 100% rename from utils/man/download.file.Rd rename to base/utils/man/download.file.Rd diff --git a/utils/man/download.url.Rd b/base/utils/man/download.url.Rd similarity index 100% rename from utils/man/download.url.Rd rename to base/utils/man/download.url.Rd diff --git a/utils/man/ensemble.filename.Rd b/base/utils/man/ensemble.filename.Rd similarity index 100% rename from utils/man/ensemble.filename.Rd rename to base/utils/man/ensemble.filename.Rd diff --git a/utils/man/fqdn.Rd b/base/utils/man/fqdn.Rd similarity index 100% rename from utils/man/fqdn.Rd rename to base/utils/man/fqdn.Rd diff --git a/utils/man/full.path.Rd b/base/utils/man/full.path.Rd similarity index 100% rename from utils/man/full.path.Rd rename to base/utils/man/full.path.Rd diff --git a/utils/man/get.ensemble.inputs.Rd b/base/utils/man/get.ensemble.inputs.Rd similarity index 100% rename from utils/man/get.ensemble.inputs.Rd rename to base/utils/man/get.ensemble.inputs.Rd diff --git a/utils/man/get.ensemble.samples.Rd b/base/utils/man/get.ensemble.samples.Rd similarity index 100% rename from utils/man/get.ensemble.samples.Rd rename to base/utils/man/get.ensemble.samples.Rd diff --git a/utils/man/get.model.output.Rd b/base/utils/man/get.model.output.Rd similarity index 100% rename from utils/man/get.model.output.Rd rename to base/utils/man/get.model.output.Rd diff --git a/utils/man/get.parameter.samples.Rd b/base/utils/man/get.parameter.samples.Rd similarity index 100% rename from utils/man/get.parameter.samples.Rd rename to base/utils/man/get.parameter.samples.Rd diff --git a/utils/man/get.parameter.stat.Rd b/base/utils/man/get.parameter.stat.Rd similarity index 100% rename from utils/man/get.parameter.stat.Rd rename to base/utils/man/get.parameter.stat.Rd diff --git a/utils/man/get.quantiles.Rd b/base/utils/man/get.quantiles.Rd similarity index 100% rename from utils/man/get.quantiles.Rd rename to base/utils/man/get.quantiles.Rd diff --git a/utils/man/get.results.Rd b/base/utils/man/get.results.Rd similarity index 100% rename from utils/man/get.results.Rd rename to base/utils/man/get.results.Rd diff --git a/utils/man/get.run.id.Rd b/base/utils/man/get.run.id.Rd similarity index 100% rename from utils/man/get.run.id.Rd rename to base/utils/man/get.run.id.Rd diff --git a/utils/man/get.sa.sample.list.Rd b/base/utils/man/get.sa.sample.list.Rd similarity index 100% rename from utils/man/get.sa.sample.list.Rd rename to base/utils/man/get.sa.sample.list.Rd diff --git a/utils/man/get.sa.samples.Rd b/base/utils/man/get.sa.samples.Rd similarity index 100% rename from utils/man/get.sa.samples.Rd rename to base/utils/man/get.sa.samples.Rd diff --git a/utils/man/get.stats.mcmc.Rd b/base/utils/man/get.stats.mcmc.Rd similarity index 100% rename from utils/man/get.stats.mcmc.Rd rename to base/utils/man/get.stats.mcmc.Rd diff --git a/utils/man/grid2netcdf.Rd b/base/utils/man/grid2netcdf.Rd similarity index 100% rename from utils/man/grid2netcdf.Rd rename to base/utils/man/grid2netcdf.Rd diff --git a/utils/man/iqr.Rd b/base/utils/man/iqr.Rd similarity index 100% rename from utils/man/iqr.Rd rename to base/utils/man/iqr.Rd diff --git a/utils/man/is.localhost.Rd b/base/utils/man/is.localhost.Rd similarity index 100% rename from utils/man/is.localhost.Rd rename to base/utils/man/is.localhost.Rd diff --git a/utils/man/kill.tunnel.Rd b/base/utils/man/kill.tunnel.Rd similarity index 100% rename from utils/man/kill.tunnel.Rd rename to base/utils/man/kill.tunnel.Rd diff --git a/utils/man/left.pad.zeros.Rd b/base/utils/man/left.pad.zeros.Rd similarity index 100% rename from utils/man/left.pad.zeros.Rd rename to base/utils/man/left.pad.zeros.Rd diff --git a/utils/man/listToArgString.Rd b/base/utils/man/listToArgString.Rd similarity index 100% rename from utils/man/listToArgString.Rd rename to base/utils/man/listToArgString.Rd diff --git a/utils/man/listToXml.default.Rd b/base/utils/man/listToXml.default.Rd similarity index 100% rename from utils/man/listToXml.default.Rd rename to base/utils/man/listToXml.default.Rd diff --git a/utils/man/load.modelpkg.Rd b/base/utils/man/load.modelpkg.Rd similarity index 100% rename from utils/man/load.modelpkg.Rd rename to base/utils/man/load.modelpkg.Rd diff --git a/utils/man/logger.debug.Rd b/base/utils/man/logger.debug.Rd similarity index 100% rename from utils/man/logger.debug.Rd rename to base/utils/man/logger.debug.Rd diff --git a/utils/man/logger.error.Rd b/base/utils/man/logger.error.Rd similarity index 100% rename from utils/man/logger.error.Rd rename to base/utils/man/logger.error.Rd diff --git a/utils/man/logger.getLevel.Rd b/base/utils/man/logger.getLevel.Rd similarity index 100% rename from utils/man/logger.getLevel.Rd rename to base/utils/man/logger.getLevel.Rd diff --git a/utils/man/logger.getLevelNumber.Rd b/base/utils/man/logger.getLevelNumber.Rd similarity index 100% rename from utils/man/logger.getLevelNumber.Rd rename to base/utils/man/logger.getLevelNumber.Rd diff --git a/utils/man/logger.info.Rd b/base/utils/man/logger.info.Rd similarity index 100% rename from utils/man/logger.info.Rd rename to base/utils/man/logger.info.Rd diff --git a/utils/man/logger.message.Rd b/base/utils/man/logger.message.Rd similarity index 100% rename from utils/man/logger.message.Rd rename to base/utils/man/logger.message.Rd diff --git a/utils/man/logger.setLevel.Rd b/base/utils/man/logger.setLevel.Rd similarity index 100% rename from utils/man/logger.setLevel.Rd rename to base/utils/man/logger.setLevel.Rd diff --git a/utils/man/logger.setOutputFile.Rd b/base/utils/man/logger.setOutputFile.Rd similarity index 100% rename from utils/man/logger.setOutputFile.Rd rename to base/utils/man/logger.setOutputFile.Rd diff --git a/utils/man/logger.setQuitOnSevere.Rd b/base/utils/man/logger.setQuitOnSevere.Rd similarity index 100% rename from utils/man/logger.setQuitOnSevere.Rd rename to base/utils/man/logger.setQuitOnSevere.Rd diff --git a/utils/man/logger.setUseConsole.Rd b/base/utils/man/logger.setUseConsole.Rd similarity index 100% rename from utils/man/logger.setUseConsole.Rd rename to base/utils/man/logger.setUseConsole.Rd diff --git a/utils/man/logger.setWidth.Rd b/base/utils/man/logger.setWidth.Rd similarity index 100% rename from utils/man/logger.setWidth.Rd rename to base/utils/man/logger.setWidth.Rd diff --git a/utils/man/logger.severe.Rd b/base/utils/man/logger.severe.Rd similarity index 100% rename from utils/man/logger.severe.Rd rename to base/utils/man/logger.severe.Rd diff --git a/utils/man/logger.warn.Rd b/base/utils/man/logger.warn.Rd similarity index 100% rename from utils/man/logger.warn.Rd rename to base/utils/man/logger.warn.Rd diff --git a/utils/man/met2model.exists.Rd b/base/utils/man/met2model.exists.Rd similarity index 100% rename from utils/man/met2model.exists.Rd rename to base/utils/man/met2model.exists.Rd diff --git a/utils/man/misc.are.convertible.Rd b/base/utils/man/misc.are.convertible.Rd similarity index 100% rename from utils/man/misc.are.convertible.Rd rename to base/utils/man/misc.are.convertible.Rd diff --git a/utils/man/misc.convert.Rd b/base/utils/man/misc.convert.Rd similarity index 100% rename from utils/man/misc.convert.Rd rename to base/utils/man/misc.convert.Rd diff --git a/utils/man/model2netcdf.Rd b/base/utils/man/model2netcdf.Rd similarity index 100% rename from utils/man/model2netcdf.Rd rename to base/utils/man/model2netcdf.Rd diff --git a/utils/man/model2netcdfdep.Rd b/base/utils/man/model2netcdfdep.Rd similarity index 100% rename from utils/man/model2netcdfdep.Rd rename to base/utils/man/model2netcdfdep.Rd diff --git a/utils/man/mstmipvar.Rd b/base/utils/man/mstmipvar.Rd similarity index 100% rename from utils/man/mstmipvar.Rd rename to base/utils/man/mstmipvar.Rd diff --git a/utils/man/n_leap_day.Rd b/base/utils/man/n_leap_day.Rd similarity index 100% rename from utils/man/n_leap_day.Rd rename to base/utils/man/n_leap_day.Rd diff --git a/utils/man/newxtable.Rd b/base/utils/man/newxtable.Rd similarity index 100% rename from utils/man/newxtable.Rd rename to base/utils/man/newxtable.Rd diff --git a/utils/man/open_tunnel.Rd b/base/utils/man/open_tunnel.Rd similarity index 100% rename from utils/man/open_tunnel.Rd rename to base/utils/man/open_tunnel.Rd diff --git a/utils/man/paste.stats.Rd b/base/utils/man/paste.stats.Rd similarity index 100% rename from utils/man/paste.stats.Rd rename to base/utils/man/paste.stats.Rd diff --git a/utils/man/pdf.stats.Rd b/base/utils/man/pdf.stats.Rd similarity index 100% rename from utils/man/pdf.stats.Rd rename to base/utils/man/pdf.stats.Rd diff --git a/utils/man/plot_data.Rd b/base/utils/man/plot_data.Rd similarity index 100% rename from utils/man/plot_data.Rd rename to base/utils/man/plot_data.Rd diff --git a/utils/man/r2bugs.distributions.Rd b/base/utils/man/r2bugs.distributions.Rd similarity index 100% rename from utils/man/r2bugs.distributions.Rd rename to base/utils/man/r2bugs.distributions.Rd diff --git a/utils/man/read.ensemble.output.Rd b/base/utils/man/read.ensemble.output.Rd similarity index 100% rename from utils/man/read.ensemble.output.Rd rename to base/utils/man/read.ensemble.output.Rd diff --git a/utils/man/read.output.Rd b/base/utils/man/read.output.Rd similarity index 100% rename from utils/man/read.output.Rd rename to base/utils/man/read.output.Rd diff --git a/utils/man/read.sa.output.Rd b/base/utils/man/read.sa.output.Rd similarity index 100% rename from utils/man/read.sa.output.Rd rename to base/utils/man/read.sa.output.Rd diff --git a/utils/man/regrid.Rd b/base/utils/man/regrid.Rd similarity index 100% rename from utils/man/regrid.Rd rename to base/utils/man/regrid.Rd diff --git a/utils/man/remote.copy.from.Rd b/base/utils/man/remote.copy.from.Rd similarity index 100% rename from utils/man/remote.copy.from.Rd rename to base/utils/man/remote.copy.from.Rd diff --git a/utils/man/remote.copy.to.Rd b/base/utils/man/remote.copy.to.Rd similarity index 100% rename from utils/man/remote.copy.to.Rd rename to base/utils/man/remote.copy.to.Rd diff --git a/utils/man/remote.copy.update.Rd b/base/utils/man/remote.copy.update.Rd similarity index 100% rename from utils/man/remote.copy.update.Rd rename to base/utils/man/remote.copy.update.Rd diff --git a/utils/man/remote.execute.R.Rd b/base/utils/man/remote.execute.R.Rd similarity index 100% rename from utils/man/remote.execute.R.Rd rename to base/utils/man/remote.execute.R.Rd diff --git a/utils/man/remote.execute.cmd.Rd b/base/utils/man/remote.execute.cmd.Rd similarity index 100% rename from utils/man/remote.execute.cmd.Rd rename to base/utils/man/remote.execute.cmd.Rd diff --git a/utils/man/rsync.Rd b/base/utils/man/rsync.Rd similarity index 100% rename from utils/man/rsync.Rd rename to base/utils/man/rsync.Rd diff --git a/utils/man/run.write.configs.Rd b/base/utils/man/run.write.configs.Rd similarity index 100% rename from utils/man/run.write.configs.Rd rename to base/utils/man/run.write.configs.Rd diff --git a/utils/man/sendmail.Rd b/base/utils/man/sendmail.Rd similarity index 100% rename from utils/man/sendmail.Rd rename to base/utils/man/sendmail.Rd diff --git a/utils/man/sensitivity.filename.Rd b/base/utils/man/sensitivity.filename.Rd similarity index 100% rename from utils/man/sensitivity.filename.Rd rename to base/utils/man/sensitivity.filename.Rd diff --git a/utils/man/ssh.Rd b/base/utils/man/ssh.Rd similarity index 100% rename from utils/man/ssh.Rd rename to base/utils/man/ssh.Rd diff --git a/utils/man/start.model.runs.Rd b/base/utils/man/start.model.runs.Rd similarity index 100% rename from utils/man/start.model.runs.Rd rename to base/utils/man/start.model.runs.Rd diff --git a/utils/man/status.check.Rd b/base/utils/man/status.check.Rd similarity index 100% rename from utils/man/status.check.Rd rename to base/utils/man/status.check.Rd diff --git a/utils/man/status.end.Rd b/base/utils/man/status.end.Rd similarity index 100% rename from utils/man/status.end.Rd rename to base/utils/man/status.end.Rd diff --git a/utils/man/status.skip.Rd b/base/utils/man/status.skip.Rd similarity index 100% rename from utils/man/status.skip.Rd rename to base/utils/man/status.skip.Rd diff --git a/utils/man/status.start.Rd b/base/utils/man/status.start.Rd similarity index 100% rename from utils/man/status.start.Rd rename to base/utils/man/status.start.Rd diff --git a/utils/man/summarize.result.Rd b/base/utils/man/summarize.result.Rd similarity index 100% rename from utils/man/summarize.result.Rd rename to base/utils/man/summarize.result.Rd diff --git a/utils/man/tabnum.Rd b/base/utils/man/tabnum.Rd similarity index 100% rename from utils/man/tabnum.Rd rename to base/utils/man/tabnum.Rd diff --git a/utils/man/temp.settings.Rd b/base/utils/man/temp.settings.Rd similarity index 100% rename from utils/man/temp.settings.Rd rename to base/utils/man/temp.settings.Rd diff --git a/utils/man/test.remote.Rd b/base/utils/man/test.remote.Rd similarity index 100% rename from utils/man/test.remote.Rd rename to base/utils/man/test.remote.Rd diff --git a/utils/man/theme_border.Rd b/base/utils/man/theme_border.Rd similarity index 100% rename from utils/man/theme_border.Rd rename to base/utils/man/theme_border.Rd diff --git a/utils/man/timezone_hour.Rd b/base/utils/man/timezone_hour.Rd similarity index 100% rename from utils/man/timezone_hour.Rd rename to base/utils/man/timezone_hour.Rd diff --git a/utils/man/to_ncdim.Rd b/base/utils/man/to_ncdim.Rd similarity index 100% rename from utils/man/to_ncdim.Rd rename to base/utils/man/to_ncdim.Rd diff --git a/utils/man/to_ncvar.Rd b/base/utils/man/to_ncvar.Rd similarity index 100% rename from utils/man/to_ncvar.Rd rename to base/utils/man/to_ncvar.Rd diff --git a/utils/man/trait.lookup.Rd b/base/utils/man/trait.lookup.Rd similarity index 100% rename from utils/man/trait.lookup.Rd rename to base/utils/man/trait.lookup.Rd diff --git a/utils/man/transformstats.Rd b/base/utils/man/transformstats.Rd similarity index 100% rename from utils/man/transformstats.Rd rename to base/utils/man/transformstats.Rd diff --git a/utils/man/tryl.Rd b/base/utils/man/tryl.Rd similarity index 100% rename from utils/man/tryl.Rd rename to base/utils/man/tryl.Rd diff --git a/utils/man/vecpaste.Rd b/base/utils/man/vecpaste.Rd similarity index 100% rename from utils/man/vecpaste.Rd rename to base/utils/man/vecpaste.Rd diff --git a/utils/man/write.ensemble.configs.Rd b/base/utils/man/write.ensemble.configs.Rd similarity index 100% rename from utils/man/write.ensemble.configs.Rd rename to base/utils/man/write.ensemble.configs.Rd diff --git a/utils/man/write.sa.configs.Rd b/base/utils/man/write.sa.configs.Rd similarity index 100% rename from utils/man/write.sa.configs.Rd rename to base/utils/man/write.sa.configs.Rd diff --git a/utils/man/zero.bounded.density.Rd b/base/utils/man/zero.bounded.density.Rd similarity index 100% rename from utils/man/zero.bounded.density.Rd rename to base/utils/man/zero.bounded.density.Rd diff --git a/utils/man/zero.truncate.Rd b/base/utils/man/zero.truncate.Rd similarity index 100% rename from utils/man/zero.truncate.Rd rename to base/utils/man/zero.truncate.Rd diff --git a/utils/scripts/metutils.R b/base/utils/scripts/metutils.R similarity index 100% rename from utils/scripts/metutils.R rename to base/utils/scripts/metutils.R diff --git a/utils/scripts/time.constants.R b/base/utils/scripts/time.constants.R similarity index 100% rename from utils/scripts/time.constants.R rename to base/utils/scripts/time.constants.R diff --git a/utils/tests/testthat.R b/base/utils/tests/testthat.R similarity index 100% rename from utils/tests/testthat.R rename to base/utils/tests/testthat.R diff --git a/utils/tests/testthat/test.SafeList.class.R b/base/utils/tests/testthat/test.SafeList.class.R similarity index 100% rename from utils/tests/testthat/test.SafeList.class.R rename to base/utils/tests/testthat/test.SafeList.class.R diff --git a/utils/tests/testthat/test.distn.stats.R b/base/utils/tests/testthat/test.distn.stats.R similarity index 100% rename from utils/tests/testthat/test.distn.stats.R rename to base/utils/tests/testthat/test.distn.stats.R diff --git a/utils/tests/testthat/test.localhost.R b/base/utils/tests/testthat/test.localhost.R similarity index 100% rename from utils/tests/testthat/test.localhost.R rename to base/utils/tests/testthat/test.localhost.R diff --git a/utils/tests/testthat/test.logger.R b/base/utils/tests/testthat/test.logger.R similarity index 100% rename from utils/tests/testthat/test.logger.R rename to base/utils/tests/testthat/test.logger.R diff --git a/utils/tests/testthat/test.plots.R b/base/utils/tests/testthat/test.plots.R similarity index 100% rename from utils/tests/testthat/test.plots.R rename to base/utils/tests/testthat/test.plots.R diff --git a/utils/tests/testthat/test.trait.dictionary.R b/base/utils/tests/testthat/test.trait.dictionary.R similarity index 100% rename from utils/tests/testthat/test.trait.dictionary.R rename to base/utils/tests/testthat/test.trait.dictionary.R diff --git a/utils/tests/testthat/test.utils.R b/base/utils/tests/testthat/test.utils.R similarity index 100% rename from utils/tests/testthat/test.utils.R rename to base/utils/tests/testthat/test.utils.R diff --git a/visualization/DESCRIPTION b/base/visualization/DESCRIPTION similarity index 100% rename from visualization/DESCRIPTION rename to base/visualization/DESCRIPTION diff --git a/visualization/LICENSE b/base/visualization/LICENSE similarity index 100% rename from visualization/LICENSE rename to base/visualization/LICENSE diff --git a/visualization/NAMESPACE b/base/visualization/NAMESPACE similarity index 100% rename from visualization/NAMESPACE rename to base/visualization/NAMESPACE diff --git a/visualization/R/add_icon.R b/base/visualization/R/add_icon.R similarity index 100% rename from visualization/R/add_icon.R rename to base/visualization/R/add_icon.R diff --git a/visualization/R/ciEnvelope.R b/base/visualization/R/ciEnvelope.R similarity index 100% rename from visualization/R/ciEnvelope.R rename to base/visualization/R/ciEnvelope.R diff --git a/visualization/R/map.output.R b/base/visualization/R/map.output.R similarity index 100% rename from visualization/R/map.output.R rename to base/visualization/R/map.output.R diff --git a/visualization/R/plot.netcdf.R b/base/visualization/R/plot.netcdf.R similarity index 100% rename from visualization/R/plot.netcdf.R rename to base/visualization/R/plot.netcdf.R diff --git a/visualization/R/points2county.R b/base/visualization/R/points2county.R similarity index 100% rename from visualization/R/points2county.R rename to base/visualization/R/points2county.R diff --git a/visualization/R/visually.weighted.watercolor.plots.R b/base/visualization/R/visually.weighted.watercolor.plots.R similarity index 100% rename from visualization/R/visually.weighted.watercolor.plots.R rename to base/visualization/R/visually.weighted.watercolor.plots.R diff --git a/visualization/R/worldmap.R b/base/visualization/R/worldmap.R similarity index 100% rename from visualization/R/worldmap.R rename to base/visualization/R/worldmap.R diff --git a/visualization/data/counties.RData b/base/visualization/data/counties.RData similarity index 100% rename from visualization/data/counties.RData rename to base/visualization/data/counties.RData diff --git a/visualization/data/yielddf.RData b/base/visualization/data/yielddf.RData similarity index 100% rename from visualization/data/yielddf.RData rename to base/visualization/data/yielddf.RData diff --git a/visualization/inst/extdata/miscanthusyield.csv b/base/visualization/inst/extdata/miscanthusyield.csv similarity index 100% rename from visualization/inst/extdata/miscanthusyield.csv rename to base/visualization/inst/extdata/miscanthusyield.csv diff --git a/visualization/inst/favicon.png b/base/visualization/inst/favicon.png similarity index 100% rename from visualization/inst/favicon.png rename to base/visualization/inst/favicon.png diff --git a/visualization/man/add_icon.Rd b/base/visualization/man/add_icon.Rd similarity index 100% rename from visualization/man/add_icon.Rd rename to base/visualization/man/add_icon.Rd diff --git a/visualization/man/ciEnvelope.Rd b/base/visualization/man/ciEnvelope.Rd similarity index 100% rename from visualization/man/ciEnvelope.Rd rename to base/visualization/man/ciEnvelope.Rd diff --git a/visualization/man/map.output.Rd b/base/visualization/man/map.output.Rd similarity index 100% rename from visualization/man/map.output.Rd rename to base/visualization/man/map.output.Rd diff --git a/visualization/man/pecan.worldmap.Rd b/base/visualization/man/pecan.worldmap.Rd similarity index 100% rename from visualization/man/pecan.worldmap.Rd rename to base/visualization/man/pecan.worldmap.Rd diff --git a/visualization/man/plot.hdf5.Rd b/base/visualization/man/plot.hdf5.Rd similarity index 100% rename from visualization/man/plot.hdf5.Rd rename to base/visualization/man/plot.hdf5.Rd diff --git a/visualization/man/points2county.Rd b/base/visualization/man/points2county.Rd similarity index 100% rename from visualization/man/points2county.Rd rename to base/visualization/man/points2county.Rd diff --git a/visualization/man/vwReg.Rd b/base/visualization/man/vwReg.Rd similarity index 100% rename from visualization/man/vwReg.Rd rename to base/visualization/man/vwReg.Rd diff --git a/visualization/tests/testthat.R b/base/visualization/tests/testthat.R similarity index 100% rename from visualization/tests/testthat.R rename to base/visualization/tests/testthat.R diff --git a/visualization/tests/testthat/test.pecan.worldmap.R b/base/visualization/tests/testthat/test.pecan.worldmap.R similarity index 100% rename from visualization/tests/testthat/test.pecan.worldmap.R rename to base/visualization/tests/testthat/test.pecan.worldmap.R diff --git a/visualization/vignettes/usmap.Rmd b/base/visualization/vignettes/usmap.Rmd similarity index 100% rename from visualization/vignettes/usmap.Rmd rename to base/visualization/vignettes/usmap.Rmd diff --git a/utils/modellauncher/Makefile b/utils/modellauncher/Makefile deleted file mode 100644 index 4a7dceef20b..00000000000 --- a/utils/modellauncher/Makefile +++ /dev/null @@ -1,3 +0,0 @@ -CC=mpicc - -all: modellauncher diff --git a/utils/modellauncher/modellauncher.c b/utils/modellauncher/modellauncher.c deleted file mode 100644 index 28736c2ab6f..00000000000 --- a/utils/modellauncher/modellauncher.c +++ /dev/null @@ -1,103 +0,0 @@ -#include -#include -#include -#include - -/* Actual processing of the file */ -int process(int rank, int size, char *filename) { - FILE *fp; - char command[1024]; - char line[1024]; - char execute[2048]; - int lineno; - int exitcode = 0; - - /* open configuration file */ - fp=fopen(filename, "r"); - if (fp == NULL) { - if (rank == 0) { - printf("File '%s' not found.\n", filename); - } - return; - } - - /* first line is command to execute */ - fgets(command, 1024, fp); - command[strlen(command) - 1] = '\0'; - - /* read configuration file and execute */ - printf("Executing %s of every %dth line starting with line %d of %s\n", command, size, rank+1, filename); - lineno = 0; - while(fgets(line, 1024, fp)) { - if (lineno % size == rank) { - line[strlen(line) - 1] = '\0'; - if (chdir(line) == 0) { - sprintf(execute, "%s 2>stderr.txt >stdout.txt", command); - - printf("[%d] cwd=%s exec=%s\n", rank, line, execute); - int ret = system(execute); - if (ret != 0) { - printf("[%d] returned %d as exit status.\n", rank, ret); - exitcode = ret; - } - } else { - printf("[%d] could not change directory to %s.\n", rank, line); - exitcode = -1; - } - } - lineno++; - } - - /* all done */ - fclose(fp); - - return exitcode; -} - -/* Main function */ -int main (int argc, char** argv) { - int rank, size; - int exitcode = 0; - - /* starts MPI */ - MPI_Init (&argc, &argv); - - /* get current process id */ - MPI_Comm_rank (MPI_COMM_WORLD, &rank); - - /* get number of processes */ - MPI_Comm_size (MPI_COMM_WORLD, &size); - - /* check right number of arguments */ - if (argc == 2) { - exitcode = process(rank, size, argv[1]); - } else if (rank == 0) { - printf("Usage %s configfile\n", argv[0]); - exitcode = -1; - } - - /* Send and wait for other exitcodes */ - if (rank == 0) { - int counter = 1; - int buffer[1]; - while (counter < size) { - MPI_Recv(buffer, 1, MPI_INT, MPI_ANY_SOURCE, 123, MPI_COMM_WORLD, MPI_STATUS_IGNORE); - if (buffer[0] != 0) { - exitcode = buffer[0]; - } - counter++; - } - } else { - int buffer[1]; - buffer[0] = exitcode; - MPI_Send(buffer, 1, MPI_INT, 0, 123, MPI_COMM_WORLD); - } - - /* All done */ - MPI_Finalize(); - - if (rank == 0 && exitcode != 0) { - printf("ERROR IN MODEL RUN\n"); - } - return exitcode; -} diff --git a/visualization/vignettes/figure/unnamed-chunk-1.png b/visualization/vignettes/figure/unnamed-chunk-1.png deleted file mode 100644 index 6a87c04ba8aa702d2d48c9223c8faf7f0e9133a0..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 10036 zcmeIYc{r5s7e9`{*p;;+`xaS>NXAG)C4{09icndGguxhVgqWnro)l%5oiR)HEMs4? z%wykY#y-s8=l%KP_q(p&|KI<<=eq7cp7VOn>pth)=X&n@dhQc*&&-&c;~WPA0|WQ% zTQ@Bk7#OMl4K~n;CUKY7l!1Zi+P%B?4No2!85xGI{v>gwuR zT3T1HUe(stzIN@Jj*bol0)axIdU|@-uV2^K*EcXQFg7;6efzelsi~QnnYp>Sg@uKs zrKOdX)q@8QtgWqWY-}DqdSq*B`{c z)vH%-Zf+hP9xxcp+uPg6$LGzPH@?2Uetv#|fq_9mK?npQI5-%IM24Qo@o_{%L}X;- z+qZ9{qN1Xsqu;%I7ZVc`8yg!J7x(`C`}p{H6bkj})2HO*#v6FEM{;c$37{?DI3O-)TLEiJ9Bt!-^>?d|Oy9UXuF{_X7S?CR7Qup`w4-O7! zG#Z^wKRi45;1#mdC0N+^aaV9GdN-P5PYzT04#bAEqX=5#aj zDc+9~6EC^m37dM>FNXN!Hx$$#IJ>y|x%#_Quk6(Y`7H)lW9=q~hIDm>&wajS_l3rK zf9n>W^K-bcB8%#M4*Q=1=zAC7IhK?gKY+J){x9%(Y-pN9oXT_9MT#4A5a81c6s9AhvJ`&Oz_(!S4j21z3*YrK#Um{l? z{HlaXssG*>()z(CUz<_uj8k6M8>PM}Ad#lxWUo0bOOKJ+YlzTw&8bv zkg#Ye?8X8V_vJ#xMa%I&V)42&WEBLc=uL{aiqr=HKL~uhG8ME<7vGpCnv3@SR+1 zYhKZ%3RTX}f%7Og@Gx~*Sg$j&h$bwh>;3WRbj`(b@sSRs3|wuK0eO8>MF=wS#ku7) z))cgJ-S+Qi{&FMAI*Fel{nmEpK|6{WdmB%d6E6wjdISC|<3F+xQC6P!yZBS=6_4G9 z{Ei{p7BQ<1UL8@$hZ=nYoWVEcO5NxzTdyVCgdAOzT&A4#+7vgYCS13GPDm3#OOurX zbtde_5`VdMNkROghO2AzparfH8pOY^r-7Wu1)Hqe#@!h0ulzO!n4VWr4$*~YRc*R2u zhAX&|Tu0%NQ$wTd`yRo=M|W`qM>xwitK-prN1n`h=_fevzEvp7bMdJsSm{DR0Q-lC z{GV@mfgx@9?pZoZeo_QsV!s1F-tCgEILja84S0_knBv>K|5n!%=uAs*N^%n*SH07p z$}2CS*r1hjZB^ZNue(e$ht}TcMTvT0FY}Db03M&xu2eBt!TJooY`?@w#&$|uacO8q|61ktJ}l0u-q}Yd_F<~ip(@8-I$5{+XX)dm z!B66eOC}823Xd6|utS_9+0f2yLtF@|H`mQ>lChy3f7s2R%Xs zEgF5S7o6?dUOG1>GVFV#J;-5x*B%|E->ybt@^&2Zb|o^yb({}yDd)TT)~Sjrv|(1v zt*jf{noR3a0)7#D(KP|gd{VcI6jc^^o^x)0orvPC{%z#S5*H}NOP6PHC}l^u%vG{Y zUczrTuG`!ebdU^ub2u?QTr>W=@--uaRCYccPQr%=ToOF~wAaDwU*DdMxFjXV4@cbLlPj;-Y z|1tx)mtk@rrCUtKFTS^nh+qZWj>kW|aCXWU!!`tS$7}8sp7kG5oo?`_w#ZHQWK`n@ z)i4%*OBlL6U^Cy_2Jml83DhL*bbr3C;ZL4`58UGzWrkek5<^U8ZqmX^BRYKC@~TF| z%~M^4#kEg4y#*RAL$Xx8D87Onw!W;Gf?UJS4r%JONb(NNo(avPiJD};DlQf0BUs*A3F6XQ2hnj$S^9e@uPVe%5l8YWC*(drT|D=C% zG`G^J19P-F19)cJO(I)w`hAs?eJ{w&df16aHPM_iJSwadakKR8l-ws(aka@^M)5x; z47DzER+NVu=Im3)K)iX{fK|rz#A2^ap0fEN9Vh#u#oS&VCST!~c$+VAmhm$Q+>6ge zC0J9Xg%gz5;ZI+yQWEIEhF_eOf^2Xu_=c~Lh>P}5;GZ!?8*cQeq+;^%SBwZ`Jognv z>e<)dSX#X}J;CHX7&T86q8EJIzWd>Z=6XW8-QWeC?<7%aLd+juMH`tv7ru%1f6ZCkw$9zXqDeeXL1pW`a0pEv&W2c(v%P0 z9|EZ+eIh1Jfu`-k26ZR~b6FI&A1%=q`*dKh^3a}vFdcYiY-(EKu3SibtYSi1I#LzB z)*nH86J4&N$rpDSOo@Q(gYe^tAZ206lrMwlT`#W;g0e$vBr6udc>7D{Oym&|J_ks2 z5i#?+q7&+xQUdaC3h7cH&EmG)2wbnDH^e(yuMKv;kKFyU72 zaV8M)sAePkpTAHP^s3_Wn1YvLgIc@KO-j^_=s4?Xq2Nno%mLU@sx3>=ng{cn3*qrQ zY!@ln5<@Hhjl4)rWAYos_u$$lHP@2^HTJxF>?m<&cf7w-%hKG_ZMoNp*9Qm&n3C-Vy6@z)0T~VU^Ov+592^e~PWYZ1=D-pV$pbW+ zhUQcRmNR3N!mXk$rQ9}UZz?U}zvqeRNthfdE@XxC9$ib`S25#V1r|4nNCAr5r2vWU zxlHvt|F-pGI65uU6QeH)V=9Dr<8b-+l$PpBzOvuj1%+RDP%_{1`YEJRg^8?nAbR)n zBLNF-9(Wc(s7Mro3ad?nl-v%En)3V`xY+A89jD`SQw&Q>7^ zdW40v<1q`dcwTuuK6?LQy*1l4IYL2S!QaQT0g`5h+F_-DzQw8%x!0xQK?_*%yCI`v zDJc106{$lQ_>-*D9}neQY&KroE1YkGD(moeT73JXTOM%dan|UqpCH8MRl|9)?2Wh_ z?lQY}oa^hFR=!K2g!+TdEZtN@wcGRe#!Og55K7EF&Lb-o&WdSB%8T`rreJ#50Dmv= zaT#7KxKfhwS{~;cGw5F-c*a=U+{t-BU!TY_h1WW}-&}11SP63*Tb`|6JVgm};07A* zBIOZie<^c4q{3bwU~^qer1lHw?qv|u_eapdzpNDrJ~xJglCD=_MoI6F;hUo9!VE1D zh=u0!8XeU$JX!6tF!8QKcYIUIT*EWD?3TfI4V?FkA};pp`cPWW4}-JDl@fAqab`?> z@ge0s-P{mi{1MJ;U&5}dt_>dtWA3y!@nqiR1S%#@ixhPbprQzFl*@qq>{k@4Lut;H zlsFse?LT?+4`^`qFzx)D7V?Ru<*{#2J97d3+NN|{%`|jXpNm>0lSJy9O#|&M#EFt{qtIjhG zm!|fVlIuv>iOAb3riNTC!XMG?`Y5$(oZm%Ix3fwx?nH zO|>WxHaVxNqc@I+v6Jf_0eb26)?QV=XFsEh@y%(_7^VhTDqo2~|@D%u&}H1wr`x~-rv2hjc>h`>TI>)Y1{909lCVU3X>ia zu|0(V_q8_{ih^1bdm(! zl%D&kn-WSCeYGW4ds}>7pVFOp_hkR$=8f#e!(de;bi=CRAo=|D3E+`a?#8_Ury#3% z-kt^1=o?%)EsejX1yQ7_6b2|2?#2XrcxXS*6?B;)KGsW4Jd7w0Ne_>HEW1D&(%@vl z%HiLCkPC3EMkT~2dl^~|qvW%_39O)Iz;-j~HBp2U{rP8|BQkLF(^RSM$G$*V>F0Y#)2vKt2LSZcX*RXJ^im?Eck^ z46RyDEB|W@$fTksA1v*#Y{oHSq1$qyT1#I+eVM=`9c0L+?@j16U6%qWs!Jg08*Wx6 z@kl#hcr4kXl0Eh7irVHSU#adt)zcGP^wV$Hs8xx3{NQKz@;Dkj9;x*t|MH0=R#c*J zKK~xPIn9cEH6x2zW(CgBv^iLPh`vRDkWy3yZKDxEk66V^Z+CC>; zggA9yoN77ON@AS)E^k&R9!=K=M)b4(Y-v;fE&y@EnH&D93(sWSc#v8Ft!JJjR7Rm% zUz>61&gz__bM%U^5gMv9Y@hvp3}t#Xdr%ER==fT|jgoQWo|O9;xP%uJ)<)A6-lr2v zEZEXfkcK-8IQ!x2A*U63pN^Ulvjdni{~J1Zv39LBaG&(dAk#;dlEkOFF$to-YOfG` zuDL1K(gS|}eV!p)zQJg7{WvXU#}Hep_D_lh_Ux-&_wUc)M02!3f@$cG1v1IQ@BVIH zW~b(rI}+I`i0i|3do+bNHlN>_a>gvOW?dsjClYQAJ&T|fZKUe7W{Rat z&+Y$WgOFn`weJ0C5HncPRipeX59BvPijo$&p-7|p1UaZEvsn8qjYyx)3fxpf7mnn- zX?Mikf22my*o~VK{)->!tIKD$pKIWy8YZFeO=-K_f``t!Gn=IXu4lgrdb z4-l9>Eha+pnT@x{lVuSO`sc%3VQUp#-b#taZaZYJJ$XY)*YUqfngmrUz)9iB^U-lM z;cv^1{_8iM0 z7bcy(2k-OTVKyF@}Nw6#~sIo+xxC&upwG(xvlQ0EM?&H&ubhNKQB@i zF8aMRd|J&MlYn2;z4XIK--`(GAO=<(`AR*jzvA%KT|GrapMW=KtovTU>fjS1mOe*9tW`vF`FC@7tH7bk%39?;^ zk}WN_Q==ZV|HU4JJ8JbbM8rmh5k-CIEVsGf;_&!yRf&E6%(hBVL&ELL)i<;*D&66- zCaG|VUzrC^W4w0%1^Bh8&S&O<$Q`O$pbvGzcXflAs|{FI9{dtX&Kyr!@8C3-g!4Ck zY>nVu;x!&GWyj|(%#UASaQHdp&qQVv53kzz$Bac7v6(kYIixUk!YjDRG8G zMRdAuLftrGP(sLAy3C1dl==+~NB)|ba}0A4<*pEfB(XHuM-v=jTV3-T4En5j#cwM10a#OfGubHX#CdPmtVhrsk>^`N_zJ$}8+oBoqNUSuTguO9#ZVUS z-ns}^r-D_r%Mk$&-R*DxiIFY>hq*@e#GZ;XaFwP^4RqFJe>+TGss+;P#_|CVjg@4J ze-*z`=GRL=p~mEdFoJz#xwZ{uD^crh3lm&1$GC2<$Uue3!8;mbmgY@5WxyCJK)=Zj zz3b|}(ekqHTS|w#-(v=1s<6aO0#^oYS54coyDqm_9uM7BOn=FT_}X(8;cZl18>?zr zy3w6I&i8F4dxZ^eGdj+f6{{hqXvdX+akM~KzsX2zfKYrjUIzS}(x$GfuwkCiY#!jw z+<{9Zcxl5m7kY#U+NO@EUhR>MOdqwV5rO*|XTjvQTifAnRU16`Zj|C47vgn&3|~-f z0xuG}o#_K(qJE&Cg=;DnFe7Ih?60ok1g9Ohl!N2erMQk{fEWbEMJ$!VT42dS+GRgN zWag9r*h9Mi*9(QRrVJ-ZvI-rG1~4IQf5+V42X<)S9&cH~^^=N(Or)%JfeI)3$j zp}Z-&udeyOQla>W=!Wb(1P9neHcUNHJo!<@8_0j&SS2{$?Np%migr1H9h3TUFzUx% z(i#)-^5(Otr<)g=5$$$+3Q$F%GgK$}*ZD5Y#Fg!dc$h0U!^zh_4+PPbNsmx%j!-LE zTxHgaBn!km8SDZwU058rMzz;4f@Hk(uIUZz2bkK$drUBCO0ijT`>$k%qwjNeDeU3K zHW%d`>cCEYflWGq=8)WFS_Z;(zGnrw=Wk8wWFW3Y&MnXTfQ+6rKl8os(#k$Xs_@R# z4C7a3rF(AX`jMo?<^C*7npHL}=G_!?zxtQ6sa6S|7d9cUAi*WV-{-pdun;C?_+?!# z6R6}xRI!mvK&b2KnN>sqK>6)h{V%6tv1jHAFguzgP#m6pgZ~4s=mAdJ&69j-p-5nf z#X&iY7K;~u+}DOOlf!YkhzW0>c75pKSJu`W|Ck!JG>ML>aiN$6MQGh8MSbN+4eIE!EtR;x!3bIR^h-qu()=s((qB*n85f^-emzTU~ZtQeK;wfmfE0Rg~2 zoTJ{@Tb>q16!@t`jkqF&4$-lI)SrtBSjbN`J(CbOAH?8LbF+c`D+0|8jH_p;#J`SV zBIMP5f3_p1xTxg0c17MHAW5tCm$>Z{K{d*ew=PIMB}*}e<0H$I4B-8E9G#){o-P*( zOHn+NF&Si4&dJa@9M9sFZ$aVzdAF`I>j8xk(x|LrJpfQ>elKkuXD19FTwy>&ti8nd z&tBm`Dt@j@QD?TMh@mgk`YzixG@7(!#g4gA-oqMeY`9T@chlIUeT4w4=1JS|I-N~f zN@j}MX#Lh)+f?qJ0{!mF4t1tY!#%x(&7LZShzGH}8*J3UC3sz{-rh z6t9)>h$!8KVNb3$m^R_ajLiP$Xqm}LRR;1h(r$CZUSt$2Z54i@C%AEq{;&ZaUJRq} zhr(WXcDu`l)G4qD8RWXL?M2L&i0U>6ttt7f6ydafd@35ddsP=Gw1NyV;Ta2FyKs$X z2~)pu0IPgdtBE-F8m0=BjF|#ib_PP>KDC=gl>U;$j7z7KkzSUho1B4bJ_;`$t5}t9 zIK7+Y#1g{v88@!@L2uHdtVf(B1i?a)tF>PE)U~1ca|_(?-Yg(kP7>gh<5fRJ7L3!L zQ{jTt+gQ!ceDc5kkqOEPJjzI38PqzR_NHRDFNQJuV|4HS?YbZ`kMg7N+of7tjy zgS9X7lp-}rfr*^C!ap9w|A3_ODrECASe746j?0$pb6XRR{EbXb_xi{=#T|Qf-!#(3 zwxT>k9vf#Q0KXyLYMp%~H2Ouaz{`bw<{dN4rC=tVjgI!VO$AoZc0M$S(CyC9y~2kF zC#5fH3eY>MG$>cakGQlXIT1IJ7)<%8mef)=YZVR0$MJd6IN^ER-gtn z)84t(F|z0-37{Wdfd5KMY6#D^P1{(qM30rjuBz!)VtUqYKcTnZp%F;cJKXUj z`rEzm-P;v$4;L)ko;BaE(heE9dCiHU>TyI42-yS*r}|WIT2$(i|J2@))^U5lo0JClG;B2qtJ>3P!c}KkHSrt|Um;EKs)j#$dX%XsOxa85F5Qn2gKxu5 z`s_^C9J+6XiN8uS&ZdZ$ZI_H_b-TiFxeop|G~pA|Czccw3-32gLiFsZe;O&+<&_i5 zzF6KT)atlyX@{3-4H(W8BrV>yR~SR$J!&rY5~_)@rpmHl1$@JfC$%)XkL{_Y>r4nv zr6XE#>F818!HCw8Daa%nv7nm*YoI*vUmFrXa)ofOu_;Y_40njF$6?9U#bJ8O8z)u~ zC_-@g6}nRQ{0JS_Xc}P>@@BSz=-ur^8pSq@WrMW#1#7*abaZ(GnzHs1AfL|ggXiEg$G`1Z)&@^ zlqfVff;@%Aw`DgjovpEZg&ev;M=DIb$Y~!#pc5B>8c$JSSv?YT* z(mw;d>SJ2?aeSNKdJZ65tob}h;AOkta^PaL|INup&pKl8L`X4>ExJ;v2lV>3E7wuK zDT*9hUn4RF$A^Wi$&S=IUu!PC8t2&feT%^%qixMD1b`lVBdy!R0@Fap(KYr4#`Okt z4i@b5&#q-bWBLEEjTZj-BDR#{gK*VT@EUN@J&K9-X}S|}`&Nb03TZGrg#KB)J`$J| ztG$6&ePl>+2(YHr==~2NuAXBe@8SeGkbR1ux5W@4gOk5lj`>F>DP5deh;KOtUT?!4 zsyQ&3N-HPslM!VbfT|t^m!D0=eLnTGjq@u~oPmM)(|^4HCmg}AG8@iY?5ziSk#TuZyTPC z<`?ZpDo_OrluzcH5fQcJ6)y%(QG36g_}9ZTe$8J;YJ)qWIGWf0iykvnfd2787Vp2d zl_2T=wE2>|Z`cqDRM|qdskRlG^oHkKaa)wZng|P4Ob}1|;1ME&RMM*!(_8vrgfG?q z@i8lm{JvR>`+adVDvIZ&0R3@G>_N{hdM59m(LgF2o_6wHTwsi~0OJ1i`9!L9S&SU+rNsN=sYTtL1)3ne|G|U(dJhY% z5}$ebff^%E8`U&gvSn5uzQ_wW^tO=PX9hxjacB>lVF$(25nYFPm22zTp;KIKr zPsi}4zxW?=GS z!R+l5H`Ag8=;wa?e`$J;cPqk}FLK!rN&nv_mjCnZJ4fOr{{DmbXU8XvOAHLR4b5(r J+;|%P{{V|%@_+yU From 75ddf6a7dc736109158d8057b64d9f78240d4fa3 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Sat, 5 Aug 2017 21:22:46 -0400 Subject: [PATCH 334/771] Move logger functions into own package --- CHANGELOG.md | 1 + base/logger/DESCRIPTION | 10 ++++++++++ base/logger/NAMESPACE | 13 +++++++++++++ base/{utils => logger}/R/logger.R | 0 base/{utils => logger}/man/logger.debug.Rd | 0 base/{utils => logger}/man/logger.error.Rd | 0 base/{utils => logger}/man/logger.getLevel.Rd | 0 base/{utils => logger}/man/logger.getLevelNumber.Rd | 0 base/{utils => logger}/man/logger.info.Rd | 0 base/{utils => logger}/man/logger.message.Rd | 0 base/{utils => logger}/man/logger.setLevel.Rd | 0 base/{utils => logger}/man/logger.setOutputFile.Rd | 0 .../{utils => logger}/man/logger.setQuitOnSevere.Rd | 0 base/{utils => logger}/man/logger.setUseConsole.Rd | 0 base/{utils => logger}/man/logger.setWidth.Rd | 0 base/{utils => logger}/man/logger.severe.Rd | 0 base/{utils => logger}/man/logger.warn.Rd | 0 base/{utils => logger}/tests/testthat/test.logger.R | 0 base/utils/NAMESPACE | 11 ----------- 19 files changed, 24 insertions(+), 11 deletions(-) create mode 100644 base/logger/DESCRIPTION create mode 100644 base/logger/NAMESPACE rename base/{utils => logger}/R/logger.R (100%) rename base/{utils => logger}/man/logger.debug.Rd (100%) rename base/{utils => logger}/man/logger.error.Rd (100%) rename base/{utils => logger}/man/logger.getLevel.Rd (100%) rename base/{utils => logger}/man/logger.getLevelNumber.Rd (100%) rename base/{utils => logger}/man/logger.info.Rd (100%) rename base/{utils => logger}/man/logger.message.Rd (100%) rename base/{utils => logger}/man/logger.setLevel.Rd (100%) rename base/{utils => logger}/man/logger.setOutputFile.Rd (100%) rename base/{utils => logger}/man/logger.setQuitOnSevere.Rd (100%) rename base/{utils => logger}/man/logger.setUseConsole.Rd (100%) rename base/{utils => logger}/man/logger.setWidth.Rd (100%) rename base/{utils => logger}/man/logger.severe.Rd (100%) rename base/{utils => logger}/man/logger.warn.Rd (100%) rename base/{utils => logger}/tests/testthat/test.logger.R (100%) diff --git a/CHANGELOG.md b/CHANGELOG.md index a85ea601f66..522c047f3c2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,6 +19,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha ### Changed - Clean up directory structure: * Move `base` packages (`utils`, `settings`, `db`, `visualizaton`) to a `base` directory, for consistency with `modules` and `models` + * Move `logger.*` functions out of the `PEcAn.utils` package and into the `pecan.logger` package ## [1.5.10] - Prerelease ### Added diff --git a/base/logger/DESCRIPTION b/base/logger/DESCRIPTION new file mode 100644 index 00000000000..0322035dead --- /dev/null +++ b/base/logger/DESCRIPTION @@ -0,0 +1,10 @@ +Package: pecan.logger +Title: Logger functions for PEcAn +Version: 0.0.0.9000 +Authors: Rob Kooper, Alexey Shiklomanov +Description: Special logger functions for tracking execution status and the environment. +Depends: R (>= 3.4.1) +License: FreeBSD + file LICENSE +Encoding: UTF-8 +LazyData: true +RoxygenNote: 6.0.1 diff --git a/base/logger/NAMESPACE b/base/logger/NAMESPACE new file mode 100644 index 00000000000..eec7c3cc8ef --- /dev/null +++ b/base/logger/NAMESPACE @@ -0,0 +1,13 @@ +# Generated by roxygen2: do not edit by hand + +export(logger.debug) +export(logger.error) +export(logger.getLevel) +export(logger.info) +export(logger.setLevel) +export(logger.setOutputFile) +export(logger.setQuitOnSevere) +export(logger.setUseConsole) +export(logger.setWidth) +export(logger.severe) +export(logger.warn) diff --git a/base/utils/R/logger.R b/base/logger/R/logger.R similarity index 100% rename from base/utils/R/logger.R rename to base/logger/R/logger.R diff --git a/base/utils/man/logger.debug.Rd b/base/logger/man/logger.debug.Rd similarity index 100% rename from base/utils/man/logger.debug.Rd rename to base/logger/man/logger.debug.Rd diff --git a/base/utils/man/logger.error.Rd b/base/logger/man/logger.error.Rd similarity index 100% rename from base/utils/man/logger.error.Rd rename to base/logger/man/logger.error.Rd diff --git a/base/utils/man/logger.getLevel.Rd b/base/logger/man/logger.getLevel.Rd similarity index 100% rename from base/utils/man/logger.getLevel.Rd rename to base/logger/man/logger.getLevel.Rd diff --git a/base/utils/man/logger.getLevelNumber.Rd b/base/logger/man/logger.getLevelNumber.Rd similarity index 100% rename from base/utils/man/logger.getLevelNumber.Rd rename to base/logger/man/logger.getLevelNumber.Rd diff --git a/base/utils/man/logger.info.Rd b/base/logger/man/logger.info.Rd similarity index 100% rename from base/utils/man/logger.info.Rd rename to base/logger/man/logger.info.Rd diff --git a/base/utils/man/logger.message.Rd b/base/logger/man/logger.message.Rd similarity index 100% rename from base/utils/man/logger.message.Rd rename to base/logger/man/logger.message.Rd diff --git a/base/utils/man/logger.setLevel.Rd b/base/logger/man/logger.setLevel.Rd similarity index 100% rename from base/utils/man/logger.setLevel.Rd rename to base/logger/man/logger.setLevel.Rd diff --git a/base/utils/man/logger.setOutputFile.Rd b/base/logger/man/logger.setOutputFile.Rd similarity index 100% rename from base/utils/man/logger.setOutputFile.Rd rename to base/logger/man/logger.setOutputFile.Rd diff --git a/base/utils/man/logger.setQuitOnSevere.Rd b/base/logger/man/logger.setQuitOnSevere.Rd similarity index 100% rename from base/utils/man/logger.setQuitOnSevere.Rd rename to base/logger/man/logger.setQuitOnSevere.Rd diff --git a/base/utils/man/logger.setUseConsole.Rd b/base/logger/man/logger.setUseConsole.Rd similarity index 100% rename from base/utils/man/logger.setUseConsole.Rd rename to base/logger/man/logger.setUseConsole.Rd diff --git a/base/utils/man/logger.setWidth.Rd b/base/logger/man/logger.setWidth.Rd similarity index 100% rename from base/utils/man/logger.setWidth.Rd rename to base/logger/man/logger.setWidth.Rd diff --git a/base/utils/man/logger.severe.Rd b/base/logger/man/logger.severe.Rd similarity index 100% rename from base/utils/man/logger.severe.Rd rename to base/logger/man/logger.severe.Rd diff --git a/base/utils/man/logger.warn.Rd b/base/logger/man/logger.warn.Rd similarity index 100% rename from base/utils/man/logger.warn.Rd rename to base/logger/man/logger.warn.Rd diff --git a/base/utils/tests/testthat/test.logger.R b/base/logger/tests/testthat/test.logger.R similarity index 100% rename from base/utils/tests/testthat/test.logger.R rename to base/logger/tests/testthat/test.logger.R diff --git a/base/utils/NAMESPACE b/base/utils/NAMESPACE index 4ec10624920..b0c5f8edb2d 100644 --- a/base/utils/NAMESPACE +++ b/base/utils/NAMESPACE @@ -38,17 +38,6 @@ export(left.pad.zeros) export(listToArgString) export(listToXml) export(load.modelpkg) -export(logger.debug) -export(logger.error) -export(logger.getLevel) -export(logger.info) -export(logger.setLevel) -export(logger.setOutputFile) -export(logger.setQuitOnSevere) -export(logger.setUseConsole) -export(logger.setWidth) -export(logger.severe) -export(logger.warn) export(misc.are.convertible) export(misc.convert) export(model2netcdf) From 58d26c4febed5eae1addacdc59f87ff126c9cb7e Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Sat, 5 Aug 2017 21:26:13 -0400 Subject: [PATCH 335/771] Remove miscellaneous files in root directory --- TODO | 3 --- cookiejar.txt | 2 -- pecan.iml | 10 ---------- 3 files changed, 15 deletions(-) delete mode 100644 TODO delete mode 100644 cookiejar.txt delete mode 100644 pecan.iml diff --git a/TODO b/TODO deleted file mode 100644 index e62b5b332a7..00000000000 --- a/TODO +++ /dev/null @@ -1,3 +0,0 @@ -- check if we need only JAGS2.2.0 -- check all DESCRIPTION for packages -- check over calculations in the code to confirm the calculations are correct. E.g. the conversion from m2 / kg DM to m2 / kg C for SLA. Some SLA seems quite low. Also double check calculations of SLA from MA. Mean does not match posterior. Also the arrhenius scaling. diff --git a/cookiejar.txt b/cookiejar.txt deleted file mode 100644 index 06cf4c3106c..00000000000 --- a/cookiejar.txt +++ /dev/null @@ -1,2 +0,0 @@ -# This file was generated by libcurl! Edit at your own risk. - diff --git a/pecan.iml b/pecan.iml deleted file mode 100644 index 284429d9481..00000000000 --- a/pecan.iml +++ /dev/null @@ -1,10 +0,0 @@ - - - - - - - - - - From 79ef207f9a6451e8990deb57c81b570a813d4245 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Sat, 5 Aug 2017 21:42:03 -0400 Subject: [PATCH 336/771] Change PEcAn.utils calls to PEcAn.logger Also, add `PEcAn.utils::logger.*` functions, but with a deprecation warning to ease the transition. --- base/db/R/get.trait.data.R | 44 ++--- base/db/R/query.format.vars.R | 8 +- base/db/R/utils.R | 34 ++-- base/logger/DESCRIPTION | 2 +- base/settings/R/check.all.settings.R | 2 +- base/settings/R/papply.R | 6 +- base/utils/R/do_conversions.R | 8 +- base/utils/R/logger.R | 83 ++++++++++ base/utils/R/read.output.R | 2 +- base/utils/R/start.model.runs.R | 6 +- base/utils/R/to_nc.R | 10 +- models/dalec/R/met2model.DALEC.R | 2 +- models/dalec/R/write.configs.dalec.R | 155 ++++++++++++++---- models/ed/R/SDA.helpers.ED2.R | 6 +- models/ed/R/ed2in_set_value.R | 4 +- models/ed/R/read_restart.ED2.R | 4 +- models/ed/R/veg2model.ED2.R | 2 +- models/ed/R/write.configs.ed.R | 24 +-- models/ed/R/write_restart.ED2.R | 4 +- models/fates/R/model2netcdf.FATES.R | 6 +- models/fates/R/write.configs.FATES.R | 24 +-- models/jules/R/write.config.JULES.R | 4 +- models/sipnet/R/met2model.SIPNET.R | 20 +-- models/sipnet/R/write.configs.SIPNET.R | 38 +++-- modules/assim.batch/R/helpers.R | 6 +- modules/benchmark/R/calc_benchmark.R | 4 +- modules/benchmark/R/create_BRR.R | 2 +- modules/benchmark/R/define_benchmark.R | 8 +- modules/benchmark/R/load_data.R | 8 +- modules/benchmark/R/load_netcdf.R | 2 +- modules/benchmark/R/metric_AME.R | 2 +- modules/benchmark/R/metric_Frechet.R | 2 +- modules/benchmark/R/metric_MAE.R | 2 +- modules/benchmark/R/metric_MSE.R | 2 +- modules/benchmark/R/metric_PPMC.R | 2 +- modules/benchmark/R/metric_R2.R | 2 +- modules/benchmark/R/metric_RAE.R | 2 +- modules/benchmark/R/metric_RMSE.R | 2 +- modules/benchmark/R/metric_cor.R | 2 +- modules/benchmark/R/metric_lmDiag_plot.R | 2 +- modules/benchmark/R/metric_residual_plot.R | 2 +- modules/benchmark/R/metric_scatter_plot.R | 2 +- modules/benchmark/R/metric_timeseries_plot.R | 4 +- modules/benchmark/R/read_settings_BRR.R | 2 +- .../R/download.CRUNCEP_Global.R | 6 +- .../data.atmosphere/R/download.Fluxnet2015.R | 18 +- .../R/download.FluxnetLaThuile.R | 2 +- modules/data.atmosphere/R/download.GLDAS.R | 2 +- modules/data.atmosphere/R/download.NARR.R | 6 +- modules/data.atmosphere/R/download.NLDAS.R | 2 +- modules/data.atmosphere/R/extract.nc.module.R | 2 +- .../data.atmosphere/R/merge.met.variable.R | 6 +- modules/data.atmosphere/R/met.process.R | 8 +- modules/data.atmosphere/R/met2CF.FACE.R | 2 +- modules/data.atmosphere/R/met2CF.NARR.R | 4 +- modules/data.atmosphere/R/met2CF.csv.R | 62 +++---- modules/data.atmosphere/R/met2model.module.R | 2 +- modules/data.atmosphere/R/permute.nc.R | 2 +- modules/data.atmosphere/R/split_wind.R | 4 +- modules/data.land/R/extract_soil_nc.R | 6 +- modules/data.land/R/match_pft.R | 8 +- modules/data.land/R/match_species_id.R | 10 +- modules/data.land/R/partition_roots.R | 8 +- modules/data.land/R/pool_ic_list2netcdf.R | 4 +- modules/data.land/R/soil_process.R | 2 +- modules/data.land/R/soil_utils.R | 20 +-- modules/emulator/R/minimize.GP.R | 2 +- modules/rtm/R/helpers.R | 6 +- 68 files changed, 467 insertions(+), 285 deletions(-) create mode 100644 base/utils/R/logger.R diff --git a/base/db/R/get.trait.data.R b/base/db/R/get.trait.data.R index 590e1f9ef61..665bca9126c 100644 --- a/base/db/R/get.trait.data.R +++ b/base/db/R/get.trait.data.R @@ -57,7 +57,7 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, # Create directory if necessary if(!file.exists(pft$outdir) && !dir.create(pft$outdir, recursive=TRUE)) { - PEcAn.utils::logger.error(paste0("Couldn't create PFT output directory: ", pft$outdir)) + PEcAn.logger::logger.error(paste0("Couldn't create PFT output directory: ", pft$outdir)) } ## Remove old files. Clean up. @@ -71,7 +71,7 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, pftid <- db.query(paste0("SELECT pfts.id FROM pfts, modeltypes WHERE pfts.name='", pft$name, "' and pfts.modeltype_id=modeltypes.id and modeltypes.name='", modeltype, "'"), dbcon)[['id']] } if (is.null(pftid)) { - PEcAn.utils::logger.severe("Could not find pft, could not store file", filename) + PEcAn.logger::logger.severe("Could not find pft, could not store file", filename) return(NA) } @@ -104,35 +104,35 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, if (!any(is.na(ids))) { foundallfiles <- TRUE for(id in ids) { - PEcAn.utils::logger.info(files$file_path[[id]], files$file_name[[id]]) + PEcAn.logger::logger.info(files$file_path[[id]], files$file_name[[id]]) if (!file.exists(file.path(files$file_path[[id]], files$file_name[[id]]))) { foundallfiles <- FALSE - PEcAn.utils::logger.error("can not find posterior file: ", file.path(files$file_path[[id]], files$file_name[[id]])) + PEcAn.logger::logger.error("can not find posterior file: ", file.path(files$file_path[[id]], files$file_name[[id]])) } else if (files$file_name[[id]] == "species.csv") { - PEcAn.utils::logger.debug("Checking if species have changed") + PEcAn.logger::logger.debug("Checking if species have changed") testme <- read.csv(file.path(files$file_path[[id]], files$file_name[[id]])) if (!check.lists(species, testme)) { foundallfiles <- FALSE - PEcAn.utils::logger.error("species have changed: ", file.path(files$file_path[[id]], files$file_name[[id]])) + PEcAn.logger::logger.error("species have changed: ", file.path(files$file_path[[id]], files$file_name[[id]])) } remove(testme) } else if (files$file_name[[id]] == "prior.distns.Rdata") { - PEcAn.utils::logger.debug("Checking if priors have changed") + PEcAn.logger::logger.debug("Checking if priors have changed") prior.distns.tmp <- prior.distns if(file.exists(files$file_path[[id]], files$file_name[[id]])){ load(file.path(files$file_path[[id]], files$file_name[[id]]))#HERE IS THE PROBLEM }else{ - PEcAn.utils::logger.debug("Prior file does not exist. If empty (zero-byte) input file error is recived, set forceupdate to TRUE for one run.") + PEcAn.logger::logger.debug("Prior file does not exist. If empty (zero-byte) input file error is recived, set forceupdate to TRUE for one run.") } testme <- prior.distns prior.distns <- prior.distns.tmp if (!identical(prior.distns, testme)) { foundallfiles <- FALSE - PEcAn.utils::logger.error("priors have changed: ", file.path(files$file_path[[id]], files$file_name[[id]])) + PEcAn.logger::logger.error("priors have changed: ", file.path(files$file_path[[id]], files$file_name[[id]])) } remove(testme) } else if (files$file_name[[id]] == "trait.data.Rdata") { - PEcAn.utils::logger.debug("Checking if trait data has changed") + PEcAn.logger::logger.debug("Checking if trait data has changed") load(file.path(files$file_path[[id]], files$file_name[[id]])) # For trait data including converted data, only check unconverted @@ -146,13 +146,13 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, if (!identical(trait.data.check, trait.data)) { foundallfiles <- FALSE - PEcAn.utils::logger.error("trait data has changed: ", file.path(files$file_path[[id]], files$file_name[[id]])) + PEcAn.logger::logger.error("trait data has changed: ", file.path(files$file_path[[id]], files$file_name[[id]])) } remove(trait.data, trait.data.check) } } if (foundallfiles) { - PEcAn.utils::logger.info("Reusing existing files from posterior", pft$posteriorid, "for", pft$name) + PEcAn.logger::logger.info("Reusing existing files from posterior", pft$posteriorid, "for", pft$name) for(id in 1:nrow(files)) { file.copy(file.path(files[[id, 'file_path']], files[[id, 'file_name']]), file.path(pft$outdir, files[[id, 'file_name']])) } @@ -199,9 +199,9 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, file = file.path(pft$outdir, "prior.distns.csv"), row.names = TRUE) ## 3. display info to the console - PEcAn.utils::logger.info('Summary of Prior distributions for: ', pft$name) - PEcAn.utils::logger.info(colnames(prior.distns)) - apply(cbind(rownames(prior.distns), prior.distns), MARGIN=1, PEcAn.utils::logger.info) + PEcAn.logger::logger.info('Summary of Prior distributions for: ', pft$name) + PEcAn.logger::logger.info(colnames(prior.distns)) + apply(cbind(rownames(prior.distns), prior.distns), MARGIN=1, PEcAn.logger::logger.info) ## traits = variables with prior distributions for this pft trait.data.file <- file.path(pft$outdir, "trait.data.Rdata") @@ -209,9 +209,9 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, write.csv(plyr::ldply(trait.data), file = file.path(pft$outdir, "trait.data.csv"), row.names = FALSE) - PEcAn.utils::logger.info("number of observations per trait for", pft$name) + PEcAn.logger::logger.info("number of observations per trait for", pft$name) for(t in names(trait.data)){ - PEcAn.utils::logger.info(nrow(trait.data[[t]]), "observations of", t) + PEcAn.logger::logger.info(nrow(trait.data[[t]]), "observations of", t) } @@ -251,12 +251,12 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, ##' get.trait.data <- function(pfts, modeltype, dbfiles, database, forceupdate, trait.names=NULL) { if (!is.list(pfts)) { - PEcAn.utils::logger.severe('pfts must be a list') + PEcAn.logger::logger.severe('pfts must be a list') } # Check that all PFTs have associated outdir entries pft_outdirs <- lapply(pfts, '[[', 'outdir') if (any(sapply(pft_outdirs, is.null))) { - PEcAn.utils::logger.severe('At least one pft in settings is missing its "outdir"') + PEcAn.logger::logger.severe('At least one pft in settings is missing its "outdir"') } ##---------------- Load trait dictionary --------------# if(is.logical(trait.names)){ @@ -289,7 +289,7 @@ runModule.get.trait.data <- function(settings) { for(i in seq_along(settings)) { pfts.i <- settings[[i]]$pfts if (!is.list(pfts.i)) { - PEcAn.utils::logger.severe("settings[[i]]$pfts is not a list") + PEcAn.logger::logger.severe("settings[[i]]$pfts is not a list") } pft.names.i <- sapply(pfts.i, function(x) x$name) ind <- which(pft.names.i %in% setdiff(pft.names.i, pft.names)) @@ -297,7 +297,7 @@ runModule.get.trait.data <- function(settings) { pft.names <- sapply(pfts, function(x) x$name) } - PEcAn.utils::logger.info(paste0("Getting trait data for all PFTs listed by any Settings object in the list: ", + PEcAn.logger::logger.info(paste0("Getting trait data for all PFTs listed by any Settings object in the list: ", paste(pft.names, collapse=", "))) modeltype <- settings$model$type @@ -309,7 +309,7 @@ runModule.get.trait.data <- function(settings) { } else if(PEcAn.settings::is.Settings(settings)) { pfts <- settings$pfts if (!is.list(pfts)) { - PEcAn.utils::logger.severe("settings$pfts is not a list") + PEcAn.logger::logger.severe("settings$pfts is not a list") } modeltype <- settings$model$type dbfiles <- settings$database$dbfiles diff --git a/base/db/R/query.format.vars.R b/base/db/R/query.format.vars.R index eb3d4af3bb0..a6886484597 100644 --- a/base/db/R/query.format.vars.R +++ b/base/db/R/query.format.vars.R @@ -8,7 +8,7 @@ ##' query.format.vars <- function(bety,input.id=NA,format.id=NA,var.ids=NA){ - if(is.na(input.id) & is.na(format.id)){PEcAn.utils::logger.error("Must specify input id or format id")} + if(is.na(input.id) & is.na(format.id)){PEcAn.logger::logger.error("Must specify input id or format id")} con <- bety$con @@ -46,7 +46,7 @@ query.format.vars <- function(bety,input.id=NA,format.id=NA,var.ids=NA){ # Need to subset the formats table fv <- fv %>% dplyr::filter(variable_id %in% var.ids | storage_type != "") if(dim(fv)[1] == 0){ - PEcAn.utils::logger.error("None of your requested variables are available") + PEcAn.logger::logger.error("None of your requested variables are available") } } @@ -126,7 +126,7 @@ query.format.vars <- function(bety,input.id=NA,format.id=NA,var.ids=NA){ }else if(udunits2::ud.are.convertible(format$vars$input_units[i], format$vars$pecan_units[i]) == FALSE){ if(PEcAn.utils::misc.are.convertible(format$vars$input_units[i], format$vars$pecan_units[i]) == FALSE){ - PEcAn.utils::logger.warn("Units not convertible for",format$vars$input_name[i], "with units of",format$vars$input_units[i], ". Please make sure the varible has units that can be converted to", format$vars$pecan_units[i]) + PEcAn.logger::logger.warn("Units not convertible for",format$vars$input_name[i], "with units of",format$vars$input_units[i], ". Please make sure the varible has units that can be converted to", format$vars$pecan_units[i]) } } @@ -146,7 +146,7 @@ query.format.vars <- function(bety,input.id=NA,format.id=NA,var.ids=NA){ } if(length(unique(format$vars$pecan_name))!=length(format$vars$pecan_name)){ unique_cols<-match(unique(format$vars$pecan_name), format$vars$pecan_name) - PEcAn.utils::logger.warn("There are duplicate columns in format record",format$file_name, "If format is not wide format, check column(s)",format$vars$pecan_name[-unique_cols]) + PEcAn.logger::logger.warn("There are duplicate columns in format record",format$file_name, "If format is not wide format, check column(s)",format$vars$pecan_name[-unique_cols]) } diff --git a/base/db/R/utils.R b/base/db/R/utils.R index 6e60026cf6c..8fc67e99b4e 100644 --- a/base/db/R/utils.R +++ b/base/db/R/utils.R @@ -34,19 +34,19 @@ db.query <- function(query, con=NULL, params=NULL) { if(is.null(con)){ if (is.null(params)) { - PEcAn.utils::logger.error("No parameters or connection specified") + PEcAn.logger::logger.error("No parameters or connection specified") stop() } con <- db.open(params) on.exit(db.close(con)) } if (.db.utils$showquery) { - PEcAn.utils::logger.debug(query) + PEcAn.logger::logger.debug(query) } data <- DBI::dbGetQuery(con, query) res <- DBI::dbGetException(con) if (res$errorNum != 0 || (res$errorMsg != 'OK' && res$errorMsg != '')) { - PEcAn.utils::logger.severe(paste("Error executing db query '", query, "' errorcode=", res$errorNum, " message='", res$errorMsg, "'", sep='')) + PEcAn.logger::logger.severe(paste("Error executing db query '", query, "' errorcode=", res$errorNum, " message='", res$errorMsg, "'", sep='')) } .db.utils$queries <- .db.utils$queries+1 invisible(data) @@ -116,11 +116,11 @@ db.close <- function(con, showWarnings=TRUE) { id <- attr(con, "pecanid") if (showWarnings && is.null(id)) { - PEcAn.utils::logger.warn("Connection created outside of PEcAn.db package") + PEcAn.logger::logger.warn("Connection created outside of PEcAn.db package") } else { deleteme <- which(.db.utils$connections$id==id) if (showWarnings && length(deleteme) == 0) { - PEcAn.utils::logger.warn("Connection might have been closed already."); + PEcAn.logger::logger.warn("Connection might have been closed already."); } else { .db.utils$connections$id <- .db.utils$connections$id[-deleteme] .db.utils$connections$con <- .db.utils$connections$con[-deleteme] @@ -143,17 +143,17 @@ db.close <- function(con, showWarnings=TRUE) { ##' db.print.connections() ##' } db.print.connections <- function() { - PEcAn.utils::logger.info("Created", .db.utils$created, "connections and executed", .db.utils$queries, "queries") + PEcAn.logger::logger.info("Created", .db.utils$created, "connections and executed", .db.utils$queries, "queries") if (.db.utils$deprecated > 0) { - PEcAn.utils::logger.info("Used", .db.utils$deprecated, "calls to deprecated functions") + PEcAn.logger::logger.info("Used", .db.utils$deprecated, "calls to deprecated functions") } - PEcAn.utils::logger.info("Created", .db.utils$created, "connections and executed", .db.utils$queries, "queries") + PEcAn.logger::logger.info("Created", .db.utils$created, "connections and executed", .db.utils$queries, "queries") if (length(.db.utils$connections$id) == 0) { - PEcAn.utils::logger.debug("No open database connections.\n") + PEcAn.logger::logger.debug("No open database connections.\n") } else { for(x in 1:length(.db.utils$connections$id)) { - PEcAn.utils::logger.info(paste("Connection", x, "with id", .db.utils$connections$id[[x]], "was created at:\n")) - PEcAn.utils::logger.info(paste("\t", names(.db.utils$connections$log[[x]]), "\n")) + PEcAn.logger::logger.info(paste("Connection", x, "with id", .db.utils$connections$id[[x]], "was created at:\n")) + PEcAn.logger::logger.info(paste("\t", names(.db.utils$connections$log[[x]]), "\n")) # cat("\t database object : ") # print(.db.utils$connections$con[[x]]) } @@ -173,7 +173,7 @@ db.exists <- function(params, write=TRUE, table=NA) { con <- tryCatch({ invisible(db.open(params)) }, error = function(e) { - PEcAn.utils::logger.error("Could not connect to database.\n\t", e) + PEcAn.logger::logger.error("Could not connect to database.\n\t", e) invisible(NULL) }) if (is.null(con)) { @@ -186,7 +186,7 @@ db.exists <- function(params, write=TRUE, table=NA) { user.permission <<- tryCatch({ invisible(db.query(paste0("select privilege_type from information_schema.role_table_grants where grantee='",params$user,"' and table_catalog = '",params$dbname,"' and table_name='",table,"'"), con)) }, error = function(e) { - PEcAn.utils::logger.error("Could not query database.\n\t", e) + PEcAn.logger::logger.error("Could not query database.\n\t", e) db.close(con) invisible(NULL) }) @@ -213,7 +213,7 @@ db.exists <- function(params, write=TRUE, table=NA) { read.result <- tryCatch({ invisible(db.query(paste("SELECT * FROM", table, "LIMIT 1"), con)) }, error = function(e) { - PEcAn.utils::logger.error("Could not query database.\n\t", e) + PEcAn.logger::logger.error("Could not query database.\n\t", e) db.close(con) invisible(NULL) }) @@ -232,7 +232,7 @@ db.exists <- function(params, write=TRUE, table=NA) { pg_attribute.attnum = any(pg_index.indkey) AND indisprimary"), con) }, error = function(e) { - PEcAn.utils::logger.error("Could not query database.\n\t", e) + PEcAn.logger::logger.error("Could not query database.\n\t", e) db.close(con) invisible(NULL) }) @@ -266,7 +266,7 @@ db.exists <- function(params, write=TRUE, table=NA) { db.query(paste("UPDATE ", table, " SET ", write.coln,"='", write.value, "' WHERE ", key, "=", key.value, sep=""), con) invisible(TRUE) }, error = function(e) { - PEcAn.utils::logger.error("Could not write to database.\n\t", e) + PEcAn.logger::logger.error("Could not write to database.\n\t", e) invisible(FALSE) }) } else { @@ -326,7 +326,7 @@ get.id <- function(table, colnames, values, con, create=FALSE, dates=FALSE){ if (dates) colinsert <- paste0(colinsert, ", created_at, updated_at") valinsert <- paste0(values, collapse=", ") if (dates) valinsert <- paste0(valinsert, ", NOW(), NOW()") - PEcAn.utils::logger.info("INSERT INTO ", table, " (", colinsert, ") VALUES (", valinsert, ")") + PEcAn.logger::logger.info("INSERT INTO ", table, " (", colinsert, ") VALUES (", valinsert, ")") db.query(paste0("INSERT INTO ", table, " (", colinsert, ") VALUES (", valinsert, ")"), con) id <- db.query(query, con)[["id"]] } diff --git a/base/logger/DESCRIPTION b/base/logger/DESCRIPTION index 0322035dead..e942d4e44d1 100644 --- a/base/logger/DESCRIPTION +++ b/base/logger/DESCRIPTION @@ -1,4 +1,4 @@ -Package: pecan.logger +Package: PEcAn.logger Title: Logger functions for PEcAn Version: 0.0.0.9000 Authors: Rob Kooper, Alexey Shiklomanov diff --git a/base/settings/R/check.all.settings.R b/base/settings/R/check.all.settings.R index fc40e73d76a..be2a299e487 100644 --- a/base/settings/R/check.all.settings.R +++ b/base/settings/R/check.all.settings.R @@ -73,7 +73,7 @@ check.inputs <- function(settings) { formats <- PEcAn.DB::db.query(paste0("SELECT format_id FROM inputs WHERE id=", settings$run$inputs[[tag]][['id']]), con=dbcon) if (nrow(formats) >= 1) { if (formats[1, 'format_id'] != inputs$format_id[i]) { - PEcAn.utils::logger.warn("@Format of input", tag, "does not match specified input: ",formats[1, 'format_id'],inputs$format_id[i]) + PEcAn.logger::logger.warn("@Format of input", tag, "does not match specified input: ",formats[1, 'format_id'],inputs$format_id[i]) settings$run$inputs[[tag]][['path']] <- NULL ## zero out path, do_conversions will need to convert specified input ID to model format } } else { diff --git a/base/settings/R/papply.R b/base/settings/R/papply.R index 1eb79903d48..4a7e2e2bbd8 100644 --- a/base/settings/R/papply.R +++ b/base/settings/R/papply.R @@ -56,7 +56,7 @@ papply <- function(settings, fn, ..., stop.on.error = FALSE) { } } else { if (stop.on.error) { - PEcAn.utils::logger.error(paste0("papply threw an error for element ", i, " of ", length(settings), + PEcAn.logger::logger.error(paste0("papply threw an error for element ", i, " of ", length(settings), ", and is aborting since stop.on.error=TRUE. Message was: '", as.character(result.i), "'")) stop() @@ -64,7 +64,7 @@ papply <- function(settings, fn, ..., stop.on.error = FALSE) { warning.message.i <- paste0("papply threw an error for element ", i, " of ", length(settings), ", but is continuing since stop.on.error=FALSE", " (there will be no results for this element, however). Message was: '", as.character(result.i), "'") - PEcAn.utils::logger.warn(warning.message.i) + PEcAn.logger::logger.warn(warning.message.i) errors <- c(errors, paste0("Element ", i, ": '", as.character(result.i), "'")) } } @@ -75,7 +75,7 @@ papply <- function(settings, fn, ..., stop.on.error = FALSE) { } if (length(errors) > 0) { - PEcAn.utils::logger.warn(paste0("papply encountered errors for ", length(errors), " elements, ", + PEcAn.logger::logger.warn(paste0("papply encountered errors for ", length(errors), " elements, ", "but continued since stop.on.error=FALSE. ", paste(errors, collapse = "; "))) } diff --git a/base/utils/R/do_conversions.R b/base/utils/R/do_conversions.R index 11374573cdb..69009d54658 100644 --- a/base/utils/R/do_conversions.R +++ b/base/utils/R/do_conversions.R @@ -16,7 +16,7 @@ do_conversions <- function(settings, overwrite.met = FALSE, overwrite.fia = FALS dbfiles.local <- settings$database$dbfiles dbfiles <- ifelse(!PEcAn.utils::is.localhost(settings$host) & !is.null(settings$host$folder), settings$host$folder, dbfiles.local) - PEcAn.utils::logger.debug("do.conversion outdir",dbfiles) + PEcAn.logger::logger.debug("do.conversion outdir",dbfiles) for (i in seq_along(settings$run$inputs)) { input <- settings$run$inputs[[i]] @@ -25,7 +25,7 @@ do_conversions <- function(settings, overwrite.met = FALSE, overwrite.fia = FALS } input.tag <- names(settings$run$input)[i] - PEcAn.utils::logger.info("PROCESSING: ",input.tag) + PEcAn.logger::logger.info("PROCESSING: ",input.tag) ic.flag <- fia.flag <- FALSE @@ -66,7 +66,7 @@ do_conversions <- function(settings, overwrite.met = FALSE, overwrite.fia = FALS if (input.tag == "met") { name <- ifelse(is.null(settings$browndog), "MET Process", "BrownDog") if ( (PEcAn.utils::status.check(name) == 0)) { ## previously is.null(input$path) && - PEcAn.utils::logger.info("calling met.process: ",settings$run$inputs[[i]][['path']]) + PEcAn.logger::logger.info("calling met.process: ",settings$run$inputs[[i]][['path']]) settings$run$inputs[[i]][['path']] <- PEcAn.data.atmosphere::met.process( site = settings$run$site, @@ -80,7 +80,7 @@ do_conversions <- function(settings, overwrite.met = FALSE, overwrite.fia = FALS browndog = settings$browndog, spin = settings$spin, overwrite = overwrite.met) - PEcAn.utils::logger.debug("updated met path: ",settings$run$inputs[[i]][['path']]) + PEcAn.logger::logger.debug("updated met path: ",settings$run$inputs[[i]][['path']]) needsave <- TRUE } } diff --git a/base/utils/R/logger.R b/base/utils/R/logger.R new file mode 100644 index 00000000000..3247db03003 --- /dev/null +++ b/base/utils/R/logger.R @@ -0,0 +1,83 @@ +logger_deprecated <- function() { + warning('Logger functions have moved from PEcAn.utils to PEcAn.logger.', + 'This usage is deprecated') +} + +#' Logger functions (imported temporarily from PEcAn.logger) +#' +#' @importFrom PEcAn.logger logger.debug +#' @export +logger.debug <- function(...) { + logger_deprecated() + PEcAn.logger::logger.debug(...) +} + +#' @importFrom PEcAn.logger logger.info +#' @export +logger.info <- function(...) { + logger_deprecated() + PEcAn.logger::logger.info(...) +} + +#' @importFrom PEcAn.logger logger.warn +#' @export +logger.warn <- function(...) { + logger_deprecated() + PEcAn.logger::logger.warn(...) +} + +#' @importFrom PEcAn.logger logger.error +#' @export +logger.error <- function(...) { + logger_deprecated() + PEcAn.logger::logger.error(...) +} + +#' @importFrom PEcAn.logger logger.severe +#' @export +logger.severe <- function(...) { + logger_deprecated() + PEcAn.logger::logger.severe(...) +} + +#' @importFrom PEcAn.logger logger.setLevel +#' @export +logger.setLevel <- function(...) { + logger_deprecated() + PEcAn.logger::logger.setLevel(...) +} + +#' @importFrom PEcAn.logger logger.getLevelNumber +#' @export +logger.getLevelNumber <- function(...) { + logger_deprecated() + PEcAn.logger::logger.getLevelNumber(...) +} + +#' @importFrom PEcAn.logger logger.getLevel +#' @export +logger.getLevel <- function(...) { + logger_deprecated() + PEcAn.logger::logger.getLevel(...) +} + +#' @importFrom PEcAn.logger logger.setOutputFile +#' @export +logger.setOutputFile <- function(...) { + logger_deprecated() + PEcAn.logger::logger.setOutputFile(...) +} + +#' @importFrom PEcAn.logger logger.setQuitOnSevere +#' @export +logger.setQuitOnSevere <- function(...) { + logger_deprecated() + PEcAn.logger::logger.setQuitOnSevere(...) +} + +#' @importFrom PEcAn.logger logger.setWidth +#' @export +logger.setWidth <- function(...) { + logger_deprecated() + PEcAn.logger::logger.setWidth(...) +} diff --git a/base/utils/R/read.output.R b/base/utils/R/read.output.R index d545b324238..a49262326d0 100644 --- a/base/utils/R/read.output.R +++ b/base/utils/R/read.output.R @@ -130,7 +130,7 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables if(dataframe==TRUE){ #ensure that there is a time component when asking for a dataframe + posix code if(length(variables[variables=="time"])==0){ variables<-c(variables, "time") - PEcAn.utils::logger.info("No time variable requested, adding automatically") + PEcAn.logger::logger.info("No time variable requested, adding automatically") } } result <- list() diff --git a/base/utils/R/start.model.runs.R b/base/utils/R/start.model.runs.R index ecacd3d86dd..2a6a9aa0db0 100644 --- a/base/utils/R/start.model.runs.R +++ b/base/utils/R/start.model.runs.R @@ -112,17 +112,17 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error=TRUE) { # start the actual model run cmd <- qsub[[1]] args <- qsub[-1] - PEcAn.utils::logger.debug(cmd,args) + PEcAn.logger::logger.debug(cmd,args) if (is.localhost(settings$host)) { out <- system2(cmd, c(args, file.path(settings$rundir, format(run, scientific = FALSE), "job.sh")), stdout = TRUE, stderr = TRUE) } else { out <- remote.execute.cmd(settings$host, cmd, c(args, file.path(settings$host$rundir, format(run, scientific = FALSE), "job.sh")), stderr = TRUE) - PEcAn.utils::logger.debug(settings$host,format(run, scientific = FALSE)) + PEcAn.logger::logger.debug(settings$host,format(run, scientific = FALSE)) } - PEcAn.utils::logger.debug("JOB.SH submit status:",out) + PEcAn.logger::logger.debug("JOB.SH submit status:",out) jobids[run] <- sub(settings$host$qsub.jobid, "\\1", out) # if qsub option is not invoked. just start model runs in serial. diff --git a/base/utils/R/to_nc.R b/base/utils/R/to_nc.R index 034b5347fcc..a03ef8b80ab 100644 --- a/base/utils/R/to_nc.R +++ b/base/utils/R/to_nc.R @@ -12,14 +12,14 @@ to_ncdim <- function(dimname,vals){ dim <- standard_vars[which(standard_vars$Variable.Name == dimname),] #check dim exists if(nrow(dim) == 0){ - PEcAn.utils::logger.severe(paste("Dimension",dimname,"not in standard_vars")) + PEcAn.logger::logger.severe(paste("Dimension",dimname,"not in standard_vars")) } if(dim$Category != "Dimension"){ - PEcAn.utils::logger.severe(paste(dimname,"not a dimension or is deprecated")) + PEcAn.logger::logger.severe(paste(dimname,"not a dimension or is deprecated")) } if(is.null(vals) || length(vals) == 0){ - PEcAn.utils::logger.severe(paste("Missing vals for dim",dimname,",please check input")) + PEcAn.logger::logger.severe(paste("Missing vals for dim",dimname,",please check input")) } #not sure if this check is necessary units <- as.character(dim$Units) #if the units are a factor the function fails @@ -45,14 +45,14 @@ to_ncvar <- function(varname,dims){ var <- standard_vars[which(standard_vars$Variable.Name == varname),] #check var exists if(nrow(var)==0){ - PEcAn.utils::logger.severe(paste("Variable",varname,"not in standard_vars")) + PEcAn.logger::logger.severe(paste("Variable",varname,"not in standard_vars")) } dimset <- var[,c("dim1","dim2","dim3","dim4")] dim <- dims[which(names(dims) %in% dimset)] #subset list of all dims for this variable #check that dim isn't 0 if(length(dim)==0 || is.null(dim)){ - PEcAn.utils::logger.severe(paste("No dimensions were loaded for",varname)) + PEcAn.logger::logger.severe(paste("No dimensions were loaded for",varname)) } units = as.character(var$Units) #if the units are a factor the function fails diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index 9834e160fd9..05e37682356 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -102,7 +102,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, LeafWaterPot <- -0.8 old.file <- file.path(in.path, paste(in.prefix, year, ".nc", sep = "")) - if(!file.exists(old.file)) PEcAn.utils::logger.error("file not found",old.file) + if(!file.exists(old.file)) PEcAn.logger::logger.error("file not found",old.file) ## open netcdf nc <- ncdf4::nc_open(old.file) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index d4a667b4438..7f037436c32 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -15,7 +15,7 @@ PREFIX_XML <- "\n" convert.samples.DALEC <- function(trait.samples) { DEFAULT.LEAF.C <- 0.48 - ## convert SLA from PEcAn m2 / kg leaf to m2 / g C + ## convert SLA from m2 / kg leaf to m2 / g C if ("SLA" %in% names(trait.samples)) { trait.samples[["SLA"]] <- trait.samples[["SLA"]]/DEFAULT.LEAF.C/1000 @@ -108,63 +108,152 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } ### INITIAL CONDITIONS + + #function to check that ncvar was loaded (numeric) and has a valid value (not NA or negative) + is.valid <- function(var){ + return(all(is.numeric(var) && !is.na(var) && var >= 0)) + } + + default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC"), header = TRUE) IC.params <- list() - if(!is.null(settings$run$inputs$poolinitcond$path)) { + if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path + IC.nc <- try(ncdf4::nc_open(IC.path)) - sla <- NULL - if("SLA" %in% names(params)){ - sla <- params[1,"SLA"] * 1000 #convert SLA to m2/kgC from m2/gC (convert.samples) - } else{ - default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC"), header = TRUE) - sla <- default.param[which(default.param$cmdFlag == "SLA"),"val"] * 1000 #convert SLA to m2/kgC from m2/gC (dalec default) - } - - IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = sla)) - - if(!is.null(IC.pools)){ - ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) + if(class(IC.nc) != "try-error"){ + #check/load biomass netcdf variables + TotLivBiom <- try(ncdf4::ncvar_get(IC.nc,"TotLivBiom"),silent = TRUE) + leaf <- try(ncdf4::ncvar_get(IC.nc,"leaf_carbon_content"),silent = TRUE) + LAI <- try(ncdf4::ncvar_get(IC.nc,"LAI"),silent = TRUE) + AbvGrndWood <- try(ncdf4::ncvar_get(IC.nc,"AbvGrndWood"),silent = TRUE) + roots <- try(ncdf4::ncvar_get(IC.nc,"root_carbon_content"),silent = TRUE) + fine.roots <- try(ncdf4::ncvar_get(IC.nc,"fine_root_carbon_content"),silent = TRUE) + coarse.roots <- try(ncdf4::ncvar_get(IC.nc,"coarse_root_carbon_content"),silent = TRUE) + + if(!all(sapply(c(TotLivBiom,leaf,LAI,AbvGrndWood,roots,fine.roots,coarse.roots),is.numeric))){ + PEcAn.logger::logger.info("DALEC IC: Any missing vars will be calculated from those provided or replaced by DALEC's defaults") + } + + #check if total roots are partitionable + #note: if roots are patritionable, they will override fine_ and/or coarse_root_carbon_content if loaded + if(is.valid(roots)){ + if("rtsize" %in% names(IC.nc$dim)){ + PEcAn.logger::logger.info("DALEC IC: Attempting to partition root_carbon_content") + rtsize <- IC.nc$dim$rtsize$vals + part_roots <- PEcAn.data.land::partition_roots(roots, rtsize) + if(!is.null(part_roots)){ + fine.roots <- part_roots$fine.roots + coarse.roots <- part_roots$coarse.roots + } else{ + PEcAn.logger::logger.error("DALEC IC: could not partition roots; please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + } + } else{ + PEcAn.logger::logger.error("DALEC IC: Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + } + } else{ + #proceed without error message + } + + + ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) # cf0 initial canopy foliar carbon (g/m2) - if ("leaf" %in% names(IC.pools)) { - IC.params[["cf0"]] <- IC.pools$leaf * 1000 #from PEcAn standard kg C m-2 - } + if (is.valid(leaf)) { + IC.params[["cf0"]] <- leaf * 1000 #from standard kg C m-2 + } else if(is.valid(LAI)){ + if("SLA" %in% names(params)){ + SLA <- 1/params[1,"SLA"] #SLA converted to m2/gC in convert.samples + leaf <- LAI * SLA + IC.params[["cf0"]] <- leaf + } else{ + SLA <- default.param[which(default.param$cmdFlag == "SLA"),"val"] + leaf <- LAI * 1/SLA #check that leaf isn't higher than total biomass if given? + IC.params[["cf0"]] <- leaf + } + } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && + is.valid(fine.roots) && is.valid(coarse.roots)){ + leaf <- (TotLivBiom - AbvGrndWood - fine.roots - coarse.roots) * 1000 #from standard kg C m-2 + if(leaf >= 0){ + IC.params[["cf0"]] <- leaf + } else{ + PEcAn.logger::logger.error("TotLivBiom is less than sum of AbvGrndWood and roots; using default for leaf biomass") + } + } # cw0 initial pool of woody carbon (g/m2) - if ("wood" %in% names(IC.pools)) { - IC.params[["cw0"]] <- IC.pools$wood * 1000 #from PEcAn standard kg C m-2 - } + if (is.valid(AbvGrndWood)) { + if(is.valid(coarse.roots)){ + IC.params[["cw0"]] <- (AbvGrndWood + coarse.roots) * 1000 #from standard kg C m-2 + } else{ + PEcAn.logger::logger.error("write.configs.DALEC IC can't calculate total woody biomass with only AbvGrndWood; checking for total biomass.") + } + } else if (is.valid(TotLivBiom) && is.valid(leaf) && is.valid(fine.roots)){ + if(is.valid(LAI)){ + wood <- (1000*(TotLivBiom - fine.roots)) - leaf #convert TotLivBiom and fine.roots to g C m-2 from standard kg C m-2; leaf already converted via SLA + } + else{ + wood <- (TotLivBiom - leaf - fine.roots) * 1000 #from standard kg C m-2 + } + if (wood >= 0){ + IC.params[["cw0"]] <- wood + }else{ + PEcAn.logger::logger.error(paste("TotLivBiom (", TotLivBiom, ") is less than sum of leaf (", leaf, ") and fine roots(",fine.roots,"); using default for woody biomass.")) + } + } else{ + PEcAn.logger::logger.error("write.configs.DALEC IC could not calculate woody biomass; using defaults. Please provide AbvGrndWood and coarse_root_carbon OR leaf_carbon_content/LAI, fine_root_carbon_content, and TotLivBiom in netcdf.") + } # cr0 initial pool of fine root carbon (g/m2) - if ("fine.roots" %in% names(IC.pools)) { - IC.params[["cr0"]] <- IC.pools$fine.roots * 1000 #from PEcAn standard kg C m-2 - } + if (is.valid(fine.roots)) { + IC.params[["cr0"]] <- fine.roots * 1000 #from standard kg C m-2 + } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && + is.valid(leaf) && is.valid(coarse.roots)){ + if(is.valid(LAI)){ + fine.roots <- ((TotLivBiom - AbvGrndWood - coarse.roots) * 1000) - leaf #from standard kg C m-2; leaf already converted + }else{ + fine.roots <- (TotLivBiom - AbvGrndWood - leaf - coarse.roots) * 1000 #from standard kg C m-2 + } + if(fine.roots >= 0){ + IC.params[["cr0"]] <- fine.roots + } else{ + PEcAn.logger::logger.error("TotLivBiom is less than sum of AbvGrndWood, coarse roots, and leaf; using default for fine.roots biomass") + } + } ###non-living variables # cl0 initial pool of litter carbon (g/m2) - if ("litter" %in% names(IC.pools)) { - IC.params[["cl0"]] <- IC.pools$litter * 1000 #from PEcAn standard kg C m-2 + litter <- try(ncdf4::ncvar_get(IC.nc,"litter_carbon_content"),silent = TRUE) + if (is.valid(litter)) { + IC.params[["cl0"]] <- litter * 1000 #from standard kg C m-2 } # cs0 initial pool of soil organic matter and woody debris carbon (g/m2) - if("soil" %in% names(IC.pools)){ - if("wood.debris" %in% names(IC.pools)){ - IC.params[["cs0"]] <- (IC.pools$soil + sum(IC.pools$wood.debris)) * 1000 #from PEcAn standard kg C m-2 - } else { - IC.params[["cs0"]] <- IC.pools$soil * 1000 #from PEcAn standard kg C m-2 - PEcAn.utils::logger.warn("write.configs.DALEC IC: Loading soil carbon pool without woody debris.") + soil <- try(ncdf4::ncvar_get(IC.nc,"soil_organic_carbon_content"),silent = TRUE) + wood.debris <- try(ncdf4::ncvar_get(IC.nc,"wood_debris_carbon_content"),silent = TRUE) + + if(is.valid(soil) && is.valid(wood.debris)){ + IC.params[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #from standard kg C m-2 + } else if(!is.valid(soil) && is.valid(wood.debris)){ + soil <- try(ncdf4::ncvar_get(IC.nc,"soil_carbon_content"),silent = TRUE) + if(is.valid(soil)){ + IC.params[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #from standard kg C m-2 + } else{ + PEcAn.logger::logger.error("write.configs.DALEC IC can't calculate soil matter pool without soil carbon; using default. Please provide soil_organic_carbon_content in netcdf.") } + } else if(is.valid(soil) && !is.valid(wood.debris)){ + IC.params[["cs0"]] <- soil * 1000 #from standard kg C m-2 + PEcAn.logger::logger.warn("write.configs.DALEC IC: Loading soil carbon pool without woody debris.") } ###Write to command line file for (i in seq_along(IC.params)) { cmdFlags <- paste0(cmdFlags, " -", names(IC.params)[i], " ", IC.params[[i]]) } - PEcAn.utils::logger.info(paste("All command flags:",cmdFlags)) + PEcAn.logger::logger.info(paste("All command flags:",cmdFlags)) } else{ - PEcAn.utils::logger.error("Bad initial conditions filepath; kept defaults") + PEcAn.logger::logger.error("Bad initial conditions filepath; kept defaults") } } diff --git a/models/ed/R/SDA.helpers.ED2.R b/models/ed/R/SDA.helpers.ED2.R index 45bb13d0fb5..f80f632489b 100644 --- a/models/ed/R/SDA.helpers.ED2.R +++ b/models/ed/R/SDA.helpers.ED2.R @@ -24,13 +24,13 @@ get_restartfile.ED2 <- function(mod_outdir, runid, file.time) { histfile_string, full.names = TRUE) if (length(histfile) > 1) { - PEcAn.utils::logger.error("Multiple history files found.") + PEcAn.logger::logger.error("Multiple history files found.") return(NULL) } else if (length(histfile) < 1) { - PEcAn.utils::logger.error("No history files found.") + PEcAn.logger::logger.error("No history files found.") return(NULL) } else { - PEcAn.utils::logger.info("Using history file: ", + PEcAn.logger::logger.info("Using history file: ", histfile) return(histfile) } diff --git a/models/ed/R/ed2in_set_value.R b/models/ed/R/ed2in_set_value.R index 7c7389109ef..8b6233139c6 100644 --- a/models/ed/R/ed2in_set_value.R +++ b/models/ed/R/ed2in_set_value.R @@ -13,7 +13,7 @@ ed2in_set_value <- function(tag, value, ed2in, modstring = "Modified by PEcAn") { if (grepl("NL%", tag)) { - PEcAn.utils::logger.warn("NL% is automatically prepended ", + PEcAn.logger::logger.warn("NL% is automatically prepended ", "to tags. Removing it from provided tag.") tag <- gsub('NL%', '', tag) } @@ -21,7 +21,7 @@ ed2in_set_value <- function(tag, value, ed2in, regex <- sprintf("(^[[:blank:]]*NL%%%s)[[:blank:]]+=.*", tag) in_ed2in <- any(grepl(regex, ed2in)) if (!in_ed2in) { - PEcAn.utils::logger.warn("Tag ", shQuote(tag), " not found in ED2IN. ") + PEcAn.logger::logger.warn("Tag ", shQuote(tag), " not found in ED2IN. ") return(ed2in) } diff --git a/models/ed/R/read_restart.ED2.R b/models/ed/R/read_restart.ED2.R index b7d3ab22ec6..6523356ec91 100644 --- a/models/ed/R/read_restart.ED2.R +++ b/models/ed/R/read_restart.ED2.R @@ -28,7 +28,7 @@ read_restart.ED2 <- function(outdir, histfile <- get_restartfile.ED2(mod_outdir, runid, stop.time) if (is.null(histfile)) { - PEcAn.utils::logger.severe("Failed to find ED2 history restart file.") + PEcAn.logger::logger.severe("Failed to find ED2 history restart file.") } nc <- ncdf4::nc_open(histfile) @@ -86,7 +86,7 @@ read_restart.ED2 <- function(outdir, names(agb_pft) <- pft_full_names[names(agb_pft)] forecast[[var_name]] <- agb_pft } else { - PEcAn.utils::logger.error("Variable ", var_name, + PEcAn.logger::logger.error("Variable ", var_name, " not currently supported", " by read.restart.ED2") } diff --git a/models/ed/R/veg2model.ED2.R b/models/ed/R/veg2model.ED2.R index 9bbde081c93..376dc80f2f6 100644 --- a/models/ed/R/veg2model.ED2.R +++ b/models/ed/R/veg2model.ED2.R @@ -46,7 +46,7 @@ veg2model.ED2 <- function(outfolder, veg_info, start_date, new_site, source){ pss <- data.frame(time = time, patch = n.patch, trk = trk, age = age) - PEcAn.utils::logger.info(paste0("Values used in the patch file - time:", + PEcAn.logger::logger.info(paste0("Values used in the patch file - time:", pss$time, ", patch:", pss$patch, ", trk:", pss$trk, ", age:", pss$age)) diff --git a/models/ed/R/write.configs.ed.R b/models/ed/R/write.configs.ed.R index 51b01bf5361..1582f61fd55 100644 --- a/models/ed/R/write.configs.ed.R +++ b/models/ed/R/write.configs.ed.R @@ -132,9 +132,9 @@ write.config.ED2 <- function(trait.values, settings, run.id, defaults = settings filename <- system.file(paste0("ED2IN.r", rev), package = "PEcAn.ED2") } if (filename == "") { - PEcAn.utils::logger.severe("Could not find ED template") + PEcAn.logger::logger.severe("Could not find ED template") } - PEcAn.utils::logger.info("Using", filename, "as template") + PEcAn.logger::logger.info("Using", filename, "as template") ed2in.text <- readLines(con = filename, n = -1) } @@ -150,7 +150,7 @@ write.config.ED2 <- function(trait.values, settings, run.id, defaults = settings ed2in.text <- gsub("@MET_END@", metend, ed2in.text) if (is.null(settings$model$phenol.scheme)) { - PEcAn.utils::logger.error(paste0("no phenology scheme set; \n", + PEcAn.logger::logger.error(paste0("no phenology scheme set; \n", "need to add ", "tag under tag in settings file")) } else if (settings$model$phenol.scheme == 1) { @@ -202,9 +202,9 @@ write.config.ED2 <- function(trait.values, settings, run.id, defaults = settings prefix.css <- sub(lat_rxp, "", settings$run$inputs$pss$path) # pss and css prefix is not the same, kill if (!identical(prefix.pss, prefix.css)) { - PEcAn.utils::logger.info(paste("pss prefix:", prefix.pss)) - PEcAn.utils::logger.info(paste("css prefix:", prefix.css)) - PEcAn.utils::logger.severe("ED2 css/pss/ files have different prefix") + PEcAn.logger::logger.info(paste("pss prefix:", prefix.pss)) + PEcAn.logger::logger.info(paste("css prefix:", prefix.css)) + PEcAn.logger::logger.severe("ED2 css/pss/ files have different prefix") } else { # pss and css are both present value <- 2 @@ -213,9 +213,9 @@ write.config.ED2 <- function(trait.values, settings, run.id, defaults = settings prefix.site <- sub(lat_rxp, "", settings$run$inputs$site$path) # sites and pss have different prefix name, kill if (!identical(prefix.site, prefix.pss)) { - PEcAn.utils::logger.info(paste("site prefix:", prefix.site)) - PEcAn.utils::logger.info(paste("pss prefix:", prefix.pss)) - PEcAn.utils::logger.severe("ED2 sites/pss/ files have different prefix") + PEcAn.logger::logger.info(paste("site prefix:", prefix.site)) + PEcAn.logger::logger.info(paste("pss prefix:", prefix.pss)) + PEcAn.logger::logger.severe("ED2 sites/pss/ files have different prefix") } else { # sites and pass same prefix name, case 3 value <- 3 @@ -333,11 +333,11 @@ write.config.xml.ED2 <- function(settings, trait.values, defaults = settings$con ## Find history file TODO this should come from the database histfile <- paste0("data/history.r", settings$model$revision, ".csv") if (file.exists(system.file(histfile, package = "PEcAn.ED2"))) { - PEcAn.utils::logger.info(paste0("--- Using ED2 History File: ", "data/history.r", settings$model$revision, ".csv")) + PEcAn.logger::logger.info(paste0("--- Using ED2 History File: ", "data/history.r", settings$model$revision, ".csv")) edhistory <- read.csv2(system.file(histfile, package = "PEcAn.ED2"), sep = ";", stringsAsFactors = FALSE, dec = ".") } else { - PEcAn.utils::logger.info("--- Using Generic ED2 History File: data/history.csv") + PEcAn.logger::logger.info("--- Using Generic ED2 History File: data/history.csv") edhistory <- read.csv2(system.file("data/history.csv", package = "PEcAn.ED2"), sep = ";", stringsAsFactors = FALSE, dec = ".") } @@ -395,7 +395,7 @@ write.config.xml.ED2 <- function(settings, trait.values, defaults = settings$con decompositon.xml <- PEcAn.utils::listToXml(vals, "decomposition") xml <- XML::append.xmlNode(xml, decompositon.xml) } else if(length(pft.number) == 0) { - PEcAn.utils::logger.error(pft, "was not matched with a number in settings$constants or pftmapping data. Consult the PEcAn instructions on defining new PFTs.") + PEcAn.logger::logger.error(pft, "was not matched with a number in settings$constants or pftmapping data. Consult the PEcAn instructions on defining new PFTs.") stop("Unable to set PFT number") }else{ # TODO: Also modify web app to not default to 1 diff --git a/models/ed/R/write_restart.ED2.R b/models/ed/R/write_restart.ED2.R index 86ee0c8bba1..950161302e4 100644 --- a/models/ed/R/write_restart.ED2.R +++ b/models/ed/R/write_restart.ED2.R @@ -20,7 +20,7 @@ write_restart.ED2 <- function(outdir, # Get history restart file path histfile <- get_restartfile.ED2(mod_outdir, runid, start.time) if (is.null(histfile)) { - PEcAn.utils::logger.severe("Failed to find ED2 history restart file.") + PEcAn.logger::logger.severe("Failed to find ED2 history restart file.") } #### Backup old run files to date directory @@ -115,7 +115,7 @@ write_restart.ED2 <- function(outdir, h5_write <- rhdf5::h5write.default(new.nplant_co_plant, histfile, "NPLANT") # Returns NULL on success...? } else { - PEcAn.utils::logger.error("Variable ", var_name, + PEcAn.logger::logger.error("Variable ", var_name, " not currently supported", " by write.restart.ED2") } diff --git a/models/fates/R/model2netcdf.FATES.R b/models/fates/R/model2netcdf.FATES.R index ed3768e4b38..516f87a295d 100644 --- a/models/fates/R/model2netcdf.FATES.R +++ b/models/fates/R/model2netcdf.FATES.R @@ -25,9 +25,9 @@ model2netcdf.FATES <- function(outdir) { # misc.convert <- PEcAn.utils::misc.convert # unit conversions - logger.info <- PEcAn.utils::logger.info - logger.severe <- PEcAn.utils::logger.severe - logger.warn <- PEcAn.utils::logger.warn + logger.info <- PEcAn.logger::logger.info + logger.severe <- PEcAn.logger::logger.severe + logger.warn <- PEcAn.logger::logger.warn # var_update("AR","AutoResp","kgC m-2 s-1") var_update <- function(out,oldname,newname,newunits=NULL){ diff --git a/models/fates/R/write.configs.FATES.R b/models/fates/R/write.configs.FATES.R index f9f8ae5f69f..50e7f9837b8 100644 --- a/models/fates/R/write.configs.FATES.R +++ b/models/fates/R/write.configs.FATES.R @@ -197,36 +197,36 @@ write.config.FATES <- function(defaults, trait.values, settings, run.id){ ## Loop over PFTS npft <- length(trait.values) - PEcAn.utils::logger.debug(npft) - PEcAn.utils::logger.debug(dim(trait.values)) - PEcAn.utils::logger.debug(names(trait.values)) + PEcAn.logger::logger.debug(npft) + PEcAn.logger::logger.debug(dim(trait.values)) + PEcAn.logger::logger.debug(names(trait.values)) #pftnames <- stringr::str_trim(tolower(ncvar_get(param.nc,"pftname"))) pftnames <- stringr::str_trim(tolower(ncvar_get(clm.param.nc,"pftname"))) for (i in seq_len(npft)) { pft <- trait.values[[i]] print(c("PFT",i)) - PEcAn.utils::logger.info(pft) + PEcAn.logger::logger.info(pft) pft.name <- names(trait.values)[i] if(is.null(pft.name) | is.na(pft.name)){ - PEcAn.utils::logger.error("pft.name missing") + PEcAn.logger::logger.error("pft.name missing") } else { - PEcAn.utils::logger.info(paste("PFT =",pft.name)) - PEcAn.utils::logger.debug(paste0("fates-clm PFT number: ",which(pftnames==pft.name))) + PEcAn.logger::logger.info(paste("PFT =",pft.name)) + PEcAn.logger::logger.debug(paste0("fates-clm PFT number: ",which(pftnames==pft.name))) } if(pft.name == 'env') next ## HACK, need to remove env from default ## Match PFT name to COLUMN ipft <- match(tolower(pft.name),pftnames) - PEcAn.utils::logger.debug(paste0("ipft: ",ipft)) + PEcAn.logger::logger.debug(paste0("ipft: ",ipft)) if(is.na(ipft)){ - PEcAn.utils::logger.severe(paste("Unmatched PFT",pft.name, + PEcAn.logger::logger.severe(paste("Unmatched PFT",pft.name, "in FATES. PEcAn does not yet support non-default PFTs for this model")) } # hard code hack until we can use more than 2 pfts in FATES ipft <- 2 - PEcAn.utils::logger.debug(paste0("*** PFT number hard-coded to ", ipft," in fates. This will be updated when FATES allows more PFTs")) + PEcAn.logger::logger.debug(paste0("*** PFT number hard-coded to ", ipft," in fates. This will be updated when FATES allows more PFTs")) ## Special variables used in conversions # leafC <- pft['leafC']/100 ## percent to proportion @@ -282,7 +282,7 @@ write.config.FATES <- function(defaults, trait.values, settings, run.id){ if(var == "SLA"){ ncvar_put(nc=fates.param.nc, varid='fates_slatop', start = ipft, count = 1, vals=udunits2::ud.convert(pft[v],"m2 kg-1","m2 g-1")/leafC) - #PEcAn.utils::logger.debug(paste0("SLA: ",udunits2::ud.convert(pft[v],"m2 kg-1","m2 g-1")/leafC)) # temp debugging + #PEcAn.logger::logger.debug(paste0("SLA: ",udunits2::ud.convert(pft[v],"m2 kg-1","m2 g-1")/leafC)) # temp debugging } if(var == "leaf_turnover_rate"){ ncvar_put(nc=fates.param.nc, varid='fates_leaf_long', start = ipft, count = 1, @@ -307,7 +307,7 @@ write.config.FATES <- function(defaults, trait.values, settings, run.id){ if(var == "leaf_width"){ # Characteristic leaf dimension use for aerodynamic resistance ncvar_put(nc=fates.param.nc, varid='fates_dleaf', start = ipft, count = 1, vals=udunits2::ud.convert(pft[v],"mm","m")) - #PEcAn.utils::logger.debug(paste0("fates_dleaf: ",udunits2::ud.convert(pft[v],"mm","m"))) # temp debugging + #PEcAn.logger::logger.debug(paste0("fates_dleaf: ",udunits2::ud.convert(pft[v],"mm","m"))) # temp debugging } ## Currently not in param.nc file despite being on NGEE-T parameter list # if(var == "nonlocal_dispersal"){ # Place-holder parameter for important seed dispersal parameters diff --git a/models/jules/R/write.config.JULES.R b/models/jules/R/write.config.JULES.R index 20849ea64d7..bf7b915042b 100644 --- a/models/jules/R/write.config.JULES.R +++ b/models/jules/R/write.config.JULES.R @@ -186,7 +186,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { settings$run$inputs$co2$path <- co2.remote } - PEcAn.utils::logger.debug("co2.local",co2.local,length(co2.dat)) + PEcAn.logger::logger.debug("co2.local",co2.local,length(co2.dat)) } ## add CO2 file @@ -599,7 +599,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { #' @examples detect.timestep <- function(met.dir,met.regexp,start_date){ met.file <- dir(met.dir, pattern = met.regexp, full.names = TRUE)[1] - PEcAn.utils::logger.info("Detect timestep:",met.dir,met.regexp) + PEcAn.logger::logger.info("Detect timestep:",met.dir,met.regexp) met.header <- system(paste("ncdump -h ", met.file), intern = TRUE) id <- grep("time:delta_t", met.header) if (length(id) > 0) { diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index 60885abea8b..b9caaff2c9d 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -29,7 +29,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date overwrite = FALSE, verbose = FALSE, ...) { library(PEcAn.utils) - PEcAn.utils::logger.info("START met2model.SIPNET") + PEcAn.logger::logger.info("START met2model.SIPNET") start_date <- as.POSIXlt(start_date, tz = "UTC") end_date <- as.POSIXlt(end_date, tz = "UTC") out.file <- paste(in.prefix, strptime(start_date, "%Y-%m-%d"), @@ -46,7 +46,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date enddate = end_date, dbfile.name = out.file, stringsAsFactors = FALSE) - PEcAn.utils::logger.info("internal results") + PEcAn.logger::logger.info("internal results") print(results) if (file.exists(out.file.full) && !overwrite) { @@ -71,7 +71,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date for (year in start_year:end_year) { skip <- FALSE - PEcAn.utils::logger.info(year) + PEcAn.logger::logger.info(year) old.file <- file.path(in.path, paste(in.prefix, year, "nc", sep = ".")) @@ -99,7 +99,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date U <- ncvar_get(nc, "eastward_wind") V <- ncvar_get(nc, "northward_wind") ws <- sqrt(U ^ 2 + V ^ 2) - PEcAn.utils::logger.info("wind_speed absent; calculated from eastward_wind and northward_wind") + PEcAn.logger::logger.info("wind_speed absent; calculated from eastward_wind and northward_wind") } Rain <- ncvar_get(nc, "precipitation_flux") @@ -109,7 +109,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date PAR <- try(ncvar_get(nc, "surface_downwelling_photosynthetic_photon_flux_in_air")) ## in mol/m2/s if (!is.numeric(PAR)) { PAR <- SW * 0.45 - PEcAn.utils::logger.info("surface_downwelling_photosynthetic_photon_flux_in_air absent; PAR set to SW * 0.45") + PEcAn.logger::logger.info("surface_downwelling_photosynthetic_photon_flux_in_air absent; PAR set to SW * 0.45") } soilT <- try(ncvar_get(nc, "soil_temperature")) @@ -119,7 +119,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date filt <- exp(-(1:length(Tair)) / tau) filt <- (filt / sum(filt)) soilT <- convolve(Tair, filt) - 273.15 - PEcAn.utils::logger.info("soil_temperature absent; soilT approximated from Tair") + PEcAn.logger::logger.info("soil_temperature absent; soilT approximated from Tair") } else { soilT <- soilT - 273.15 } @@ -128,14 +128,14 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date VPD <- try(ncvar_get(nc, "water_vapor_saturation_deficit")) ## in Pa if (!is.numeric(VPD)) { VPD <- SVP * (1 - qair2rh(Qair, Tair - 273.15)) - PEcAn.utils::logger.info("water_vapor_saturation_deficit absent; VPD calculated from Qair, Tair, and SVP (saturation vapor pressure) ") + PEcAn.logger::logger.info("water_vapor_saturation_deficit absent; VPD calculated from Qair, Tair, and SVP (saturation vapor pressure) ") } e_a <- SVP - VPD VPDsoil <- udunits2::ud.convert(get.es(soilT), "millibar", "Pa") * (1 - qair2rh(Qair, soilT)) ncdf4::nc_close(nc) } else { - PEcAn.utils::logger.info("Skipping to next year") + PEcAn.logger::logger.info("Skipping to next year") next } @@ -183,7 +183,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date hr[rng] <- rep(seq(0, length = 86400 / dt, by = dt/86400 * 24), 366)[1:length(rng)] } if (skip) { - PEcAn.utils::logger.info("Skipping to next year") + PEcAn.logger::logger.info("Skipping to next year") next } @@ -225,7 +225,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date write.table(out, out.file.full, quote = FALSE, sep = "\t", row.names = FALSE, col.names = FALSE) return(invisible(results)) } else { - PEcAn.utils::logger.info("NO MET TO OUTPUT") + PEcAn.logger::logger.info("NO MET TO OUTPUT") return(invisible(NULL)) } } # met2model.SIPNET diff --git a/models/sipnet/R/write.configs.SIPNET.R b/models/sipnet/R/write.configs.SIPNET.R index 7b7a6c98228..8e607acd963 100644 --- a/models/sipnet/R/write.configs.SIPNET.R +++ b/models/sipnet/R/write.configs.SIPNET.R @@ -361,13 +361,18 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs } else if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path - IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = SLA)) - - if(!is.null(IC.pools)){ - IC.nc <- ncdf4::nc_open(IC.path) #for additional variables specific to SIPNET - ## plantWoodInit gC/m2 - if ("wood" %in% names(IC.pools)) { - param[which(param[, 1] == "plantWoodInit"), 2] <- IC.pools$wood * 1000 #from PEcAn standard AbvGrndWood kgC/m2 + IC.nc <- try(ncdf4::nc_open(IC.path)) + if(class(IC.nc) != "try-error"){ + ## plantWoodInit gC/m2 + AbvGrndWood <- try(ncdf4::ncvar_get(IC.nc,"AbvGrndWood"),silent = TRUE) + if (!is.na(AbvGrndWood) && is.numeric(AbvGrndWood)) { + fineRootFrac <- param[which(param[, 1] == "fineRootFrac"), 2] + coarseRootFrac <- param[which(param[, 1] == "coarseRootFrac"), 2] + plantWood <- AbvGrndWood/(1-(fineRootFrac+coarseRootFrac)) #inflate plantWood to include belowground + param[which(param[, 1] == "plantWoodInit"), 2] <- plantWood * 1000 #PEcAn standard AbvGrndWood kgC/m2 + } + else{ + #try back-calculate from LAI,sla, and total biomass? where is total biomass? } ## laiInit m2/m2 lai <- try(ncdf4::ncvar_get(IC.nc,"LAI"),silent = TRUE) @@ -375,12 +380,14 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs param[which(param[, 1] == "laiInit"), 2] <- lai } ## litterInit gC/m2 - if ("litter" %in% names(IC.pools)) { - param[which(param[, 1] == "litterInit"), 2] <- IC.pools$litter * 1000 #from PEcAn standard litter_carbon_content kg/m2 + litter <- try(ncdf4::ncvar_get(IC.nc,"litter_carbon_content"),silent = TRUE) + if (!is.na(litter) && is.numeric(litter)) { + param[which(param[, 1] == "litterInit"), 2] <- litter * 1000 #PEcAn standard litter_carbon_content kg/m2 } ## soilInit gC/m2 - if ("soil" %in% names(IC.pools)) { - param[which(param[, 1] == "soilInit"), 2] <- sum(IC.pools$soil) * 1000 #from PEcAn standard TotSoilCarb kg C/m2 + soil <- try(ncdf4::ncvar_get(IC.nc,"soil_carbon_content"),silent = TRUE) + if (!is.na(soil) && is.numeric(soil)) { + param[which(param[, 1] == "soilInit"), 2] <- sum(soil) * 1000 #PEcAn standard TotSoilCarb kg C/m2 } ## soilWFracInit fraction soilWFrac <- try(ncdf4::ncvar_get(IC.nc,"SoilMoistFrac"),silent = TRUE) @@ -393,16 +400,19 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs ## snowInit cm water equivalent snow = try(ncdf4::ncvar_get(IC.nc,"SWE"),silent = TRUE) if (!is.na(snow) && is.numeric(snow)) { - param[which(param[, 1] == "snowInit"), 2] <- snow*0.1 #from PEcAn standard SWE kg/m2 (1kg = 1mm) + param[which(param[, 1] == "snowInit"), 2] <- snow*0.1 #PEcAn standard SWE kg/m2 (1kg = 1mm) } ## microbeInit mgC/g soil microbe <- try(ncdf4::ncvar_get(IC.nc,"Microbial Biomass C"),silent = TRUE) if (!is.na(microbe) && is.numeric(microbe)) { param[which(param[, 1] == "microbeInit"), 2] <- microbe * .001 #BETY Microbial Biomass C mg C kg-1 soil } + + #close file ncdf4::nc_close(IC.nc) - }else{ - PEcAn.utils::logger.error("Bad initial conditions filepath; keeping defaults") + } + else{ + PEcAn.logger::logger.error("Bad initial conditions filepath; kept defaults") } }else{ #some stuff about IC file that we can give in lieu of actual ICs diff --git a/modules/assim.batch/R/helpers.R b/modules/assim.batch/R/helpers.R index 6f7aa84fcc1..c2af6142ca8 100644 --- a/modules/assim.batch/R/helpers.R +++ b/modules/assim.batch/R/helpers.R @@ -1,6 +1,6 @@ stop <- function(...) { if (requireNamespace("PEcAn.utils")) { - PEcAn.utils::logger.severe(...) + PEcAn.logger::logger.severe(...) } else { stop(...) } @@ -8,7 +8,7 @@ stop <- function(...) { warning <- function(...) { if (requireNamespace("PEcAn.utils")) { - PEcAn.utils::logger.warn(...) + PEcAn.logger::logger.warn(...) } else { warning(...) } @@ -16,7 +16,7 @@ warning <- function(...) { message <- function(...) { if (requireNamespace("PEcAn.utils")) { - PEcAn.utils::logger.info(...) + PEcAn.logger::logger.info(...) } else { message(...) } diff --git a/modules/benchmark/R/calc_benchmark.R b/modules/benchmark/R/calc_benchmark.R index e851be623d2..d52dc73d261 100644 --- a/modules/benchmark/R/calc_benchmark.R +++ b/modules/benchmark/R/calc_benchmark.R @@ -41,7 +41,7 @@ calc_benchmark <- function(settings, bety) { ", ",settings$model$id,", ",settings$info$userid, ", 1000000001 ) RETURNING *;"), bety$con) }else if(dim(bm.ensemble)[1] >1){ - PEcAn.utils::logger.error("Duplicate record entries in benchmarks_ensembles") + PEcAn.logger::logger.error("Duplicate record entries in benchmarks_ensembles") } # --------------------------------------------------------------------------------------------- # @@ -168,7 +168,7 @@ calc_benchmark <- function(settings, bety) { "(score, benchmarks_ensemble_id, benchmark_id, metric_id) VALUES ", "('",score,"',",bm.ensemble$id,", ",bm$id,",",metric.id,")"),bety$con) }else if(dim(score.entry)[1] >1){ - PEcAn.utils::logger.error("Duplicate record entries in scores") + PEcAn.logger::logger.error("Duplicate record entries in scores") } } results.list <- append(results.list, list(out.calc_metrics[["benchmarks"]])) diff --git a/modules/benchmark/R/create_BRR.R b/modules/benchmark/R/create_BRR.R index 1d41b9bcd71..1084362b6dc 100644 --- a/modules/benchmark/R/create_BRR.R +++ b/modules/benchmark/R/create_BRR.R @@ -40,7 +40,7 @@ create_BRR <- function(ens_wf, con, user_id = ""){ "VALUES(",ens_wf$model_id,", '",settings_xml,"' , ",user_id, ") RETURNING *;"),con) }else if(dim(ref_run)[1] > 1){# There shouldn't be more than one reference run with the same settings - PEcAn.utils::logger.error("There is more than one reference run in the database with these settings. Review for duplicates. ") + PEcAn.logger::logger.error("There is more than one reference run in the database with these settings. Review for duplicates. ") } BRR <- ref_run %>% rename(.,reference_run_id = id) return(BRR) diff --git a/modules/benchmark/R/define_benchmark.R b/modules/benchmark/R/define_benchmark.R index a7b3c468a8c..e146a5ccd79 100644 --- a/modules/benchmark/R/define_benchmark.R +++ b/modules/benchmark/R/define_benchmark.R @@ -35,7 +35,7 @@ define_benchmark <- function(settings, bety){ BRR <- tbl(bety,"reference_runs") %>% filter(id == bm_ens$reference_run_id) %>% rename(reference_run_id = id) %>% collect() }else if(dim(bm_ens)[1] > 1){ # There shouldn't be more than one reference run per run - PEcAn.utils::logger.error("There is more than one reference run in the database for this ensemble id. Review for duplicates. ") + PEcAn.logger::logger.error("There is more than one reference run in the database for this ensemble id. Review for duplicates. ") } # add the ref_run id, remove the ensemble_id bm.settings$reference_run_id <- BRR$reference_run_id @@ -63,7 +63,7 @@ define_benchmark <- function(settings, bety){ benchmark$site_id, settings$info$userid) bm <- db.query(cmd, bety$con) }else if(dim(bm)[1] >1){ - PEcAn.utils::logger.error("Duplicate record entries in benchmarks") + PEcAn.logger::logger.error("Duplicate record entries in benchmarks") } @@ -84,7 +84,7 @@ define_benchmark <- function(settings, bety){ bm$id, bm.settings$reference_run_id) db.query(cmd, bety$con) }else if(dim(bmBRR)[1] > 1){ - PEcAn.utils::logger.error("Duplicate record entries in benchmarks_benchmarks_reference_runs") + PEcAn.logger::logger.error("Duplicate record entries in benchmarks_benchmarks_reference_runs") } # Retrieve/create benchmarks_metrics record @@ -98,7 +98,7 @@ define_benchmark <- function(settings, bety){ bm$id, benchmark$metrics[[j]]) db.query(cmd, bety$con) }else if(dim(bmmetric)[1] > 1){ - PEcAn.utils::logger.error("Duplicate record entries in benchmarks_metrics") + PEcAn.logger::logger.error("Duplicate record entries in benchmarks_metrics") } } diff --git a/modules/benchmark/R/load_data.R b/modules/benchmark/R/load_data.R index 4703e1be8bc..fd348a22c30 100644 --- a/modules/benchmark/R/load_data.R +++ b/modules/benchmark/R/load_data.R @@ -43,13 +43,13 @@ load_data <- function(data.path, format, start_year = NA, end_year = NA, site = converted.data.path <- convert_file(url = "https://bd-api.ncsa.illinois.edu", input_filename = data.path, output = "csv", output_path = output_path, token = token) if (is.na(converted.data.path)){ - PEcAn.utils::logger.error("Converted file was not returned from Brown Dog") + PEcAn.logger::logger.error("Converted file was not returned from Brown Dog") } #not doing anything about mimetypes not convertible by BD right now fcn <- match.fun("load_csv") data.path <- converted.data.path } else { - PEcAn.utils::logger.warn("Brown Dog is currently unable to perform conversion from ",mimetype," to a PEcAn usable format") + PEcAn.logger::logger.warn("Brown Dog is currently unable to perform conversion from ",mimetype," to a PEcAn usable format") } vars = format$vars$input_name[c(vars.used.index, time.row)] @@ -91,7 +91,7 @@ load_data <- function(data.path, format, start_year = NA, end_year = NA, site = out[col] <- as.vector(misc.convert(x, u1, u2)) # Betsy: Adding this because misc.convert returns vector with attributes original agrument x, which causes problems later colnames(out)[col] <- vars_used$pecan_name[i] } else { - PEcAn.utils::logger.warn(paste("Units cannot be converted. Removing variable. please check the units of",vars_used$input_name[i])) + PEcAn.logger::logger.warn(paste("Units cannot be converted. Removing variable. please check the units of",vars_used$input_name[i])) out<-out[,!names(out) %in% c(vars_used$input_name[i])] vars_used<-vars_used[!names(vars_used) %in% c(vars_used$input_name[i],vars_used$pecan_name[i]),] } @@ -111,7 +111,7 @@ load_data <- function(data.path, format, start_year = NA, end_year = NA, site = tz = site$time_zone }else{ tz = "UTC" - PEcAn.utils::logger.warn("No site timezone. Assuming input time zone is UTC. This may be incorrect.") + PEcAn.logger::logger.warn("No site timezone. Assuming input time zone is UTC. This may be incorrect.") } out$posix <- strptime(apply(y, 1, function(x) paste(x, collapse = " ")), diff --git a/modules/benchmark/R/load_netcdf.R b/modules/benchmark/R/load_netcdf.R index 8e3a05089b5..ea85218ae05 100644 --- a/modules/benchmark/R/load_netcdf.R +++ b/modules/benchmark/R/load_netcdf.R @@ -44,7 +44,7 @@ load_x_netcdf <- function(data.path, format, site, vars = NULL) { } # throw error if can't parse time format if (is.na(date.origin)) { - PEcAn.utils::logger.error("All time formats failed to parse. No formats found.") + PEcAn.logger::logger.error("All time formats failed to parse. No formats found.") } diff --git a/modules/benchmark/R/metric_AME.R b/modules/benchmark/R/metric_AME.R index 6c38387e2c7..805d54dcbf8 100644 --- a/modules/benchmark/R/metric_AME.R +++ b/modules/benchmark/R/metric_AME.R @@ -6,6 +6,6 @@ ##' @author Betsy Cowdery metric_AME <- function(dat, ...) { - PEcAn.utils::logger.info("Metric: Absolute Maximum Error") + PEcAn.logger::logger.info("Metric: Absolute Maximum Error") return(max(abs(dat$model - dat$obvs),na.rm = TRUE)) } # metric_AME diff --git a/modules/benchmark/R/metric_Frechet.R b/modules/benchmark/R/metric_Frechet.R index 9aee40d0404..704b133c30f 100644 --- a/modules/benchmark/R/metric_Frechet.R +++ b/modules/benchmark/R/metric_Frechet.R @@ -6,7 +6,7 @@ ##' @author Betsy Cowdery metric_Frechet <- function(dat, ...) { - PEcAn.utils::logger.info("Metric: Frechet Distance") + PEcAn.logger::logger.info("Metric: Frechet Distance") Fdist <- SimilarityMeasures::Frechet(as.matrix(dat$obvs), as.matrix(dat$model)) return(Fdist) } # metric_Frechet diff --git a/modules/benchmark/R/metric_MAE.R b/modules/benchmark/R/metric_MAE.R index bb766435944..03229d1f0b5 100644 --- a/modules/benchmark/R/metric_MAE.R +++ b/modules/benchmark/R/metric_MAE.R @@ -6,6 +6,6 @@ ##' @author Betsy Cowdery ##' metric_MAE <- function(dat, ...) { - PEcAn.utils::logger.info("Metric: Mean Absolute Error") + PEcAn.logger::logger.info("Metric: Mean Absolute Error") return(mean(abs(dat$model - dat$obvs),na.rm=TRUE)) } # metric_MAE diff --git a/modules/benchmark/R/metric_MSE.R b/modules/benchmark/R/metric_MSE.R index 407785510e7..1ace772a42f 100644 --- a/modules/benchmark/R/metric_MSE.R +++ b/modules/benchmark/R/metric_MSE.R @@ -6,6 +6,6 @@ ##' @author Betsy Cowdery metric_MSE <- function(dat, ...) { - PEcAn.utils::logger.info("Metric: Mean Square Error") + PEcAn.logger::logger.info("Metric: Mean Square Error") return(mean((dat$model - dat$obvs) ^ 2,na.rm=TRUE)) } # metric_MSE diff --git a/modules/benchmark/R/metric_PPMC.R b/modules/benchmark/R/metric_PPMC.R index deb93076f87..f63141ec9a3 100644 --- a/modules/benchmark/R/metric_PPMC.R +++ b/modules/benchmark/R/metric_PPMC.R @@ -6,7 +6,7 @@ ##' @author Betsy Cowdery metric_PPMC <- function(dat, ...) { - PEcAn.utils::logger.info("Metric: Pearson Product Moment Correlation") + PEcAn.logger::logger.info("Metric: Pearson Product Moment Correlation") numer <- sum((dat$obvs - mean(dat$obvs)) * (dat$model - mean(dat$model))) denom <- sqrt(sum((dat$obvs - mean(dat$obvs)) ^ 2)) * sqrt(sum((dat$model - mean(dat$model)) ^ 2)) return(numer / denom) diff --git a/modules/benchmark/R/metric_R2.R b/modules/benchmark/R/metric_R2.R index 844e0cc9e03..923dce45d54 100644 --- a/modules/benchmark/R/metric_R2.R +++ b/modules/benchmark/R/metric_R2.R @@ -6,7 +6,7 @@ ##' @author Betsy Cowdery metric_R2 <- function(dat, ...) { - PEcAn.utils::logger.info("Metric: Coefficient of Determination (R2)") + PEcAn.logger::logger.info("Metric: Coefficient of Determination (R2)") numer <- sum((dat$obvs - mean(dat$obvs)) * (dat$model - mean(dat$model))) denom <- sqrt(sum((dat$obvs - mean(dat$obvs)) ^ 2)) * sqrt(sum((dat$model - mean(dat$model)) ^ 2)) return((numer / denom) ^ 2) diff --git a/modules/benchmark/R/metric_RAE.R b/modules/benchmark/R/metric_RAE.R index 53647abb77d..79104be8fbf 100644 --- a/modules/benchmark/R/metric_RAE.R +++ b/modules/benchmark/R/metric_RAE.R @@ -6,7 +6,7 @@ ##' @author Betsy Cowdery metric_RAE <- function(dat, ...) { - PEcAn.utils::logger.info("Metric: Relative Absolute Error") + PEcAn.logger::logger.info("Metric: Relative Absolute Error") numer <- mean(abs(dat$obvs - dat$model)) denom <- mean(abs(dat$obvs - mean(dat$obvs))) return(numer/denom) diff --git a/modules/benchmark/R/metric_RMSE.R b/modules/benchmark/R/metric_RMSE.R index 9af044b7fd7..6ae45498b82 100644 --- a/modules/benchmark/R/metric_RMSE.R +++ b/modules/benchmark/R/metric_RMSE.R @@ -6,6 +6,6 @@ ##' @author Betsy Cowdery metric_RMSE <- function(dat, ...) { - PEcAn.utils::logger.info("Metric: Root Mean Square Error") + PEcAn.logger::logger.info("Metric: Root Mean Square Error") return(sqrt(mean((dat$model - dat$obvs) ^ 2,na.rm=TRUE))) } # metric_RMSE diff --git a/modules/benchmark/R/metric_cor.R b/modules/benchmark/R/metric_cor.R index 97d2c81200d..26780eb757a 100644 --- a/modules/benchmark/R/metric_cor.R +++ b/modules/benchmark/R/metric_cor.R @@ -6,6 +6,6 @@ ##' @author Mike Dietze metric_cor <- function(dat, ...) { - PEcAn.utils::logger.info("Metric: Correlation Coefficient") + PEcAn.logger::logger.info("Metric: Correlation Coefficient") return(cor(dat$model,dat$obvs,use ="pairwise.complete.obs")) } # metric_cor diff --git a/modules/benchmark/R/metric_lmDiag_plot.R b/modules/benchmark/R/metric_lmDiag_plot.R index 7b42e408098..5519f4f6ec6 100644 --- a/modules/benchmark/R/metric_lmDiag_plot.R +++ b/modules/benchmark/R/metric_lmDiag_plot.R @@ -5,7 +5,7 @@ ##' ##' @author Betsy Cowdery metric_lmDiag_plot <- function(metric_dat, var, filename = NA, draw.plot = FALSE) { - PEcAn.utils::logger.info("Metric: Linear Regression Diagnostic Plot") + PEcAn.logger::logger.info("Metric: Linear Regression Diagnostic Plot") fit <- lm(metric_dat[, 1] ~ metric_dat[, 2]) diff --git a/modules/benchmark/R/metric_residual_plot.R b/modules/benchmark/R/metric_residual_plot.R index bb3aa65ed1a..8c27255d91b 100644 --- a/modules/benchmark/R/metric_residual_plot.R +++ b/modules/benchmark/R/metric_residual_plot.R @@ -5,7 +5,7 @@ ##' ##' @author Betsy Cowdery metric_residual_plot <- function(dat, var, filename = NA, draw.plot = FALSE) { - PEcAn.utils::logger.info("Metric: Residual Plot") + PEcAn.logger::logger.info("Metric: Residual Plot") dat$time <- lubridate::year(as.Date(as.character(dat$time), format = "%Y")) dat$diff <- abs(dat$model - dat$obvs) diff --git a/modules/benchmark/R/metric_scatter_plot.R b/modules/benchmark/R/metric_scatter_plot.R index 73fa8e45734..955c86f5606 100644 --- a/modules/benchmark/R/metric_scatter_plot.R +++ b/modules/benchmark/R/metric_scatter_plot.R @@ -7,7 +7,7 @@ ##' @author Betsy Cowdery metric_scatter_plot <- function(metric_dat, var, filename = NA, draw.plot = is.na(filename)) { - PEcAn.utils::logger.info("Metric: Scatter Plot") + PEcAn.logger::logger.info("Metric: Scatter Plot") p <- ggplot2::ggplot(data = metric_dat) p <- p + ggplot2::geom_point(aes(x = model, y = obvs), size = 4) diff --git a/modules/benchmark/R/metric_timeseries_plot.R b/modules/benchmark/R/metric_timeseries_plot.R index 93690bd9963..15ed08d3e59 100644 --- a/modules/benchmark/R/metric_timeseries_plot.R +++ b/modules/benchmark/R/metric_timeseries_plot.R @@ -7,12 +7,12 @@ ##' @author Betsy Cowdery metric_timeseries_plot <- function(metric_dat, var, filename = NA, draw.plot = is.na(filename)) { - PEcAn.utils::logger.info("Metric: Timeseries Plot") + PEcAn.logger::logger.info("Metric: Timeseries Plot") # Attempt at getting around the fact that time can be annual and thus as.Date won't work date.time <- try(as.Date(metric_dat$time), silent = TRUE) if (class(date.time) == "try-error"){ - PEcAn.utils::logger.warn("Can't coerce time column to Date format, attempting plot anyway") + PEcAn.logger::logger.warn("Can't coerce time column to Date format, attempting plot anyway") }else{ metric_dat$time <- date.time } diff --git a/modules/benchmark/R/read_settings_BRR.R b/modules/benchmark/R/read_settings_BRR.R index db0896d13b3..af1a4576833 100644 --- a/modules/benchmark/R/read_settings_BRR.R +++ b/modules/benchmark/R/read_settings_BRR.R @@ -13,7 +13,7 @@ read_settings_BRR <- function(settings){ # Check database connection if (is.null(settings$database$bety)) { - PEcAn.utils::logger.info("No databasse connection, can't get run information.") + PEcAn.logger::logger.info("No databasse connection, can't get run information.") return (settings) } diff --git a/modules/data.atmosphere/R/download.CRUNCEP_Global.R b/modules/data.atmosphere/R/download.CRUNCEP_Global.R index 581f01b1b92..44e1743336f 100644 --- a/modules/data.atmosphere/R/download.CRUNCEP_Global.R +++ b/modules/data.atmosphere/R/download.CRUNCEP_Global.R @@ -26,7 +26,7 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l CRUNCEP_start <- 1901 CRUNCEP_end <- 2010 if (start_year < CRUNCEP_start | end_year > CRUNCEP_end) { - PEcAn.utils::logger.severe(sprintf('Input year range (%d:%d) exceeds the CRUNCEP range (%d:%d)', + PEcAn.logger::logger.severe(sprintf('Input year range (%d:%d) exceeds the CRUNCEP range (%d:%d)', start_year, end_year, CRUNCEP_start, CRUNCEP_end)) } @@ -77,7 +77,7 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l next } - PEcAn.utils::logger.info(paste("Downloading",loc.file)) + PEcAn.logger::logger.info(paste("Downloading",loc.file)) ## Create dimensions lat <- ncdf4::ncdim_def(name = "latitude", units = "degree_north", vals = lat.in, create_dimvar = TRUE) lon <- ncdf4::ncdim_def(name = "longitude", units = "degree_east", vals = lon.in, create_dimvar = TRUE) @@ -94,7 +94,7 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l ## get data off OpenDAP for (j in seq_len(nrow(var))) { dap_file <- paste0(dap_base, var$DAP.name[j], "_", year, "_v1.nc4") - PEcAn.utils::logger.info(dap_file) + PEcAn.logger::logger.info(dap_file) # This throws an error if file not found dap <- ncdf4::nc_open(dap_file) diff --git a/modules/data.atmosphere/R/download.Fluxnet2015.R b/modules/data.atmosphere/R/download.Fluxnet2015.R index e60c794cc4d..6234ca9da63 100644 --- a/modules/data.atmosphere/R/download.Fluxnet2015.R +++ b/modules/data.atmosphere/R/download.Fluxnet2015.R @@ -42,17 +42,17 @@ download.Fluxnet2015 <- function(sitename, outfolder, start_date, end_date, # test to see that we got back a FTP if (is.null(ftplink)) { - PEcAn.utils::logger.severe("Could not get information about", site, ".", "Is this an Fluxnet2015 site?") + PEcAn.logger::logger.severe("Could not get information about", site, ".", "Is this an Fluxnet2015 site?") } # get start and end year of data from filename syear <- as.numeric(substr(ftplink, nchar(ftplink) - 16, nchar(ftplink) - 13)) eyear <- as.numeric(substr(ftplink, nchar(ftplink) - 11, nchar(ftplink) - 8)) if (start_year > eyear) { - PEcAn.utils::logger.severe("Start_Year", start_year, "exceeds end of record ", eyear, " for ", site) + PEcAn.logger::logger.severe("Start_Year", start_year, "exceeds end of record ", eyear, " for ", site) } if (end_year < syear) { - PEcAn.utils::logger.severe("End_Year", end_year, "precedes start of record ", syear, " for ", site) + PEcAn.logger::logger.severe("End_Year", end_year, "precedes start of record ", syear, " for ", site) } # get zip and csv filenames @@ -84,17 +84,17 @@ download.Fluxnet2015 <- function(sitename, outfolder, start_date, end_date, download_file_flag <- TRUE extract_file_flag <- TRUE if (!overwrite && file.exists(output_zip_file)) { - PEcAn.utils::logger.debug("File '", output_zip_file, "' already exists, skipping download") + PEcAn.logger::logger.debug("File '", output_zip_file, "' already exists, skipping download") download_file_flag <- FALSE } if (!overwrite && file.exists(output_csv_file)) { - PEcAn.utils::logger.debug("File '", output_csv_file, "' already exists, skipping extraction.") + PEcAn.logger::logger.debug("File '", output_csv_file, "' already exists, skipping extraction.") download_file_flag <- FALSE extract_file_flag <- FALSE file_timestep <- "HH" } else { if (!overwrite && file.exists(output_csv_file_hr)) { - PEcAn.utils::logger.debug("File '", output_csv_file_hr, "' already exists, skipping extraction.") + PEcAn.logger::logger.debug("File '", output_csv_file_hr, "' already exists, skipping extraction.") download_file_flag <- FALSE extract_file_flag <- FALSE file_timestep <- "HR" @@ -107,7 +107,7 @@ download.Fluxnet2015 <- function(sitename, outfolder, start_date, end_date, extract_file_flag <- TRUE download.file(ftplink, output_zip_file) if (!file.exists(output_zip_file)) { - PEcAn.utils::logger.severe("FTP did not download ", output_zip_file, " from ", ftplink) + PEcAn.logger::logger.severe("FTP did not download ", output_zip_file, " from ", ftplink) } } if (extract_file_flag) { @@ -120,12 +120,12 @@ download.Fluxnet2015 <- function(sitename, outfolder, start_date, end_date, output_csv_file <- output_csv_file_hr outcsvname <- outcsvname_hr } else { - PEcAn.utils::logger.severe("Half-hourly or Hourly data file was not found in ", output_zip_file) + PEcAn.logger::logger.severe("Half-hourly or Hourly data file was not found in ", output_zip_file) } } unzip(output_zip_file, outcsvname, exdir = outfolder) if (!file.exists(output_csv_file)) { - PEcAn.utils::logger.severe("ZIP file ", output_zip_file, " did not contain CSV file ", outcsvname) + PEcAn.logger::logger.severe("ZIP file ", output_zip_file, " did not contain CSV file ", outcsvname) } } diff --git a/modules/data.atmosphere/R/download.FluxnetLaThuile.R b/modules/data.atmosphere/R/download.FluxnetLaThuile.R index c314aec25b5..3d50f6c2f02 100644 --- a/modules/data.atmosphere/R/download.FluxnetLaThuile.R +++ b/modules/data.atmosphere/R/download.FluxnetLaThuile.R @@ -71,7 +71,7 @@ download.FluxnetLaThuile <- function(sitename, outfolder, start_date, end_date, # see if file exists if (file.exists(outputfile) && !overwrite) { - PEcAn.utils::logger.debug("File '", outputfile, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", outputfile, "' already exists, skipping to next file.") next } diff --git a/modules/data.atmosphere/R/download.GLDAS.R b/modules/data.atmosphere/R/download.GLDAS.R index 3c2c7bf0941..7c0aaf7cbfc 100644 --- a/modules/data.atmosphere/R/download.GLDAS.R +++ b/modules/data.atmosphere/R/download.GLDAS.R @@ -25,7 +25,7 @@ download.GLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon GLDAS_start <- 1948 if (start_year < GLDAS_start) { - PEcAn.utils::logger.severe(sprintf('Input year range (%d:%d) exceeds the GLDAS range (%d:present)', + PEcAn.logger::logger.severe(sprintf('Input year range (%d:%d) exceeds the GLDAS range (%d:present)', start_year, end_year, GLDAS_start)) } diff --git a/modules/data.atmosphere/R/download.NARR.R b/modules/data.atmosphere/R/download.NARR.R index c909dbc80b0..7892dfa6e3e 100644 --- a/modules/data.atmosphere/R/download.NARR.R +++ b/modules/data.atmosphere/R/download.NARR.R @@ -27,7 +27,7 @@ download.NARR <- function(outfolder, start_date, end_date, overwrite = FALSE, ve NARR_start <- 1979 if (start_year < NARR_start) { - PEcAn.utils::logger.severe(sprintf('Input year range (%d:%d) exceeds the NARR range (%d:present)', + PEcAn.logger::logger.severe(sprintf('Input year range (%d:%d) exceeds the NARR range (%d:present)', start_year, end_year, NARR_start)) } @@ -63,13 +63,13 @@ download.NARR <- function(outfolder, start_date, end_date, overwrite = FALSE, ve results$formatname[row] <- "NARR" if (file.exists(new.file) && !overwrite) { - PEcAn.utils::logger.debug("File '", new.file, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping to next file.") next } url <- paste0("ftp://ftp.cdc.noaa.gov/Datasets/NARR/monolevel/", v, ".", year, ".nc") - PEcAn.utils::logger.debug(paste0("Downloading from:\n", url, "\nto:\n", new.file)) + PEcAn.logger::logger.debug(paste0("Downloading from:\n", url, "\nto:\n", new.file)) PEcAn.utils::download.file(url, new.file, method) } } diff --git a/modules/data.atmosphere/R/download.NLDAS.R b/modules/data.atmosphere/R/download.NLDAS.R index 930d815f29c..daac94caba8 100644 --- a/modules/data.atmosphere/R/download.NLDAS.R +++ b/modules/data.atmosphere/R/download.NLDAS.R @@ -26,7 +26,7 @@ download.NLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon NLDAS_start <- 1980 if (start_year < NLDAS_start) { - PEcAn.utils::logger.severe(sprintf('Input year range (%d:%d) exceeds the NLDAS range (%d:present)', + PEcAn.logger::logger.severe(sprintf('Input year range (%d:%d) exceeds the NLDAS range (%d:present)', start_year, end_year, NLDAS_start)) } diff --git a/modules/data.atmosphere/R/extract.nc.module.R b/modules/data.atmosphere/R/extract.nc.module.R index 0e268bc67f3..ce6d348fde5 100644 --- a/modules/data.atmosphere/R/extract.nc.module.R +++ b/modules/data.atmosphere/R/extract.nc.module.R @@ -9,7 +9,7 @@ outfolder <- file.path(dir, paste0(met, "_CF_site_", str_ns)) } else { if(is.null(host$folder)){ - PEcAn.utils::logger.severe("host$folder required when running extract.nc.module for remote servers") + PEcAn.logger::logger.severe("host$folder required when running extract.nc.module for remote servers") } else { outfolder <- file.path(host$folder, paste0(met, "_CF_site_", str_ns)) } diff --git a/modules/data.atmosphere/R/merge.met.variable.R b/modules/data.atmosphere/R/merge.met.variable.R index 2c6e6a1fe79..0fe41833cb8 100644 --- a/modules/data.atmosphere/R/merge.met.variable.R +++ b/modules/data.atmosphere/R/merge.met.variable.R @@ -58,12 +58,12 @@ merge_met_variable <- function(in.path,in.prefix,start_date, end_date, merge.fil # check dates if(lubridate::year(merge.time.std[1]) > start_year){ - PEcAn.utils::logger.error("merge.time > start_year", merge.time.std[1],start_date) + PEcAn.logger::logger.error("merge.time > start_year", merge.time.std[1],start_date) ncdf4::nc_close(merge.nc) return(NULL) } if(lubridate::year(tail(merge.time.std,1)) < end_year){ - PEcAn.utils::logger.error("merge.time < end_year", tail(merge.time.std,1),end_date) + PEcAn.logger::logger.error("merge.time < end_year", tail(merge.time.std,1),end_date) ncdf4::nc_close(merge.nc) return(NULL) } @@ -108,7 +108,7 @@ merge_met_variable <- function(in.path,in.prefix,start_date, end_date, merge.fil nc <- ncdf4::nc_open(old.file,write = TRUE) if(merge.vars[1] %in% names(nc$var)) { - PEcAn.utils::logger.info("variable already exists",merge.vars[1]) + PEcAn.logger::logger.info("variable already exists",merge.vars[1]) ncdf4::nc_close(nc) next } diff --git a/modules/data.atmosphere/R/met.process.R b/modules/data.atmosphere/R/met.process.R index 9a8d9a45a94..fabf03cb5aa 100644 --- a/modules/data.atmosphere/R/met.process.R +++ b/modules/data.atmosphere/R/met.process.R @@ -30,7 +30,7 @@ met.process <- function(site, input_met, start_date, end_date, model, # get met source and potentially determine where to start in the process if(is.null(input_met$source)){ if(is.null(input_met$id)){ - PEcAn.utils::logger.warn("met.process only has a path provided, assuming path is model driver and skipping processing") + PEcAn.logger::logger.warn("met.process only has a path provided, assuming path is model driver and skipping processing") return(input_met$path) }else { logger.warn("No met source specified") @@ -259,7 +259,7 @@ met.process <- function(site, input_met, start_date, end_date, model, model.file <- file.path(model.file.info$file_path,model.file.info$file_name) } else { - PEcAn.utils::logger.info("ready.id",ready.id,machine.host) + PEcAn.logger::logger.info("ready.id",ready.id,machine.host) model.id <- dbfile.check("Input", ready.id, con)#, hostname=machine.host) if(is.null(model.id)|length(model.id)==0){ model.file <- input_met$path @@ -268,8 +268,8 @@ met.process <- function(site, input_met, start_date, end_date, model, model.file.info <- db.query(paste0("SELECT * from dbfiles where id = ", model.id$dbfile.id), con) model.file <- file.path(model.file.info$file_path,model.file.info$file_name) } - #PEcAn.utils::logger.info("model.file = ",model.file,input.met) - PEcAn.utils::logger.info("model.file = ",model.file,input_met) + #PEcAn.logger::logger.info("model.file = ",model.file,input.met) + PEcAn.logger::logger.info("model.file = ",model.file,input_met) } diff --git a/modules/data.atmosphere/R/met2CF.FACE.R b/modules/data.atmosphere/R/met2CF.FACE.R index 4920eea5b31..509d780f70d 100644 --- a/modules/data.atmosphere/R/met2CF.FACE.R +++ b/modules/data.atmosphere/R/met2CF.FACE.R @@ -101,7 +101,7 @@ met2CF.FACE <- function(in.path,in.prefix,outfolder,start_date,end_date,input.id vars_used$pecan_name[i], u2)) vals <- misc.convert(x, u1, u2) } else { - PEcAn.utils::logger.error("Units cannot be converted") + PEcAn.logger::logger.error("Units cannot be converted") } } diff --git a/modules/data.atmosphere/R/met2CF.NARR.R b/modules/data.atmosphere/R/met2CF.NARR.R index 6f981aa34ab..fd5dbba414e 100644 --- a/modules/data.atmosphere/R/met2CF.NARR.R +++ b/modules/data.atmosphere/R/met2CF.NARR.R @@ -53,10 +53,10 @@ met2CF.NARR <- function(in.path, in.prefix, outfolder, start_date, end_date, results$formatname[row] <- "CF (regional)" if (file.exists(newfile) && !overwrite) { - PEcAn.utils::logger.debug("File '", newfile, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", newfile, "' already exists, skipping to next file.") next } else { - PEcAn.utils::logger.info("Preparing file '", newfile, "'. ") + PEcAn.logger::logger.info("Preparing file '", newfile, "'. ") } # use tempfile diff --git a/modules/data.atmosphere/R/met2CF.csv.R b/modules/data.atmosphere/R/met2CF.csv.R index f24a265b4e3..d1036c297a0 100644 --- a/modules/data.atmosphere/R/met2CF.csv.R +++ b/modules/data.atmosphere/R/met2CF.csv.R @@ -65,24 +65,24 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form files <- dir(in.path, in.prefix, full.names = TRUE) files <- files[grep("*.csv", files)] if (length(files) == 0) { - PEcAn.utils::logger.warn("No met files named ", in.prefix, "found in ", in.path) + PEcAn.logger::logger.warn("No met files named ", in.prefix, "found in ", in.path) return(NULL) } if (length(files) > 1) { - PEcAn.utils::logger.warn(length(files), ' met files found. Using first file: ', files[1]) + PEcAn.logger::logger.warn(length(files), ' met files found. Using first file: ', files[1]) files <- files[1] } # get lat/lon from format.vars if not passed directly if (missing(lat) || is.null(lat)) { - PEcAn.utils::logger.debug('Latitude is missing or NULL. Using `format$lat`.') + PEcAn.logger::logger.debug('Latitude is missing or NULL. Using `format$lat`.') lat <- format$lat if (is.null(lat)) { lat <- 0. } } if (missing(lon) || is.null(lon)) { - PEcAn.utils::logger.debug('Longitude is missing or NULL. Using `format$lon`.') + PEcAn.logger::logger.debug('Longitude is missing or NULL. Using `format$lon`.') lon <- format$lon if (is.null(lon)) { lon <- 0. @@ -106,11 +106,11 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form # If all the files already exist, then skip the conversion unless overwrite=TRUE if (!overwrite && all(file.exists(all_files))) { - PEcAn.utils::logger.debug("File '", all_files, "' already exist, skipping.") + PEcAn.logger::logger.debug("File '", all_files, "' already exist, skipping.") } else { # If some of the files already exist, skip those, but still need to read file if (!overwrite && any(file.exists(all_files))) { - PEcAn.utils::logger.debug("Files ", all_files[which(file.exists(all_files))], " already exist, skipping those") + PEcAn.logger::logger.debug("Files ", all_files[which(file.exists(all_files))], " already exist, skipping those") all_years <- all_years[which(!file.exists(all_files))] all_files <- all_files[which(!file.exists(all_files))] } @@ -119,7 +119,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form ## search for NA's after conversion to numeric skiplog <- FALSE if (is.null(format$header)) { - PEcAn.utils::logger.warn("please specify number of header rows in file") + PEcAn.logger::logger.warn("please specify number of header rows in file") header <- FALSE } else if (format$header %in% c(0, 1)) { header <- as.logical(format$header) @@ -153,7 +153,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form tz = format$time_zone }else{ tz = "UTC" - PEcAn.utils::logger.warn("No site timezone. Assuming input time zone is UTC. This may be incorrect.") + PEcAn.logger::logger.warn("No site timezone. Assuming input time zone is UTC. This may be incorrect.") } ##datetime_index <- which(format$vars$bety_name == "datetime") @@ -174,7 +174,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form alldatetime <- as.POSIXct(yyddhhmm) } else { ## Does not match any of the known date formats, add new ones here! - PEcAn.utils::logger.error("datetime column is not specified in format") + PEcAn.logger::logger.error("datetime column is not specified in format") } } else { datetime_raw <- alldat[, format$vars$input_name[datetime_index]] @@ -193,7 +193,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (!missing(start_date) && !missing(end_date)) { availdat <- which(years >= lubridate::year(start_date) & years <= lubridate::year(end_date)) if (length(availdat) == 0) { - PEcAn.utils::logger.severe("Data does not contain output after start_date or before end_date") + PEcAn.logger::logger.severe("Data does not contain output after start_date or before end_date") } alldat <- alldat[availdat, ] alldatetime <- alldatetime[availdat] @@ -213,7 +213,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form this.year <- all_years[i] availdat.year <- which(years == this.year) if (length(availdat.year) == 0) { - PEcAn.utils::logger.debug("File ", all_files, " has no data for year ", this.year) + PEcAn.logger::logger.debug("File ", all_files, " has no data for year ", this.year) next } new.file <- all_files[i] @@ -246,13 +246,13 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for airT by name or column number") + PEcAn.logger::logger.error("Cannot find column location for airT by name or column number") } } ncdf4::ncvar_put(nc, varid = airT.var, vals = met.conv(dat[, arrloc], format$vars$input_units[k], "celsius", "K")) } else { - PEcAn.utils::logger.error("No air temperature found in met file") + PEcAn.logger::logger.error("No air temperature found in met file") } ## air_pressure (Pa) => air_pressure (Pa) @@ -266,7 +266,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for air_pressure by name or column number") + PEcAn.logger::logger.error("Cannot find column location for air_pressure by name or column number") } } ncdf4::ncvar_put(nc, varid = Psurf.var, @@ -286,7 +286,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for co2atm by name or column number") + PEcAn.logger::logger.error("Cannot find column location for co2atm by name or column number") } } ncdf4::ncvar_put(nc, @@ -307,7 +307,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for soilM by name or column number") + PEcAn.logger::logger.error("Cannot find column location for soilM by name or column number") } } ncdf4::ncvar_put(nc, @@ -326,7 +326,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for soilT by name or column number") + PEcAn.logger::logger.error("Cannot find column location for soilT by name or column number") } } ncdf4::ncvar_put(nc, @@ -345,7 +345,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for relative_humidity by name or column number") + PEcAn.logger::logger.error("Cannot find column location for relative_humidity by name or column number") } } ncdf4::ncvar_put(nc, @@ -364,7 +364,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for specific_humidity by name or column number") + PEcAn.logger::logger.error("Cannot find column location for specific_humidity by name or column number") } } ncdf4::ncvar_put(nc, @@ -395,7 +395,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for VPD by name or column number") + PEcAn.logger::logger.error("Cannot find column location for VPD by name or column number") } } ncdf4::ncvar_put(nc, @@ -417,7 +417,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for surface_downwelling_longwave_flux_in_air by name or column number") + PEcAn.logger::logger.error("Cannot find column location for surface_downwelling_longwave_flux_in_air by name or column number") } } ncdf4::ncvar_put(nc, @@ -438,7 +438,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for solar_radiation by name or column number") + PEcAn.logger::logger.error("Cannot find column location for solar_radiation by name or column number") } } ncdf4::ncvar_put(nc, @@ -459,7 +459,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for PAR by name or column number") + PEcAn.logger::logger.error("Cannot find column location for PAR by name or column number") } } ncdf4::ncvar_put(nc, @@ -480,7 +480,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for precipitation_flux by name or column number") + PEcAn.logger::logger.error("Cannot find column location for precipitation_flux by name or column number") } } rain <- dat[, arrloc] @@ -514,7 +514,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for eastward_wind by name or column number") + PEcAn.logger::logger.error("Cannot find column location for eastward_wind by name or column number") } } ncdf4::ncvar_put(nc, @@ -530,7 +530,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for northward_wind by name or column number") + PEcAn.logger::logger.error("Cannot find column location for northward_wind by name or column number") } ncdf4::ncvar_put(nc, varid = Ewind.var, @@ -548,7 +548,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc_wd <- format$vars$column_number[k_wd] } else { - PEcAn.utils::logger.error("Cannot find column location for wind_direction by name or column number") + PEcAn.logger::logger.error("Cannot find column location for wind_direction by name or column number") } } arrloc_ws <- as.character(format$vars$input_name[k_ws]) @@ -556,7 +556,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc_ws <- format$vars$column_number[k_ws] } else { - PEcAn.utils::logger.error("Cannot find column location for wind_speed by name or column number") + PEcAn.logger::logger.error("Cannot find column location for wind_speed by name or column number") } } wind <- met.conv(dat[, arrloc_ws], format$vars$input_units[k_ws], "m s-1", "m s-1") @@ -583,7 +583,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form if (any(colnames(format$vars) == "column_number")) { arrloc <- format$vars$column_number[k] } else { - PEcAn.utils::logger.error("Cannot find column location for Wspd by name or column number") + PEcAn.logger::logger.error("Cannot find column location for Wspd by name or column number") } } ncdf4::ncvar_put(nc, @@ -636,9 +636,9 @@ met.conv <- function(x, orig, bety, CF) { if (udunits2::ud.are.convertible(orig, bety)) { return(udunits2::ud.convert(udunits2::ud.convert(x, orig, bety), bety, CF)) } else { - PEcAn.utils::logger.error(paste("met.conv could not convert", orig, bety, CF)) + PEcAn.logger::logger.error(paste("met.conv could not convert", orig, bety, CF)) } } else { - PEcAn.utils::logger.error(paste("met.conv could not parse units:", orig), "Please check if these units conform to udunits") + PEcAn.logger::logger.error(paste("met.conv could not parse units:", orig), "Please check if these units conform to udunits") } } # met.conv diff --git a/modules/data.atmosphere/R/met2model.module.R b/modules/data.atmosphere/R/met2model.module.R index e832f26aef2..de37093c194 100644 --- a/modules/data.atmosphere/R/met2model.module.R +++ b/modules/data.atmosphere/R/met2model.module.R @@ -25,7 +25,7 @@ outfolder <- file.path(dir, paste0(met, "_", model, "_site_", str_ns)) } else { if(is.null(host$folder)){ - PEcAn.utils::logger.severe("host$folder required when running met2model.module for remote servers") + PEcAn.logger::logger.severe("host$folder required when running met2model.module for remote servers") } else { outfolder <- file.path(host$folder, paste0(met, "_", model, "_site_", str_ns)) } diff --git a/modules/data.atmosphere/R/permute.nc.R b/modules/data.atmosphere/R/permute.nc.R index 3184b8fd129..ee1977a181b 100644 --- a/modules/data.atmosphere/R/permute.nc.R +++ b/modules/data.atmosphere/R/permute.nc.R @@ -45,7 +45,7 @@ permute.nc <- function(in.path, in.prefix, outfolder, start_date, end_date, results$formatname[row] <- "CF (permuted)" if (file.exists(new.file) && !overwrite) { - PEcAn.utils::logger.debug("File '", new.file, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping to next file.") next } diff --git a/modules/data.atmosphere/R/split_wind.R b/modules/data.atmosphere/R/split_wind.R index f421301e389..2f4f1d102c9 100644 --- a/modules/data.atmosphere/R/split_wind.R +++ b/modules/data.atmosphere/R/split_wind.R @@ -53,12 +53,12 @@ split_wind <- function(in.path, in.prefix, start_date, end_date, nc <- ncdf4::nc_open(old.file, write = TRUE) if("eastward_wind" %in% names(nc$var)) { - PEcAn.utils::logger.info("eastward_wind already exists", year_txt) + PEcAn.logger::logger.info("eastward_wind already exists", year_txt) ncdf4::nc_close(nc) next } if(!("wind_speed" %in% names(nc$var))) { - PEcAn.utils::logger.error("wind_speed does not exist", year_txt) + PEcAn.logger::logger.error("wind_speed does not exist", year_txt) ncdf4::nc_close(nc) next } diff --git a/modules/data.land/R/extract_soil_nc.R b/modules/data.land/R/extract_soil_nc.R index f382415f0bd..f215f36a5ce 100644 --- a/modules/data.land/R/extract_soil_nc.R +++ b/modules/data.land/R/extract_soil_nc.R @@ -32,10 +32,10 @@ extract_soil_nc <- function(in.file,outdir,lat,lon){ dlat <- abs(median(diff(soil.lat))) dlon <- abs(median(diff(soil.lon))) if(lat < (min(soil.lat)-dlat) | lat > (max(soil.lat)+dlat)){ - PEcAn.utils::logger.error("site lat out of bounds",lat,range(soil.lat)) + PEcAn.logger::logger.error("site lat out of bounds",lat,range(soil.lat)) } if(lon < (min(soil.lon)-dlon) | lon > (max(soil.lon)+dlon)){ - PEcAn.utils::logger.error("site lon out of bounds",lon,range(soil.lon)) + PEcAn.logger::logger.error("site lon out of bounds",lon,range(soil.lon)) } if(dims[1] == lat.dim){ soil.row <- which.min(abs(lat-soil.lat)) @@ -44,7 +44,7 @@ extract_soil_nc <- function(in.file,outdir,lat,lon){ soil.col <- which.min(abs(lat-soil.lat)) soil.row <- which.min(abs(lon-soil.lon)) } else { - PEcAn.utils::logger.error("could not determine lat/lon dimension order:: ",dims) + PEcAn.logger::logger.error("could not determine lat/lon dimension order:: ",dims) } ## extract raw soil data diff --git a/modules/data.land/R/match_pft.R b/modules/data.land/R/match_pft.R index d1544dad83d..e539cb935e5 100644 --- a/modules/data.land/R/match_pft.R +++ b/modules/data.land/R/match_pft.R @@ -52,7 +52,7 @@ match_pft <- function(bety_species_id, pfts, query = NULL, con = NULL, allow_mis if (nrow(bad) > 0) { for(i in seq_along(nrow(bad))){ error.pft <- translation[translation$bety_species_id == bad$bety_species_id[i],] - PEcAn.utils::logger.warn(paste0("Duplicated species id: ", bad$bety_species_id[i], " under ", paste(error.pft$pft, collapse = ", "))) + PEcAn.logger::logger.warn(paste0("Duplicated species id: ", bad$bety_species_id[i], " under ", paste(error.pft$pft, collapse = ", "))) } } @@ -78,17 +78,17 @@ match_pft <- function(bety_species_id, pfts, query = NULL, con = NULL, allow_mis }else{ latin <- NA } - PEcAn.utils::logger.warn(paste0("Unmatched species: ", ubad[i]," ", latin)) + PEcAn.logger::logger.warn(paste0("Unmatched species: ", ubad[i]," ", latin)) } } ## stop after checking both errors if (nrow(bad) > 0) { - PEcAn.utils::logger.severe("Within BETY PFT table, please address duplicated species and add unmatched species to PFTs.") + PEcAn.logger::logger.severe("Within BETY PFT table, please address duplicated species and add unmatched species to PFTs.") } if(allow_missing == FALSE & length(bad2) > 0){ - PEcAn.utils::logger.severe("Within BETY PFT table, please address duplicated species and add unmatched species to PFTs.") + PEcAn.logger::logger.severe("Within BETY PFT table, please address duplicated species and add unmatched species to PFTs.") } ## Match diff --git a/modules/data.land/R/match_species_id.R b/modules/data.land/R/match_species_id.R index 6f3331257b8..5e400c8cbab 100644 --- a/modules/data.land/R/match_species_id.R +++ b/modules/data.land/R/match_species_id.R @@ -42,7 +42,7 @@ match_species_id <- function(input_codes, format_name = 'custom', bety = NULL, t 'latin_name' = 'scientificname', 'custom' = 'custom') if (!format_name %in% names(formats_dict)) { - PEcAn.utils::logger.severe('format_name "', format_name, '" not found. ', + PEcAn.logger::logger.severe('format_name "', format_name, '" not found. ', 'Please use one of the following: ', paste(names(formats_dict), collapse = ', ')) } @@ -50,12 +50,12 @@ match_species_id <- function(input_codes, format_name = 'custom', bety = NULL, t msg2 <- c('Found the following columns: ', paste(colnames(translation_table), collapse = ', ')) if (!'input_code' %in% colnames(translation_table)) { - PEcAn.utils::logger.severe('Custom translation table must have column "input_code". ', msg2) + PEcAn.logger::logger.severe('Custom translation table must have column "input_code". ', msg2) } else if (!'bety_species_id' %in% colnames(translation_table)) { - PEcAn.utils::logger.severe('Custom translation table must have column "bety_species_id". ', msg2) + PEcAn.logger::logger.severe('Custom translation table must have column "bety_species_id". ', msg2) } else { if (any(grepl('^(genus|species)$', colnames(translation_table)))) { - PEcAn.utils::logger.warn('"genus" or "species" columns found in translation table. ', + PEcAn.logger::logger.warn('"genus" or "species" columns found in translation table. ', 'Because these also match the BETY table, ', 'they will be ignored by the merge, but their names will ', 'be appended with ".translation_table" for disambiguation') @@ -109,7 +109,7 @@ match_species_id <- function(input_codes, format_name = 'custom', bety = NULL, t if(sum(is.na(merge_table$bety_species_id)) > 0){ bad <- unique(merge_table$input_code[is.na(merge_table$bety_species_id)]) - PEcAn.utils::logger.error(paste0("Species for the following code(s) not found : ", paste(bad, collapse = ", "))) + PEcAn.logger::logger.error(paste0("Species for the following code(s) not found : ", paste(bad, collapse = ", "))) } return(merge_table) diff --git a/modules/data.land/R/partition_roots.R b/modules/data.land/R/partition_roots.R index 2d610a76544..29fc521bd12 100644 --- a/modules/data.land/R/partition_roots.R +++ b/modules/data.land/R/partition_roots.R @@ -16,7 +16,7 @@ partition_roots <- function(roots, rtsize){ rtsize_thresh_idx <- which.min(sapply(rtsize-threshold,abs)) rtsize_thresh <- rtsize[rtsize_thresh_idx] if(abs(rtsize_thresh-threshold) > epsilon){ - PEcAn.utils::logger.error(paste("Closest rtsize to fine root threshold of", threshold, "m (", rtsize_thresh, + PEcAn.logger::logger.error(paste("Closest rtsize to fine root threshold of", threshold, "m (", rtsize_thresh, ") is greater than", epsilon, "m off; fine roots can't be partitioned. Please improve rtsize dimensions.")) return(NULL) @@ -25,15 +25,15 @@ partition_roots <- function(roots, rtsize){ fine.roots <- sum(roots[1:rtsize_thresh_idx-1]) coarse.roots <- sum(roots) - fine.roots if(fine.roots >= 0 && coarse.roots >= 0){ - PEcAn.utils::logger.info("Using partitioned root values", fine.roots, "for fine and", coarse.roots, "for coarse.") + PEcAn.logger::logger.info("Using partitioned root values", fine.roots, "for fine and", coarse.roots, "for coarse.") return(list(fine.roots = fine.roots, coarse.roots = coarse.roots)) } else{ - PEcAn.utils::logger.error("Roots could not be partitioned (fine or coarse is less than 0).") + PEcAn.logger::logger.error("Roots could not be partitioned (fine or coarse is less than 0).") return(NULL) } } } else { - PEcAn.utils::logger.error("Inadequate or incorrect number of levels of rtsize associated with roots; please ensure roots and rtsize lengths match and are greater than 1.") + PEcAn.logger::logger.error("Inadequate or incorrect number of levels of rtsize associated with roots; please ensure roots and rtsize lengths match and are greater than 1.") return(NULL) } } \ No newline at end of file diff --git a/modules/data.land/R/pool_ic_list2netcdf.R b/modules/data.land/R/pool_ic_list2netcdf.R index 9539e4f231e..1332adec3d2 100644 --- a/modules/data.land/R/pool_ic_list2netcdf.R +++ b/modules/data.land/R/pool_ic_list2netcdf.R @@ -10,12 +10,12 @@ pool_ic_list2netcdf <- function(input, outdir, siteid){ if(is.null(input$vals) || length(input$vals) == 0){ - PEcAn.utils::logger.severe("Please provide 'vals' list in input with variable names assigned to values") + PEcAn.logger::logger.severe("Please provide 'vals' list in input with variable names assigned to values") } if(is.null(input$dims) || length(input$dims) == 0){ if (any(sapply(input$vals,length) > 1)){ - PEcAn.utils::logger.severe("A variable has length > 1; please provide non-empty 'dims' list in input") + PEcAn.logger::logger.severe("A variable has length > 1; please provide non-empty 'dims' list in input") } } #to do: check diff --git a/modules/data.land/R/soil_process.R b/modules/data.land/R/soil_process.R index 0ccad415449..237161b0cf9 100644 --- a/modules/data.land/R/soil_process.R +++ b/modules/data.land/R/soil_process.R @@ -12,7 +12,7 @@ soil_process <- function(settings, input, dbfiles, overwrite = FALSE,run.local=TRUE){ if(is.null(input$id)){ - PEcAn.utils::logger.severe("currently soil_process requires an input ID to be specified") + PEcAn.logger::logger.severe("currently soil_process requires an input ID to be specified") return(NULL) } diff --git a/modules/data.land/R/soil_utils.R b/modules/data.land/R/soil_utils.R index 98ac108ee13..0495a839f0b 100644 --- a/modules/data.land/R/soil_utils.R +++ b/modules/data.land/R/soil_utils.R @@ -34,7 +34,7 @@ soil_params <- function(soil_type,sand,silt,clay,bulk){ #---------------------------------------------------------------------------------------# if (missing(sand) & missing(clay)){ ## insufficient texture data, infer from soil_type - if(missing(soil_type)) PEcAn.utils::logger.error("insufficient arguments") + if(missing(soil_type)) PEcAn.logger::logger.error("insufficient arguments") mysoil$soil_type <- soil_type mysoil$soil_n <- which(toupper(soil.name) == toupper(soil_type)) # mysoil$key <- soil.key [mysoil$soil_n] ## turning off these abreviations since they lack a CF equivalent @@ -244,11 +244,11 @@ sclass <- function(sandfrac,clayfrac){ if (any(silt > 100.) | any(silt < 0.) | any(sand > 100.) | any(sand < 0.) | any(clay > 100.) | any(clay < 0.) ) { - PEcAn.utils::logger.warn(" At least one of your percentages is screwy...") - PEcAn.utils::logger.warn(paste("SAND <- ",sprintf("%.2f",sand),"%",sep="")) - PEcAn.utils::logger.warn(paste("CLAY <- ",sprintf("%.2f",clay),"%",sep="")) - PEcAn.utils::logger.warn(paste("SILT <- ",sprintf("%.2f",silt),"%",sep="")) - PEcAn.utils::logger.severe("This soil doesn''t fit into any category...") + PEcAn.logger::logger.warn(" At least one of your percentages is screwy...") + PEcAn.logger::logger.warn(paste("SAND <- ",sprintf("%.2f",sand),"%",sep="")) + PEcAn.logger::logger.warn(paste("CLAY <- ",sprintf("%.2f",clay),"%",sep="")) + PEcAn.logger::logger.warn(paste("SILT <- ",sprintf("%.2f",silt),"%",sep="")) + PEcAn.logger::logger.severe("This soil doesn''t fit into any category...") } nlayer = max(length(silt),length(clay),length(sand)) @@ -285,10 +285,10 @@ sclass <- function(sandfrac,clayfrac){ }else if( clay[z] > 40.0 & silt[z] > 30.0 & silt[z] <= 40.0) { mysoil[z] <- 17 #----- Clayey silt. -----------------------------------------------------# }else{ - PEcAn.utils::logger.warn(paste("SAND <- ",sprintf("%.2f",sand[z]),"%",sep="")) - PEcAn.utils::logger.warn(paste("CLAY <- ",sprintf("%.2f",clay[z]),"%",sep="")) - PEcAn.utils::logger.warn(paste("SILT <- ",sprintf("%.2f",silt[z]),"%",sep="")) - PEcAn.utils::logger.severe ("This soil doesn''t fit into any category...") + PEcAn.logger::logger.warn(paste("SAND <- ",sprintf("%.2f",sand[z]),"%",sep="")) + PEcAn.logger::logger.warn(paste("CLAY <- ",sprintf("%.2f",clay[z]),"%",sep="")) + PEcAn.logger::logger.warn(paste("SILT <- ",sprintf("%.2f",silt[z]),"%",sep="")) + PEcAn.logger::logger.severe ("This soil doesn''t fit into any category...") }#end if } return(mysoil) diff --git a/modules/emulator/R/minimize.GP.R b/modules/emulator/R/minimize.GP.R index a387f395196..7e0ef250bed 100644 --- a/modules/emulator/R/minimize.GP.R +++ b/modules/emulator/R/minimize.GP.R @@ -281,7 +281,7 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn samp[g, ] <- unlist(xcurr) par[g, ] <- pcurr - if(g %% 1000 == 0) PEcAn.utils::logger.info(g, "of", nmcmc, "iterations") + if(g %% 1000 == 0) PEcAn.logger::logger.info(g, "of", nmcmc, "iterations") # print(p(jmp)) jmp <- update(jmp,samp) } diff --git a/modules/rtm/R/helpers.R b/modules/rtm/R/helpers.R index 59f64f4b6b2..4e691761123 100644 --- a/modules/rtm/R/helpers.R +++ b/modules/rtm/R/helpers.R @@ -1,7 +1,7 @@ if (requireNamespace('PEcAn.utils')) { - stop <- PEcAn.utils::logger.severe - warning <- PEcAn.utils::logger.warn - message <- PEcAn.utils::logger.info + stop <- PEcAn.logger::logger.severe + warning <- PEcAn.logger::logger.warn + message <- PEcAn.logger::logger.info } testForPackage <- function(pkg) { From caf2131bb158a347e699d3c1881cf87dc03793b9 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 18 Aug 2017 15:26:55 -0400 Subject: [PATCH 337/771] Fix remaining missing `PEcAn.utils::logger*` refs --- base/utils/R/read.output.R | 24 +++++++++---------- modules/data.land/R/InventoryGrowthFusion.R | 10 ++++---- modules/data.land/R/pool_ic_netcdf2list.R | 4 ++-- modules/data.land/R/prepare_pools.R | 26 ++++++++++----------- 4 files changed, 32 insertions(+), 32 deletions(-) diff --git a/base/utils/R/read.output.R b/base/utils/R/read.output.R index a49262326d0..44f72d02ab4 100644 --- a/base/utils/R/read.output.R +++ b/base/utils/R/read.output.R @@ -30,7 +30,7 @@ model2netcdfdep <- function(runid, outdir, model, lat, lon, start_date, end_date model2nc <- paste("model2netcdf", model, sep = ".") if (!exists(model2nc)) { - logger.warn("File conversion function model2netcdf does not exist for", model) + PEcAn.logger::logger.warn("File conversion function model2netcdf does not exist for", model) return(NA) } @@ -39,7 +39,7 @@ model2netcdfdep <- function(runid, outdir, model, lat, lon, start_date, end_date print(paste("Output from run", runid, "has been converted to netCDF")) ncfiles <- list.files(path = outdir, pattern = "\\.nc$", full.names = TRUE) if (length(ncfiles) == 0) { - logger.severe("Conversion of model files to netCDF unsuccessful") + PEcAn.logger::logger.severe("Conversion of model files to netCDF unsuccessful") } return(ncfiles) } # model2netcdfdep @@ -64,7 +64,7 @@ model2netcdfdep <- function(runid, outdir, model, lat, lon, start_date, end_date ##' @return vector of filenames created, converts model output to netcdf as a side effect ##' @author Mike Dietze, David LeBauer model2netcdf <- function(runid, outdir, model, lat, lon, start_date, end_date) { - logger.severe("model2netcdf will be removed in future versions, plase update your worklow") + PEcAn.logger::logger.severe("model2netcdf will be removed in future versions, plase update your worklow") } # model2netcdf @@ -107,7 +107,7 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables keep <- which(nc.years >= as.numeric(start.year) & nc.years <= as.numeric(end.year)) ncfiles <- ncfiles[keep] } else if(length(nc.years) != 0){ - PEcAn.utils::logger.info("No start or end year provided; reading output for all years") + PEcAn.logger::logger.info("No start or end year provided; reading output for all years") start.year <- min(nc.years) end.year <- max(nc.years) } @@ -115,14 +115,14 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables # throw error if no *.nc files selected/availible nofiles <- FALSE if (length(ncfiles) == 0) { - logger.warn("read.output: no netCDF files of model output present for runid = ", + PEcAn.logger::logger.warn("read.output: no netCDF files of model output present for runid = ", runid, " in ", outdir, " for years requested; will return NA") if (length(nc.years) > 0) { - logger.info("netCDF files for other years present", nc.years) + PEcAn.logger::logger.info("netCDF files for other years present", nc.years) } nofiles <- TRUE } else { - logger.info("Reading output for Years: ", start.year, " - ", end.year, + PEcAn.logger::logger.info("Reading output for Years: ", start.year, " - ", end.year, "in directory:", outdir, "including files", dir(outdir, pattern = "\\.nc$")) } @@ -146,7 +146,7 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables # m-2 s-1', 'kg ha-1 yr-1') } result[[v]] <- abind::abind(result[[v]], newresult) } else if (!(v %in% names(nc$var))) { - logger.warn(paste(v, "missing in", ncfile)) + PEcAn.logger::logger.warn(paste(v, "missing in", ncfile)) } } ncdf4::nc_close(nc) @@ -155,7 +155,7 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables result <- lapply(variables, function(x) NA) } - logger.info(variables, "Mean:", + PEcAn.logger::logger.info(variables, "Mean:", lapply(result, function(x) signif(mean(x, na.rm = TRUE), 3)), "Median:", lapply(result, function(x) signif(median(x, na.rm = TRUE), 3))) @@ -174,7 +174,7 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables start_year = start.year end_year = end.year }else{ - logger.error("Start and End year must be of type numeric, character or Date") + PEcAn.logger::logger.error("Start and End year must be of type numeric, character or Date") } years <- start_year:end_year seconds <- udunits2::ud.convert(model$time,"years","seconds") @@ -199,7 +199,7 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables return(model) } }else{ - logger.error("Error in dataframe variable. Dataframe boolean must be set to TRUE or FALSE") + PEcAn.logger::logger.error("Error in dataframe variable. Dataframe boolean must be set to TRUE or FALSE") } } # read.output @@ -216,5 +216,5 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables ##' @export ##' @author Rob Kooper convert.outputs <- function(model, settings, ...) { - logger.severe("This function is not longer used and will be removed in the future.") + PEcAn.logger::logger.severe("This function is not longer used and will be removed in the future.") } # convert.outputs diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index a278535304e..50eb867da61 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -22,7 +22,7 @@ InventoryGrowthFusion <- function(data, cov.data=NULL, time_data = NULL, n.iter= if(!exists("model")) model = 0 check.dup.data <- function(data,loc){ - if(any(duplicated(names(data)))){PEcAn.utils::logger.error("duplicated variable at",loc,names(data))} + if(any(duplicated(names(data)))){PEcAn.logger::logger.error("duplicated variable at",loc,names(data))} } # start text object that will be manipulated (to build different linear models, swap in/out covariates) TreeDataFusionMV <- " @@ -288,7 +288,7 @@ model{ if(!is.null(time_varying)){ if (is.null(time_data)) { - PEcAn.utils::logger.error("time_varying formula provided but time_data is absent:", time_varying) + PEcAn.logger::logger.error("time_varying formula provided but time_data is absent:", time_varying) } Xt.priors <- "" @@ -406,11 +406,11 @@ model{ } - PEcAn.utils::logger.info("COMPILE JAGS MODEL") + PEcAn.logger::logger.info("COMPILE JAGS MODEL") j.model <- jags.model(file = textConnection(TreeDataFusionMV), data = data, inits = init, n.chains = 3) if(n.burn > 0){ - PEcAn.utils::logger.info("BURN IN") + PEcAn.logger::logger.info("BURN IN") jags.out <- coda.samples(model = j.model, variable.names = burnin.variables, n.iter = n.burn) @@ -419,7 +419,7 @@ model{ } } - PEcAn.utils::logger.info("RUN MCMC") + PEcAn.logger::logger.info("RUN MCMC") load.module("dic") for(k in seq_len(ceiling(n.iter/n.chunk))){ if(as.logical(save.state) & k%%as.numeric(save.state) == 0){ diff --git a/modules/data.land/R/pool_ic_netcdf2list.R b/modules/data.land/R/pool_ic_netcdf2list.R index 49d73c0babb..a004efc41d4 100644 --- a/modules/data.land/R/pool_ic_netcdf2list.R +++ b/modules/data.land/R/pool_ic_netcdf2list.R @@ -23,7 +23,7 @@ pool_ic_netcdf2list <- function(nc.path){ return(list(dims = dims, vals = vals)) } else{ - PEcAn.utils::logger.severe("Could not read IC file.") + PEcAn.logger::logger.severe("Could not read IC file.") } -} \ No newline at end of file +} diff --git a/modules/data.land/R/prepare_pools.R b/modules/data.land/R/prepare_pools.R index c6cec6d8efe..3952516ad93 100644 --- a/modules/data.land/R/prepare_pools.R +++ b/modules/data.land/R/prepare_pools.R @@ -36,17 +36,17 @@ prepare_pools <- function(nc.path, constants = NULL){ # note: if roots are partitionable, they will override fine_ and/or coarse_root_carbon_content if loaded if(is.valid(roots)){ if("rtsize" %in% names(IC.list$dims)){ - PEcAn.utils::logger.info("prepare_pools: Attempting to partition root_carbon_content") + PEcAn.logger::logger.info("prepare_pools: Attempting to partition root_carbon_content") rtsize <- IC.list$dims$rtsize part_roots <- PEcAn.data.land::partition_roots(roots, rtsize) if(!is.null(part_roots)){ fine.roots <- part_roots$fine.roots coarse.roots <- part_roots$coarse.roots } else{ - PEcAn.utils::logger.error("prepare_pools: could not partition roots; please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + PEcAn.logger::logger.error("prepare_pools: could not partition roots; please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") } } else{ - PEcAn.utils::logger.error("prepare_pools: Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") + PEcAn.logger::logger.error("prepare_pools: Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") } } else{ # proceed without error message @@ -62,10 +62,10 @@ prepare_pools <- function(nc.path, constants = NULL){ sla <- constants$sla if(!is.null(sla)){ leaf <- LAI * 1/sla - PEcAn.utils::logger.info(paste("using LAI", LAI, "and SLA", sla, "to get leaf", leaf)) + PEcAn.logger::logger.info(paste("using LAI", LAI, "and SLA", sla, "to get leaf", leaf)) IC.params[["leaf"]] <- leaf } else{ - PEcAn.utils::logger.error("Could not convert LAI to leaf carbon without SLA; please include 'constants' list with named element 'sla'") + PEcAn.logger::logger.error("Could not convert LAI to leaf carbon without SLA; please include 'constants' list with named element 'sla'") } } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && is.valid(fine.roots) && is.valid(coarse.roots)){ @@ -73,7 +73,7 @@ prepare_pools <- function(nc.path, constants = NULL){ if(leaf >= 0){ IC.params[["leaf"]] <- leaf } else{ - PEcAn.utils::logger.error("TotLivBiom is less than sum of AbvGrndWood and roots; will use default for leaf biomass") + PEcAn.logger::logger.error("TotLivBiom is less than sum of AbvGrndWood and roots; will use default for leaf biomass") } } @@ -82,17 +82,17 @@ prepare_pools <- function(nc.path, constants = NULL){ if(is.valid(coarse.roots)){ IC.params[["wood"]] <- (AbvGrndWood + coarse.roots) } else{ - PEcAn.utils::logger.error("prepare_pools can't calculate total woody biomass with only AbvGrndWood; checking for total biomass.") + PEcAn.logger::logger.error("prepare_pools can't calculate total woody biomass with only AbvGrndWood; checking for total biomass.") } } else if (is.valid(TotLivBiom) && is.valid(leaf) && is.valid(fine.roots)){ wood <- (TotLivBiom - leaf - fine.roots) if (wood >= 0){ IC.params[["wood"]] <- wood }else{ - PEcAn.utils::logger.error(paste("TotLivBiom (", TotLivBiom, ") is less than sum of leaf (", leaf, ") and fine roots(",fine.roots,"); will use default for woody biomass.")) + PEcAn.logger::logger.error(paste("TotLivBiom (", TotLivBiom, ") is less than sum of leaf (", leaf, ") and fine roots(",fine.roots,"); will use default for woody biomass.")) } } else{ - PEcAn.utils::logger.error("prepare_pools could not calculate woody biomass; will use defaults. Please provide AbvGrndWood and coarse_root_carbon OR leaf_carbon_content/LAI, fine_root_carbon_content, and TotLivBiom in netcdf.") + PEcAn.logger::logger.error("prepare_pools could not calculate woody biomass; will use defaults. Please provide AbvGrndWood and coarse_root_carbon OR leaf_carbon_content/LAI, fine_root_carbon_content, and TotLivBiom in netcdf.") } # initial pool of fine root carbon (kgC/m2) @@ -104,7 +104,7 @@ prepare_pools <- function(nc.path, constants = NULL){ if(fine.roots >= 0){ IC.params[["fine.roots"]] <- fine.roots } else{ - PEcAn.utils::logger.error("TotLivBiom is less than sum of AbvGrndWood, coarse roots, and leaf; will use default for fine.roots biomass") + PEcAn.logger::logger.error("TotLivBiom is less than sum of AbvGrndWood, coarse roots, and leaf; will use default for fine.roots biomass") } } @@ -132,12 +132,12 @@ prepare_pools <- function(nc.path, constants = NULL){ return(IC.params) } else{ - PEcAn.utils::logger.severe("Could not load initial conditions: output list is null") + PEcAn.logger::logger.severe("Could not load initial conditions: output list is null") return(NULL) } } else{ - PEcAn.utils::logger.severe("Could not load initial conditions: filepath is null") + PEcAn.logger::logger.severe("Could not load initial conditions: filepath is null") return(NULL) } -} \ No newline at end of file +} From 78728ad4f0ce77b224616f570fcbc68131993eb8 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 18 Aug 2017 15:55:32 -0400 Subject: [PATCH 338/771] Fix logger references in data.atmosphere --- modules/data.atmosphere/NAMESPACE | 8 ---- .../data.atmosphere/R/download.Ameriflux.R | 6 +-- .../data.atmosphere/R/download.AmerifluxLBL.R | 22 ++++----- .../R/download.CRUNCEP_Global.R | 6 +-- .../data.atmosphere/R/download.Geostreams.R | 7 ++- modules/data.atmosphere/R/download.NEONmet.R | 48 +++++++++---------- modules/data.atmosphere/R/download.PalEON.R | 6 +-- .../R/download.raw.met.module.R | 7 ++- modules/data.atmosphere/R/extract.nc.R | 2 +- modules/data.atmosphere/R/extract.nc.module.R | 7 ++- modules/data.atmosphere/R/extract.success.R | 2 +- modules/data.atmosphere/R/load.cfmet.R | 6 +-- modules/data.atmosphere/R/met.process.R | 16 +++---- modules/data.atmosphere/R/met2CF.ALMA.R | 16 +++---- modules/data.atmosphere/R/met2CF.Ameriflux.R | 4 +- modules/data.atmosphere/R/met2CF.FACE.R | 2 +- modules/data.atmosphere/R/met2CF.Geostreams.R | 8 ++-- modules/data.atmosphere/R/met2CF.csv.R | 2 +- modules/data.atmosphere/R/met2cf.module.R | 20 ++++---- modules/data.atmosphere/R/met2model.module.R | 10 ++-- modules/data.atmosphere/R/metgapfill.R | 15 +++--- modules/data.atmosphere/R/metgapfill.module.R | 7 ++- modules/data.atmosphere/R/read.register.R | 10 ++-- .../data.atmosphere/R/tdm_lm_ensemble_sims.R | 2 +- .../data.atmosphere/R/temporal.downscaling.R | 8 ++-- modules/data.atmosphere/R/upscale_met.R | 2 +- .../tests/testthat/test.download.CRUNCEP.R | 6 +-- .../tests/testthat/test.load.cfmet.R | 2 +- 28 files changed, 118 insertions(+), 139 deletions(-) diff --git a/modules/data.atmosphere/NAMESPACE b/modules/data.atmosphere/NAMESPACE index eee187343ca..1bf20dd6cbe 100644 --- a/modules/data.atmosphere/NAMESPACE +++ b/modules/data.atmosphere/NAMESPACE @@ -74,14 +74,6 @@ export(wide2long) importFrom(PEcAn.DB,db.close) importFrom(PEcAn.DB,db.query) importFrom(PEcAn.DB,dbfile.input.insert) -importFrom(PEcAn.DB,query.format.vars) -importFrom(PEcAn.utils,convert.input) -importFrom(PEcAn.utils,fqdn) -importFrom(PEcAn.utils,logger.debug) -importFrom(PEcAn.utils,logger.error) -importFrom(PEcAn.utils,logger.info) -importFrom(PEcAn.utils,logger.severe) -importFrom(PEcAn.utils,logger.warn) importFrom(ncdf4,ncatt_get) importFrom(ncdf4,ncatt_put) importFrom(ncdf4,ncdim_def) diff --git a/modules/data.atmosphere/R/download.Ameriflux.R b/modules/data.atmosphere/R/download.Ameriflux.R index a332dcd5af7..5b27591a9ba 100644 --- a/modules/data.atmosphere/R/download.Ameriflux.R +++ b/modules/data.atmosphere/R/download.Ameriflux.R @@ -52,7 +52,7 @@ download.Ameriflux <- function(sitename, outfolder, start_date, end_date, links <- tryCatch({ xpathSApply(htmlParse(baseurl), "//a/@href") }, error = function(e) { - logger.severe("Could not get information about", site, ".", "Is this an Ameriflux site?") + PEcAn.logger::logger.severe("Could not get information about", site, ".", "Is this an Ameriflux site?") }) # find all links we need based on the years and download them @@ -79,13 +79,13 @@ download.Ameriflux <- function(sitename, outfolder, start_date, end_date, # see if file exists if (file.exists(outputfile) && !overwrite) { - logger.debug("File '", outputfile, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", outputfile, "' already exists, skipping to next file.") next } file <- tail(as.character(links[grep(paste0("_", year, "_.*.nc"), links)]), n = 1) if (length(file) == 0) { - logger.severe("Could not download data for", site, "for the year", year) + PEcAn.logger::logger.severe("Could not download data for", site, "for the year", year) } download.file(paste0(baseurl, file), outputfile) } diff --git a/modules/data.atmosphere/R/download.AmerifluxLBL.R b/modules/data.atmosphere/R/download.AmerifluxLBL.R index d3096edba21..1dfe89a0933 100644 --- a/modules/data.atmosphere/R/download.AmerifluxLBL.R +++ b/modules/data.atmosphere/R/download.AmerifluxLBL.R @@ -15,8 +15,6 @@ ##' @param username Ameriflux username ##' @param method Optional. download.file() function option. Use this to set custom programs such as ncftp ##' -##' @importFrom PEcAn.utils fqdn logger.debug logger.error logger.warn logger.severe -##' ##' @examples ##' result <- download.AmerifluxLBL("US-Akn","~/","2011-01-01","2011-12-31",overwrite=TRUE) ##' @@ -52,7 +50,7 @@ download.AmerifluxLBL <- function(sitename, outfolder, start_date, end_date, # test to see that we got back a FTP if (is.null(ftplink)) { - logger.severe("Could not get information about", site, ".", "Is this an AmerifluxLBL site?") + PEcAn.logger::logger.severe("Could not get information about", site, ".", "Is this an AmerifluxLBL site?") } # get zip and csv filenames outfname <- strsplit(ftplink, "/") @@ -74,17 +72,17 @@ download.AmerifluxLBL <- function(sitename, outfolder, start_date, end_date, download_file_flag <- TRUE extract_file_flag <- TRUE if (!overwrite && file.exists(output_zip_file)) { - logger.debug("File '", output_zip_file, "' already exists, skipping download") + PEcAn.logger::logger.debug("File '", output_zip_file, "' already exists, skipping download") download_file_flag <- FALSE } if (!overwrite && file.exists(output_csv_file)) { - logger.debug("File '", output_csv_file, "' already exists, skipping extraction.") + PEcAn.logger::logger.debug("File '", output_csv_file, "' already exists, skipping extraction.") download_file_flag <- FALSE extract_file_flag <- FALSE file_timestep <- "HH" } else { if (!overwrite && file.exists(output_csv_file_hr)) { - logger.debug("File '", output_csv_file_hr, "' already exists, skipping extraction.") + PEcAn.logger::logger.debug("File '", output_csv_file_hr, "' already exists, skipping extraction.") download_file_flag <- FALSE extract_file_flag <- FALSE file_timestep <- "HR" @@ -97,7 +95,7 @@ download.AmerifluxLBL <- function(sitename, outfolder, start_date, end_date, extract_file_flag <- TRUE PEcAn.utils::download.file(ftplink, output_zip_file, method) if (!file.exists(output_zip_file)) { - logger.severe("FTP did not download ", output_zip_file, " from ", ftplink) + PEcAn.logger::logger.severe("FTP did not download ", output_zip_file, " from ", ftplink) } } if (extract_file_flag) { @@ -110,12 +108,12 @@ download.AmerifluxLBL <- function(sitename, outfolder, start_date, end_date, output_csv_file <- output_csv_file_hr outcsvname <- outcsvname_hr } else { - logger.severe("Half-hourly or Hourly data file was not found in ", output_zip_file) + PEcAn.logger::logger.severe("Half-hourly or Hourly data file was not found in ", output_zip_file) } } unzip(output_zip_file, outcsvname, exdir = outfolder) if (!file.exists(output_csv_file)) { - logger.severe("ZIP file ", output_zip_file, " did not contain CSV file ", outcsvname) + PEcAn.logger::logger.severe("ZIP file ", output_zip_file, " did not contain CSV file ", outcsvname) } } @@ -143,10 +141,10 @@ download.AmerifluxLBL <- function(sitename, outfolder, start_date, end_date, eyear <- lubridate::year(lastdate) if (start_year > eyear) { - logger.severe("Start_Year", start_year, "exceeds end of record ", eyear, " for ", site) + PEcAn.logger::logger.severe("Start_Year", start_year, "exceeds end of record ", eyear, " for ", site) } if (end_year < syear) { - logger.severe("End_Year", end_year, "precedes start of record ", syear, " for ", site) + PEcAn.logger::logger.severe("End_Year", end_year, "precedes start of record ", syear, " for ", site) } rows <- 1 @@ -160,7 +158,7 @@ download.AmerifluxLBL <- function(sitename, outfolder, start_date, end_date, stringsAsFactors = FALSE) results$file[rows] <- output_csv_file - results$host[rows] <- fqdn() + results$host[rows] <- PEcAn.utils::fqdn() results$startdate[rows] <- firstdate_st results$enddate[rows] <- lastdate_st results$mimetype[rows] <- "text/csv" diff --git a/modules/data.atmosphere/R/download.CRUNCEP_Global.R b/modules/data.atmosphere/R/download.CRUNCEP_Global.R index 44e1743336f..13ca4cd1013 100644 --- a/modules/data.atmosphere/R/download.CRUNCEP_Global.R +++ b/modules/data.atmosphere/R/download.CRUNCEP_Global.R @@ -73,7 +73,7 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l results$formatname[i] <- "CF Meteorology" if (file.exists(loc.file) && !isTRUE(overwrite)) { - logger.error("File already exists. Skipping to next year") + PEcAn.logger::logger.error("File already exists. Skipping to next year") next } @@ -101,13 +101,13 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l # confirm that timestamps match if (dap$dim$time$len != ntime) { - logger.severe("Expected", ntime, "observations, but", dap_file, "contained", dap$dim$time$len) + PEcAn.logger::logger.severe("Expected", ntime, "observations, but", dap_file, "contained", dap$dim$time$len) } dap_time <- udunits2::ud.convert(dap$dim$time$vals, dap$dim$time$units, time$units) if (!isTRUE(all.equal(dap_time, time$vals))){ - logger.severe("Timestamp mismatch.", + PEcAn.logger::logger.severe("Timestamp mismatch.", "Expected", min(time$vals), '..', max(time$vals), time$units, "but got", min(dap_time), "..", max(dap_time)) } diff --git a/modules/data.atmosphere/R/download.Geostreams.R b/modules/data.atmosphere/R/download.Geostreams.R index 48ab5d24743..21c893d8d71 100644 --- a/modules/data.atmosphere/R/download.Geostreams.R +++ b/modules/data.atmosphere/R/download.Geostreams.R @@ -14,7 +14,6 @@ #' attempts to connect unauthenticated. #' #' @export -#' @importFrom PEcAn.utils logger.severe logger.info #' @author Harsh Agrawal, Chris Black #' @examples \dontrun{ #' download.Geostreams(outfolder = "~/output/dbfiles/Clowder_EF", @@ -47,10 +46,10 @@ download.Geostreams <- function(outfolder, sitename, sensor_maxtime = lubridate::parse_date_time(sensor_info$max_end_time, orders = c("ymd", "ymdHMS", "ymdHMSz"), tz = "UTC") if (start_date < sensor_mintime) { - logger.severe("Requested start date", start_date, "is before data begin", sensor_mintime) + PEcAn.logger::logger.severe("Requested start date", start_date, "is before data begin", sensor_mintime) } if (end_date > sensor_maxtime) { - logger.severe("Requested end date", end_date, "is after data end", sensor_maxtime) + PEcAn.logger::logger.severe("Requested end date", end_date, "is after data end", sensor_maxtime) } result_files = c() @@ -65,7 +64,7 @@ download.Geostreams <- function(outfolder, sitename, met_result <- httr::GET(url = paste0(url, "/datapoints"), query = query_args, config = auth$userpass) - logger.info(met_result$url) + PEcAn.logger::logger.info(met_result$url) httr::stop_for_status(met_result, "download met data from Clowder") result_txt <- httr::content(met_result, as = "text", encoding = "UTF-8") combined_result <- paste0( diff --git a/modules/data.atmosphere/R/download.NEONmet.R b/modules/data.atmosphere/R/download.NEONmet.R index 369787b9b0d..ea6fc1ec008 100644 --- a/modules/data.atmosphere/R/download.NEONmet.R +++ b/modules/data.atmosphere/R/download.NEONmet.R @@ -14,8 +14,6 @@ ##' @examples ##' result <- download.NEONmet('HARV','~/','2017-01-01','2017-01-31',overwrite=TRUE) ##' @param verbose makes the function output more text -##' @importFrom PEcAn.utils fqdn logger.debug logger.error logger.warn logger.severe - download.NEONmet <- function(sitename, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { @@ -27,7 +25,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, site <- sub(".* \\((.*)\\)", "\\1", sitename) siteinfo <- nneo::nneo_site(site) if (!exists("siteinfo")) { - logger.error("Could not get information about", sitename, ".", "Is this a NEON site?") + PEcAn.logger::logger.error("Could not get information about", sitename, ".", "Is this a NEON site?") } #See what products and dates are available for this site @@ -71,7 +69,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, all_years <- start_year:end_year all_files <- file.path(outfolder, paste0("NEONmet.", site, ".", as.character(all_years), ".nc")) results$file <- all_files - results$host <- fqdn() + results$host <- PEcAn.utils::fqdn() results$mimetype <- "application/x-netcdf" results$formatname <- "CF" results$startdate <- paste0(all_years, "-01-01 00:00:00") @@ -101,7 +99,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, #Warn if no data is available for any months in given year monthsNeeded <- substr(seq(as.Date(start_ymd),as.Date(end_ymd),by='month'),1,7) if (length(intersect(unlist(availDates),monthsNeeded))==0) { - logger.warn("No data available in year ",current_year) + PEcAn.logger::logger.warn("No data available in year ",current_year) next() } startMon <- min(monthsNeeded) @@ -110,7 +108,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, #Set up netcdf file, dimensions, and sequence of dates new.file <- all_files[y_idx] if (file.exists(new.file) && !overwrite) { - logger.debug("File '", new.file, "' already exists, skipping.") + PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping.") next() } @@ -135,28 +133,28 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, airTempLoc <- grep("DP1\\.00002",availProducts) airTemp3Loc <- grep("DP1\\.00003",availProducts) if ((length(airTempLoc)==0) && (length(airTemp3Loc)==0)) { - logger.error("Air temperature DP1.00002 or DP1.00003 not available") + PEcAn.logger::logger.error("Air temperature DP1.00002 or DP1.00003 not available") } airTempDates <- neonmet.getDates(availDates,airTempLoc,startMon,endMon) airTemp3Dates <- neonmet.getDates(availDates,airTemp3Loc,startMon,endMon) nairTemp <- length(airTempDates) nairTemp3 <- length(airTemp3Dates) if ((nairTemp==0) && (nairTemp3==0)) { - logger.error("Air temperature DP1.00002 or DP1.00003 not available in date range ",startMon," ",endMon) + PEcAn.logger::logger.error("Air temperature DP1.00002 or DP1.00003 not available in date range ",startMon," ",endMon) } #define NetCDF variable and create NetCDF file airT.var <- ncdf4::ncvar_def(name = "air_temperature", units = "K", dim = xytdim) nc <- ncdf4::nc_create(new.file, vars = airT.var) #create netCDF file if (nairTemp3>nairTemp) { if (verbose) { - logger.info("Reading NEON SingleAsp AirTemp") + PEcAn.logger::logger.info("Reading NEON SingleAsp AirTemp") } ncdata <- neonmet.getVals(dates=airTemp3Dates,product=availProducts[airTemp3Loc[1]],site=site, datetime=datetime,data_col="tempTripleMean",QF=1, units=c("celsius","K")) } else { if (verbose) { - logger.info("Reading NEON TripleAsp AirTemp") + PEcAn.logger::logger.info("Reading NEON TripleAsp AirTemp") } ncdata <- neonmet.getVals(dates=airTempDates,product=availProducts[airTempLoc[1]],site=site, datetime=datetime,data_col="tempSingleMean", @@ -170,7 +168,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, npSurf <- length(pSurfDates) if (length(pSurfDates)>0) { if (verbose) { - logger.info("Reading NEON Pressure") + PEcAn.logger::logger.info("Reading NEON Pressure") } Psurf.var <- ncdf4::ncvar_def(name = "air_pressure", units = "Pa", dim = xytdim) nc <- ncdf4::ncvar_add(nc = nc, v = Psurf.var, verbose = verbose) @@ -179,7 +177,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, units=c("kPa","Pa")) ncdf4::ncvar_put(nc, varid = Psurf.var, vals = ncdata) } else { - logger.warn("No NEON Pressure Data") + PEcAn.logger::logger.warn("No NEON Pressure Data") } # NEON.DP1.00024 PAR @@ -187,7 +185,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, PARDates <- neonmet.getDates(availDates,PARLoc,startMon,endMon) if (length(PARDates)>0) { if (verbose) { - logger.info("Reading NEON PAR") + PEcAn.logger::logger.info("Reading NEON PAR") } PAR.var <- ncdf4::ncvar_def(name = "surface_downwelling_photosynthetic_photon_flux_in_air", units = "mol m-2 s-1", @@ -198,7 +196,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, units=c("umol m-2 s-1", "mol m-2 s-1")) ncdf4::ncvar_put(nc, varid = PAR.var, vals = ncdata) } else { - logger.warn("No NEON PAR DAta") + PEcAn.logger::logger.warn("No NEON PAR DAta") } # NEON.DP1.00006 Precip (missing uncertainty information) @@ -206,7 +204,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, precipDates <- neonmet.getDates(availDates,precipLoc,startMon,endMon) if (length(precipDates)>0) { if (verbose) { - logger.info("Reading NEON Precip") + PEcAn.logger::logger.info("Reading NEON Precip") } precip.var <- ncdf4::ncvar_def(name = "precipitation_flux", units = "kg m-2 s-1", @@ -217,7 +215,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, units=c("kg m-2 1/1800 s-1", "kg m-2 s-1")) #mm per half hour ncdf4::ncvar_put(nc, varid = precip.var, vals = ncdata) } else { - logger.warn("No NEON Precip") + PEcAn.logger::logger.warn("No NEON Precip") } # NEON.DP1.00098 RH @@ -225,7 +223,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, RHDates <- neonmet.getDates(availDates,RHLoc,startMon,endMon) if (length(RHDates)>0) { if (verbose) { - logger.info("Reading NEON RH") + PEcAn.logger::logger.info("Reading NEON RH") } RH.var <- ncdf4::ncvar_def(name = "relative_humidity", units = "%", @@ -236,7 +234,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, units=c("%", "%")) ncdf4::ncvar_put(nc, varid = RH.var, vals = ncdata) } else { - logger.warn("No NEON RH data") + PEcAn.logger::logger.warn("No NEON RH data") } # DP1.00023 SW/LW or NEON.DP1.00022 SW (Possible future: DP1.00014 for Direct/Diffuse SW) @@ -246,7 +244,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, SWLWDates <- neonmet.getDates(availDates,SWLWLoc,startMon,endMon) if (length(SWLWDates)>0) { if (verbose) { - logger.info("Reading NEON SWLW") + PEcAn.logger::logger.info("Reading NEON SWLW") } SW.var <- ncdf4::ncvar_def(name = "surface_downwelling_shortwave_flux_in_air", units = "W m-2", @@ -267,7 +265,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, } else { if (length(SWDates)>0) { if (verbose) { - logger.info("Reading NEON SW") + PEcAn.logger::logger.info("Reading NEON SW") } SW.var <- ncdf4::ncvar_def(name = "surface_downwelling_shortwave_flux_in_air", units = "W m-2", @@ -278,7 +276,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, units=c("W m-2", "W m-2")) ncdf4::ncvar_put(nc, varid = SW.var, vals = ncdata) } else { - logger.warn("No NEON SW/LW or SW") + PEcAn.logger::logger.warn("No NEON SW/LW or SW") } } @@ -287,7 +285,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, WSpdDates <- neonmet.getDates(availDates,WSpdLoc,startMon,endMon) if (length(WSpdDates)>0) { if (verbose) { - logger.info("Reading NEON Wind Speed/Direction") + PEcAn.logger::logger.info("Reading NEON Wind Speed/Direction") } WSpd.var <- ncdf4::ncvar_def(name = "wind_speed", units = "m s-1", @@ -316,7 +314,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, ncdf4::ncvar_put(nc, varid = Ewind.var, vals = ncdata_e) ncdf4::ncvar_put(nc, varid = Nwind.var, vals = ncdata_n) } else { - logger.warn("No NEON Wind data") + PEcAn.logger::logger.warn("No NEON Wind data") } # NEON.DP1.00041 Soil temp (take 2cm level which is level 501) @@ -324,7 +322,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, soilTDates <- neonmet.getDates(availDates,soilTLoc,startMon,endMon) if (length(soilTDates>0)) { if (verbose) { - logger.info("Reading NEON Soil Temp") + PEcAn.logger::logger.info("Reading NEON Soil Temp") } soilT.var <- ncdf4::ncvar_def(name = "soil_temperature", units = "K", @@ -336,7 +334,7 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, units=c("celsius", "K"),belowground=TRUE) ncdf4::ncvar_put(nc, varid = soilT.var, vals = ncdata) } else { - logger.warn("No NEON Soil Temp") + PEcAn.logger::logger.warn("No NEON Soil Temp") } # NEON.DP1.00034 CO2 at tower top (alt NEON.DP3.00009 CO2 profile) - not yet avail, don't have variable names diff --git a/modules/data.atmosphere/R/download.PalEON.R b/modules/data.atmosphere/R/download.PalEON.R index 8d6ac5972f4..1c7e6deb411 100644 --- a/modules/data.atmosphere/R/download.PalEON.R +++ b/modules/data.atmosphere/R/download.PalEON.R @@ -31,7 +31,7 @@ download.PalEON <- function(sitename, outfolder, start_date, end_date, overwrite site <- "PUN" } # 1-675 done else { - logger.severe("Unknown site name") + PEcAn.logger::logger.severe("Unknown site name") } start_date <- as.POSIXlt(start_date, tz = "UTC") @@ -59,7 +59,7 @@ download.PalEON <- function(sitename, outfolder, start_date, end_date, overwrite files <- dir(outfolder) if (sum(!(vlist %in% files)) > 0) { - logger.error("Don't have all variables downloaded") + PEcAn.logger::logger.error("Don't have all variables downloaded") } else { for (v in vlist) { print(sprintf("Checking %s", v)) @@ -67,7 +67,7 @@ download.PalEON <- function(sitename, outfolder, start_date, end_date, overwrite for (m in mlist) { file <- file.path(outfolder, v, sprintf("%s_%s_%04d_%02d.nc", site, v, y, m)) if (!(file.exists(file))) { - logger.error("Missing met file") + PEcAn.logger::logger.error("Missing met file") } row <- (which(vlist == v) - 1) * Y * M + (which(ylist == y) - 1) * M + m # print(row) diff --git a/modules/data.atmosphere/R/download.raw.met.module.R b/modules/data.atmosphere/R/download.raw.met.module.R index 56955083b4b..5ae14cda40f 100644 --- a/modules/data.atmosphere/R/download.raw.met.module.R +++ b/modules/data.atmosphere/R/download.raw.met.module.R @@ -1,4 +1,3 @@ -#' @importFrom PEcAn.utils convert.input .download.raw.met.module <- function(dir, met, register, machine, start_date, end_date, str_ns, con, input_met, site.id, lat.in, lon.in, host, site, username, overwrite = FALSE) { @@ -8,7 +7,7 @@ fcn <- paste0("download.", met) if (register$scale == "regional") { - raw.id <- convert.input(input.id = NA, + raw.id <- PEcAn.utils::convert.input(input.id = NA, outfolder = outfolder, formatname = register$format$name, mimetype = register$format$mimetype, @@ -26,7 +25,7 @@ } else if (register$scale == "site") { # Site-level met - raw.id <- convert.input(input.id = NA, + raw.id <- PEcAn.utils::convert.input(input.id = NA, outfolder = outfolder, formatname = register$format$name, mimetype = register$format$mimetype, @@ -40,7 +39,7 @@ username = username) } else { - logger.severe("Unknown register$scale") + PEcAn.logger::logger.severe("Unknown register$scale") } return(raw.id) diff --git a/modules/data.atmosphere/R/extract.nc.R b/modules/data.atmosphere/R/extract.nc.R index e1e62fbdf61..22bb0caf01a 100644 --- a/modules/data.atmosphere/R/extract.nc.R +++ b/modules/data.atmosphere/R/extract.nc.R @@ -60,7 +60,7 @@ extract.nc <- function(in.path, in.prefix, outfolder, start_date, end_date, slat results$formatname[row] <- "CF" if (file.exists(outfile) && !overwrite) { - logger.debug("File '", outfile, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", outfile, "' already exists, skipping to next file.") next } diff --git a/modules/data.atmosphere/R/extract.nc.module.R b/modules/data.atmosphere/R/extract.nc.module.R index ce6d348fde5..045bc0947e5 100644 --- a/modules/data.atmosphere/R/extract.nc.module.R +++ b/modules/data.atmosphere/R/extract.nc.module.R @@ -1,8 +1,7 @@ ##' @export -#' @importFrom PEcAn.utils convert.input logger.info .extract.nc.module <- function(cf.id, register, dir, met, str_ns, site, new.site, con, start_date, end_date, host, overwrite = FALSE) { - logger.info("Site Extraction") + PEcAn.logger::logger.info("Site Extraction") input.id <- cf.id[1] if(host$name == "localhost"){ @@ -20,7 +19,7 @@ formatname <- "CF Meteorology" mimetype <- "application/x-netcdf" - ready.id <- convert.input(input.id = input.id, + ready.id <- PEcAn.utils::convert.input(input.id = input.id, outfolder = outfolder, formatname = formatname, mimetype = mimetype, @@ -35,7 +34,7 @@ overwrite = overwrite, exact.dates = FALSE) - logger.info("Finished Extracting Met") + PEcAn.logger::logger.info("Finished Extracting Met") return(ready.id) } # .extract.nc.module diff --git a/modules/data.atmosphere/R/extract.success.R b/modules/data.atmosphere/R/extract.success.R index 66e9c9d6ad2..307331f43d3 100644 --- a/modules/data.atmosphere/R/extract.success.R +++ b/modules/data.atmosphere/R/extract.success.R @@ -18,7 +18,7 @@ extract.success <- function(in.path, in.prefix, outfolder) { } else if (length(outfiles.nc) == length(infiles) || length(outfiles.h5) == length(infiles) * 12) { s <- TRUE } else { - logger.severe("Uh oh - we should not be here") + PEcAn.logger::logger.severe("Uh oh - we should not be here") } return(s) } # extract.success diff --git a/modules/data.atmosphere/R/load.cfmet.R b/modules/data.atmosphere/R/load.cfmet.R index 81f87a30905..b68ba703f0b 100644 --- a/modules/data.atmosphere/R/load.cfmet.R +++ b/modules/data.atmosphere/R/load.cfmet.R @@ -23,7 +23,7 @@ load.cfmet <- function(met.nc, lat, lon, start.date, end.date) { Lon <- ncdf4::ncvar_get(met.nc, "longitude") if(min(abs(Lat-lat)) > 2.5 | min(abs(Lon-lon)) > 2.5){ - logger.severe("lat / lon (", lat, ",", lon, ") outside range of met file (", range(Lat), ",", range(Lon)) + PEcAn.logger::logger.severe("lat / lon (", lat, ",", lon, ") outside range of met file (", range(Lat), ",", range(Lon)) } lati <- which.min(abs(Lat - lat)) loni <- which.min(abs(Lon - lon)) @@ -57,10 +57,10 @@ load.cfmet <- function(met.nc, lat, lon, start.date, end.date) { suppressWarnings(all.dates <- data.table(index = seq(time.idx), date = round(date))) if (start.date + lubridate::days(1) < min(all.dates$date)) { - logger.error("run start date", start.date, "before met data starts", min(all.dates$date)) + PEcAn.logger::logger.error("run start date", start.date, "before met data starts", min(all.dates$date)) } if (end.date > max(all.dates$date)) { - logger.error("run end date", end.date, "after met data ends", max(all.dates$date)) + PEcAn.logger::logger.error("run end date", end.date, "after met data ends", max(all.dates$date)) } run.dates <- all.dates[date >= start.date & date <= end.date, diff --git a/modules/data.atmosphere/R/met.process.R b/modules/data.atmosphere/R/met.process.R index fabf03cb5aa..e99e4f9cd06 100644 --- a/modules/data.atmosphere/R/met.process.R +++ b/modules/data.atmosphere/R/met.process.R @@ -33,14 +33,14 @@ met.process <- function(site, input_met, start_date, end_date, model, PEcAn.logger::logger.warn("met.process only has a path provided, assuming path is model driver and skipping processing") return(input_met$path) }else { - logger.warn("No met source specified") + PEcAn.logger::logger.warn("No met source specified") if(!is.null(input_met$id) & !is.null(input_met$path)){ - logger.warn("Assuming source CFmet") + PEcAn.logger::logger.warn("Assuming source CFmet") met <- input_met$source <- "CFmet" ## this case is normally hit when the use provides an existing file that has already been ## downloaded, processed, and just needs conversion to model-specific format. ## setting a 'safe' (global) default } else { - logger.error("Cannot process met without source information") + PEcAn.logger::logger.error("Cannot process met without source information") } } } else { @@ -75,7 +75,7 @@ met.process <- function(site, input_met, start_date, end_date, model, overwrite.check[i] == TRUE && !all(overwrite.check[(i + 1):length(overwrite.check)])) { print(overwrite) - logger.error(paste0("If overwriting any stage of met.process, ", "all subsequent stages need to be overwritten too. Please correct.")) + PEcAn.logger::logger.error(paste0("If overwriting any stage of met.process, ", "all subsequent stages need to be overwritten too. Please correct.")) } } @@ -290,13 +290,13 @@ db.site.lat.lon <- function(site.id, con) { site <- db.query(paste("SELECT id, ST_X(ST_CENTROID(geometry)) AS lon, ST_Y(ST_CENTROID(geometry)) AS lat FROM sites WHERE id =", site.id), con) if (nrow(site) == 0) { - logger.error("Site not found") + PEcAn.logger::logger.error("Site not found") return(NULL) } if (!(is.na(site$lat)) && !(is.na(site$lat))) { return(list(lat = site$lat, lon = site$lon)) } else { - logger.severe("We should not be here!") + PEcAn.logger::logger.severe("We should not be here!") } } # db.site.lat.lon @@ -326,7 +326,7 @@ browndog.met <- function(browndog, source, site, start_date, end_date, model, di } else if (source == "NARR") { sitename <- gsub("[\\s/()]", "-", site$name, perl = TRUE) } else { - logger.warn("Could not process source", source) + PEcAn.logger::logger.warn("Could not process source", source) return(invisible(NA)) } @@ -372,7 +372,7 @@ browndog.met <- function(browndog, source, site, start_date, end_date, model, di dbfile.name = basename(outputfile), stringsAsFactors = FALSE) } else { - logger.warn("Could not process model", model) + PEcAn.logger::logger.warn("Could not process model", model) return(invisible(NA)) } diff --git a/modules/data.atmosphere/R/met2CF.ALMA.R b/modules/data.atmosphere/R/met2CF.ALMA.R index 967b6629cda..dc275b376bf 100644 --- a/modules/data.atmosphere/R/met2CF.ALMA.R +++ b/modules/data.atmosphere/R/met2CF.ALMA.R @@ -37,7 +37,7 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end ## check file organization by.folder <- list.dirs(in.path, recursive = FALSE, full.names = FALSE) if (length(by.folder) == 0) { - logger.severe("met2CF.PalEON, could not detect input folders", in.path) + PEcAn.logger::logger.severe("met2CF.PalEON, could not detect input folders", in.path) } rows <- end_year - start_year + 1 @@ -65,7 +65,7 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end results$formatname[row] <- "CF" if (file.exists(new.file) && !overwrite) { - logger.debug("File '", new.file, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping to next file.") next } @@ -85,7 +85,7 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end stub <- paste0(year, "_", formatC(m, width = 2, format = "d", flag = "0")) sel <- grep(stub, fnames) if (length(sel) == 0) { - logger.severe("missing file", v, stub) + PEcAn.logger::logger.severe("missing file", v, stub) } old.file <- fnames[sel] nc1 <- ncdf4::nc_open(old.file, write = FALSE) @@ -203,7 +203,7 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l ## check file organization by.folder <- list.dirs(in.path, recursive = FALSE, full.names = FALSE) if (length(by.folder) == 0) { - logger.severe("met2CF.PalEON, could not detect input folders", in.path) + PEcAn.logger::logger.severe("met2CF.PalEON, could not detect input folders", in.path) } rows <- end_year - start_year + 1 @@ -231,7 +231,7 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l results$formatname[row] <- "CF" if (file.exists(new.file) && !overwrite) { - logger.debug("File '", new.file, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping to next file.") next } @@ -251,7 +251,7 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l stub <- paste0(year, "_", formatC(m, width = 2, format = "d", flag = "0")) sel <- grep(stub, fnames) if (length(sel) == 0) { - logger.severe("missing file", v, stub) + PEcAn.logger::logger.severe("missing file", v, stub) } old.file <- fnames[sel] nc1 <- ncdf4::nc_open(old.file, write = FALSE) @@ -377,7 +377,7 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove by.file <- FALSE by.folder <- list.dirs(in.path, recursive = FALSE, full.names = FALSE) if (length(by.folder) == 0) { - logger.severe("met2CF.ALMA, could not detect input file or folders", in.path) + PEcAn.logger::logger.severe("met2CF.ALMA, could not detect input file or folders", in.path) } } else { by.file <- TRUE @@ -404,7 +404,7 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove results$formatname[row] <- "CF" if (file.exists(new.file) && !overwrite) { - logger.debug("File '", new.file, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping to next file.") next } diff --git a/modules/data.atmosphere/R/met2CF.Ameriflux.R b/modules/data.atmosphere/R/met2CF.Ameriflux.R index 027c3a03f6e..be65af3e5ca 100644 --- a/modules/data.atmosphere/R/met2CF.Ameriflux.R +++ b/modules/data.atmosphere/R/met2CF.Ameriflux.R @@ -62,7 +62,7 @@ getLatLon <- function(nc1) { return(c(as.numeric(lat$value), as.numeric(lon$value))) } } - logger.severe("Could not get site location for file.") + PEcAn.logger::logger.severe("Could not get site location for file.") } # getLatLon @@ -120,7 +120,7 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date results$formatname[row] <- "CF" if (file.exists(new.file) && !overwrite) { - logger.debug("File '", new.file, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping to next file.") next } diff --git a/modules/data.atmosphere/R/met2CF.FACE.R b/modules/data.atmosphere/R/met2CF.FACE.R index 509d780f70d..acc8efd005d 100644 --- a/modules/data.atmosphere/R/met2CF.FACE.R +++ b/modules/data.atmosphere/R/met2CF.FACE.R @@ -173,7 +173,7 @@ met2CF.FACE <- function(in.path,in.prefix,outfolder,start_date,end_date,input.id # "solar_elevation_angle") # # if (!(length(nvars) == length(vars))) { -# logger.error("Variable mismatch") +# PEcAn.logger::logger.error("Variable mismatch") # } # # l <- length(vars) diff --git a/modules/data.atmosphere/R/met2CF.Geostreams.R b/modules/data.atmosphere/R/met2CF.Geostreams.R index 6fbab32b7a4..c6e54bafd69 100644 --- a/modules/data.atmosphere/R/met2CF.Geostreams.R +++ b/modules/data.atmosphere/R/met2CF.Geostreams.R @@ -34,11 +34,11 @@ met2CF.Geostreams <- function(in.path, in.prefix, outfolder, dat$start_time <- lubridate::parse_date_time(dat$start_time, orders = "ymdHMSz", tz = "UTC") dat$end_time <- lubridate::parse_date_time(dat$end_time, orders = "ymdHMSz", tz = "UTC") if (year == lubridate::year(start_date) & start_date < min(dat$start_time)) { - logger.severe("Requested start date is", start_date, + PEcAn.logger::logger.severe("Requested start date is", start_date, "but", year, "data begin on", min(dat$start_time)) } if (year == lubridate::year(end_date) & end_date > max(dat$end_time)) { - logger.severe("Requested end date is", end_date, + PEcAn.logger::logger.severe("Requested end date is", end_date, "but", year, "data end on", max(dat$end_time)) } @@ -75,7 +75,7 @@ met2CF.Geostreams <- function(in.path, in.prefix, outfolder, make_ncvar <- function(name){ if (! name %in% met.lookup$CF_standard_name) { - logger.severe("Don't know how to convert parameter", name, "to CF standard format") + PEcAn.logger::logger.severe("Don't know how to convert parameter", name, "to CF standard format") } unit <- met.lookup[met.lookup$CF_standard_name == name, "units"] ncdf4::ncvar_def(name = name, @@ -89,7 +89,7 @@ met2CF.Geostreams <- function(in.path, in.prefix, outfolder, dir.create(outfolder, recursive = TRUE, showWarnings = FALSE) nc.file <- file.path(outfolder, paste(in.prefix, year, "nc", sep = ".")) if (!overwrite && file.exists(nc.file)) { - logger.severe("Refusing to overwrite existing file", nc.file, " -- If you're sure, set overwrite=TRUE") + PEcAn.logger::logger.severe("Refusing to overwrite existing file", nc.file, " -- If you're sure, set overwrite=TRUE") } cf <- ncdf4::nc_create(filename = nc.file, vars = var_list, verbose = verbose) for (var in var_list) { diff --git a/modules/data.atmosphere/R/met2CF.csv.R b/modules/data.atmosphere/R/met2CF.csv.R index d1036c297a0..20b8dc03568 100644 --- a/modules/data.atmosphere/R/met2CF.csv.R +++ b/modules/data.atmosphere/R/met2CF.csv.R @@ -604,7 +604,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form # if (any(colnames(format$vars)=="column_number")) { # arrloc <- format$vars$column_number[k] # } else { - # logger.error("Cannot find column location for wind_direction by name or column number") + # PEcAn.logger::logger.error("Cannot find column location for wind_direction by name or column number") # } # } # ncdf4::ncvar_put(nc, varid = Wdir.var, diff --git a/modules/data.atmosphere/R/met2cf.module.R b/modules/data.atmosphere/R/met2cf.module.R index 43335eada46..e296701fa43 100644 --- a/modules/data.atmosphere/R/met2cf.module.R +++ b/modules/data.atmosphere/R/met2cf.module.R @@ -1,9 +1,7 @@ -#' @importFrom PEcAn.utils logger.info logger.error convert.input -#' @importFrom PEcAn.DB query.format.vars .met2cf.module <- function(raw.id, register, met, str_ns, dir, machine, site.id, lat, lon, start_date, end_date, con, host, overwrite = FALSE, format.vars, bety) { - logger.info("Begin change to CF Standards") + PEcAn.logger::logger.info("Begin change to CF Standards") input.id <- raw.id$input.id[1] pkg <- "PEcAn.data.atmosphere" @@ -25,10 +23,10 @@ } else if (exists(fcn2)) { fcn <- fcn2 } else { - logger.error("met2CF function ", fcn1, " or ", fcn2, " don't exist") + PEcAn.logger::logger.error("met2CF function ", fcn1, " or ", fcn2, " don't exist") } - cf0.id <- convert.input(input.id = input.id, + cf0.id <- PEcAn.utils::convert.input(input.id = input.id, outfolder = outfolder, formatname = formatname, mimetype = mimetype, @@ -43,7 +41,7 @@ fcn <- "permute.nc" outfolder <- file.path(dir, input_name) - cf.id <- convert.input(input.id = cf0.id$input.id, + cf.id <- PEcAn.utils::convert.input(input.id = cf0.id$input.id, outfolder = outfolder, formatname = formatname, mimetype = mimetype, @@ -64,7 +62,7 @@ fcn2 <- paste0("met2CF.", mimename) if (exists(fcn1)) { fcn <- fcn1 - cf.id <- convert.input(input.id = input.id, + cf.id <- PEcAn.utils::convert.input(input.id = input.id, outfolder = outfolder, formatname = formatname, mimetype = mimetype, @@ -77,8 +75,8 @@ exact.dates = FALSE) } else if (exists(fcn2)) { fcn <- fcn2 - format <- query.format.vars(input.id = input.id, bety = bety) - cf.id <- convert.input(input.id = input.id, + format <- PEcAn.db::query.format.vars(input.id = input.id, bety = bety) + cf.id <- PEcAn.utils::convert.input(input.id = input.id, outfolder = outfolder, formatname = formatname, mimetype = mimetype, @@ -90,10 +88,10 @@ format.vars = format.vars, overwrite = overwrite, exact.dates = FALSE) } else { - logger.error("met2CF function ", fcn1, " or ", fcn2, " doesn't exists") + PEcAn.logger::logger.error("met2CF function ", fcn1, " or ", fcn2, " doesn't exists") } } - logger.info("Finished change to CF Standards") + PEcAn.logger::logger.info("Finished change to CF Standards") return(cf.id) } # .met2cf.module diff --git a/modules/data.atmosphere/R/met2model.module.R b/modules/data.atmosphere/R/met2model.module.R index de37093c194..147d4b2f202 100644 --- a/modules/data.atmosphere/R/met2model.module.R +++ b/modules/data.atmosphere/R/met2model.module.R @@ -1,11 +1,9 @@ ##' @export -#' @importFrom PEcAn.utils logger.info convert.input -#' @importFrom PEcAn.DB db.query .met2model.module <- function(ready.id, model, con, host, dir, met, str_ns, site, start_date, end_date, browndog, new.site, overwrite = FALSE, exact.dates,spin) { # Determine output format name and mimetype - model_info <- db.query(paste0("SELECT f.name, f.id, mt.type_string from modeltypes as m", " join modeltypes_formats as mf on m.id = mf.modeltype_id", + model_info <- PEcAn.db::db.query(paste0("SELECT f.name, f.id, mt.type_string 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", " join mimetypes as mt on f.mimetype_id = mt.id", " where m.name = '", model, "' AND mf.tag='met'"), con) @@ -13,7 +11,7 @@ model.id <- ready.id outfolder <- file.path(dir, paste0(met, "_site_", str_ns)) } else { - logger.info("Begin Model Specific Conversion") + PEcAn.logger::logger.info("Begin Model Specific Conversion") formatname <- model_info[1] mimetype <- model_info[3] @@ -35,7 +33,7 @@ fcn <- paste0("met2model.", model) lst <- site.lst(site, con) - model.id <- convert.input(input.id = input.id, + model.id <- PEcAn.utils::convert.input(input.id = input.id, outfolder = outfolder, formatname = formatname, mimetype = mimetype, site.id = site$id, @@ -51,6 +49,6 @@ spin_resample = spin$resample) } - logger.info(paste("Finished Model Specific Conversion", model.id[1])) + PEcAn.logger::logger.info(paste("Finished Model Specific Conversion", model.id[1])) return(list(outfolder = outfolder, model.id = model.id)) } # .met2model.module diff --git a/modules/data.atmosphere/R/metgapfill.R b/modules/data.atmosphere/R/metgapfill.R index 1948f0684ab..155340cf760 100644 --- a/modules/data.atmosphere/R/metgapfill.R +++ b/modules/data.atmosphere/R/metgapfill.R @@ -14,7 +14,6 @@ ##' @param verbose should the function be very verbose ##' @param lst is timezone offset from UTC, if timezone is available in time:units atribute in file, it will use that, default is to assume UTC ##' @author Ankur Desai -##' @importFrom PEcAn.utils fqdn logger.debug logger.error logger.warn logger.severe ##' @importFrom ncdf4 ncvar_get ncatt_get ncdim_def ncvar_def ncvar_add ncvar_put metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst = 0, overwrite = FALSE, verbose = FALSE, ...) { @@ -52,7 +51,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst # check if input exists if (!file.exists(old.file)) { - logger.warn("Missing input file ", old.file, " for year", sprintf("%04d", year), + PEcAn.logger::logger.warn("Missing input file ", old.file, " for year", sprintf("%04d", year), "in folder", in.path) next } @@ -60,14 +59,14 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst # create array with results row <- year - start_year + 1 results$file[row] <- new.file - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- sprintf("%04d-01-01 00:00:00", year) results$enddate[row] <- sprintf("%04d-12-31 23:59:59", year) results$mimetype[row] <- "application/x-netcdf" results$formatname[row] <- "CF (gapfilled)" if (file.exists(new.file) && !overwrite) { - logger.debug("File '", new.file, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping to next file.") next } @@ -110,11 +109,11 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst ## Required to exist in file Tair <- try(ncvar_get(nc = nc, varid = "air_temperature"), silent = TRUE) if (!is.numeric(Tair)) { - logger.error("air_temperature not defined in met file for metgapfill") + PEcAn.logger::logger.error("air_temperature not defined in met file for metgapfill") } precip <- try(ncvar_get(nc = nc, varid = "precipitation_flux"), silent = TRUE) if (!is.numeric(precip)) { - logger.error("precipitation_flux not defined in met file for metgapfill") + PEcAn.logger::logger.error("precipitation_flux not defined in met file for metgapfill") } ## create an array of missing values for writing new variables prior to gap filling @@ -145,7 +144,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst # check to see if we have Rg values if (length(which(is.na(Rg))) == length(Rg)) { if (length(which(is.na(PAR))) == length(PAR)) { - logger.severe("Missing both PAR and Rg") + PEcAn.logger::logger.severe("Missing both PAR and Rg") } Rg <- PAR * 1e+06 / 2.1 } @@ -625,7 +624,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst fail.file <- file.path(outfolder, paste(in.prefix, sprintf("%04d", year), "failure", "nc", sep = ".")) file.rename(from = new.file, to = fail.file) - logger.severe("Could not do gapfill, results are in", fail.file, ".", + PEcAn.logger::logger.severe("Could not do gapfill, results are in", fail.file, ".", "The following variables have NA's:", paste(error, sep = ", ")) } } # end loop diff --git a/modules/data.atmosphere/R/metgapfill.module.R b/modules/data.atmosphere/R/metgapfill.module.R index 392070dc2bf..ec70f1f060c 100644 --- a/modules/data.atmosphere/R/metgapfill.module.R +++ b/modules/data.atmosphere/R/metgapfill.module.R @@ -1,7 +1,6 @@ -# @importFrom PEcAn.utils logger.info convert.input .metgapfill.module <- function(cf.id, register, dir, met, str_ns, site, new.site, con, start_date, end_date, host, overwrite = FALSE) { - logger.info("Gapfilling") # Does NOT take place on browndog! + PEcAn.logger::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)) @@ -12,7 +11,7 @@ mimetype <- "application/x-netcdf" lst <- site.lst(site, con) - ready.id <- convert.input(input.id = input.id, + ready.id <- PEcAn.utils::convert.input(input.id = input.id, outfolder = outfolder, formatname = formatname, mimetype = mimetype, @@ -26,7 +25,7 @@ print(ready.id) - logger.info("Finished Gapfilling Met") + PEcAn.logger::logger.info("Finished Gapfilling Met") return(ready.id) } # .metgapfill.module diff --git a/modules/data.atmosphere/R/read.register.R b/modules/data.atmosphere/R/read.register.R index 37dc205825f..22f1cdbc852 100644 --- a/modules/data.atmosphere/R/read.register.R +++ b/modules/data.atmosphere/R/read.register.R @@ -15,18 +15,18 @@ read.register <- function(register.xml, con) { # check scale if (is.null(register$scale)) { - logger.error("Scale is not defined") + PEcAn.logger::logger.error("Scale is not defined") } else { if (register$scale == "regional" & is.null(register$siteid)) { - logger.warn("Region site id is not defined") + PEcAn.logger::logger.warn("Region site id is not defined") } } # check format format is not defined if (is.null(register$format)) { - logger.error("Format is not defined") + PEcAn.logger::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 + PEcAn.logger::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)) @@ -34,7 +34,7 @@ read.register <- function(register.xml, con) { (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") + PEcAn.logger::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))) { diff --git a/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R b/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R index 8ba903a26e9..e369d67e106 100644 --- a/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R +++ b/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R @@ -36,7 +36,7 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, lags.list = NULL, # Figure out if we need to extract the approrpiate if (is.null(lags.list) & is.null(lags.init)) { - logger.error("lags.init & lags.list are NULL, this is a required argument") + PEcAn.logger::logger.error("lags.init & lags.list are NULL, this is a required argument") } if (is.null(lags.init)) { lags.init <- lags.list[[unique(dat.mod$ens.day)]] diff --git a/modules/data.atmosphere/R/temporal.downscaling.R b/modules/data.atmosphere/R/temporal.downscaling.R index 25506d87aff..96f8d97f649 100644 --- a/modules/data.atmosphere/R/temporal.downscaling.R +++ b/modules/data.atmosphere/R/temporal.downscaling.R @@ -29,7 +29,7 @@ cfmet.downscale.time <- cruncep_hourly <- function(cfmet, output.dt = 1, lat = l } else if (dt_hr > 6 & dt_hr < 24) { # cfmet <- cfmet[,list(air_temperature_max = max(air_temperature), air_temperature_min = # min(air_temperature), ), by = 'year,doy']) dt_hr <- 24 - logger.error("timestep of input met data is between 6 and 24 hours.\n", "PEcAn will automatically convert this to daily data\n", + PEcAn.logger::logger.error("timestep of input met data is between 6 and 24 hours.\n", "PEcAn will automatically convert this to daily data\n", "you should confirm validity of downscaling, in particular that min / max temperatures are realistic") } @@ -39,7 +39,7 @@ cfmet.downscale.time <- cruncep_hourly <- function(cfmet, output.dt = 1, lat = l } downscaled.result <- cfmet.downscale.daily(dailymet = cfmet, output.dt = output.dt, lat = lat) } else if (dt_hr > 24) { - logger.error("only daily and sub-daily downscaling supported") + PEcAn.logger::logger.error("only daily and sub-daily downscaling supported") } return(downscaled.result) @@ -72,7 +72,7 @@ cfmet.downscale.subdaily <- function(subdailymet, output.dt = 1) { downscaled.result[["northward_wind"]] <- rep(subdailymet$northward_wind, each = tint) downscaled.result[["eastward_wind"]] <- rep(subdailymet$eastward_wind, each = tint) } else if (!'wind_speed' %in% colnames(subdailymet)){ - logger.error("no wind speed data") + PEcAn.logger::logger.error("no wind speed data") } downscaled.result[["wind_speed"]] <- rep(subdailymet$wind_speed, each = tint) @@ -168,7 +168,7 @@ cfmet.downscale.daily <- function(dailymet, output.dt = 1, lat) { wind_speed <- sqrt(northward_wind^2 + eastward_wind^2) } } else { - logger.error("no wind_speed found in daily met dataset") + PEcAn.logger::logger.error("no wind_speed found in daily met dataset") } ## Precipitation diff --git a/modules/data.atmosphere/R/upscale_met.R b/modules/data.atmosphere/R/upscale_met.R index b283ff2a36d..d447553abaa 100644 --- a/modules/data.atmosphere/R/upscale_met.R +++ b/modules/data.atmosphere/R/upscale_met.R @@ -25,7 +25,7 @@ upscale_met <- function(outfolder, input_met, resolution = 1/24, overwrite = FAL loc.file = file.path(outfolder, paste("upscaled", basename(input_met), sep = ".")) if (file.exists(loc.file) && !isTRUE(overwrite)){ - logger.severe("Output file", loc.file, "already exists. To replace it, set overwrite = TRUE") + PEcAn.logger::logger.severe("Output file", loc.file, "already exists. To replace it, set overwrite = TRUE") } met_lookup <- read.csv(system.file("/data/met.lookup.csv", package = "PEcAn.data.atmosphere"), diff --git a/modules/data.atmosphere/tests/testthat/test.download.CRUNCEP.R b/modules/data.atmosphere/tests/testthat/test.download.CRUNCEP.R index 4a760f67a27..95d725cc6f7 100644 --- a/modules/data.atmosphere/tests/testthat/test.download.CRUNCEP.R +++ b/modules/data.atmosphere/tests/testthat/test.download.CRUNCEP.R @@ -5,7 +5,7 @@ test_that("download works and returns a valid CF file", { # download is slow and was causing lots of Travis timeouts skip_on_travis() - logger.setLevel("WARN") + PEcAn.logger::logger.setLevel("WARN") tmpdir <- tempdir() on.exit(unlink(tmpdir, recursive = TRUE)) @@ -24,7 +24,7 @@ test_that("download works and returns a valid CF file", { expect_equal(cf_units, "days since 2000-01-01T00:00:00Z") # Expect that overwrite argument is respected - # The skip message comes from logger.error, + # The skip message comes fromPEcAn.logger::logger.error, # which writes to stderr but does not use message(). # If it did, this test would reduce to expect_message(download.CRUNCEP(...), "foo") msg <- capture.output(download.CRUNCEP(outfolder = tmpdir, @@ -36,4 +36,4 @@ test_that("download works and returns a valid CF file", { overwrite = FALSE), type = "message") expect_match(paste(msg, collapse="\n"), "already exists. Skipping") -}) \ No newline at end of file +}) diff --git a/modules/data.atmosphere/tests/testthat/test.load.cfmet.R b/modules/data.atmosphere/tests/testthat/test.load.cfmet.R index 8fabde218ad..647d15ca7bb 100644 --- a/modules/data.atmosphere/tests/testthat/test.load.cfmet.R +++ b/modules/data.atmosphere/tests/testthat/test.load.cfmet.R @@ -1,6 +1,6 @@ context("loading data from PEcAn-CF met drivers") -logger.setLevel("OFF") +PEcAn.logger::logger.setLevel("OFF") daily_file <- "data/urbana_daily_test.nc" subdaily_file <- "data/urbana_subdaily_test.nc" From 192e9a64669c9ea904979e5e393cb7efcccfe23a Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 18 Aug 2017 16:33:53 -0400 Subject: [PATCH 339/771] Cleanup LOTS of residual logger calls Also, add PEcAn.logger to all DESCRIPTION files. Also, fix PEcAn.all dependency in Makefile. --- Makefile | 8 +- base/all/DESCRIPTION | 1 + base/all/tests/testthat.R | 2 +- base/db/DESCRIPTION | 1 + base/db/R/dbfiles.R | 34 +-- base/db/R/query.trait.data.R | 4 +- base/db/tests/testthat.R | 2 +- base/settings/DESCRIPTION | 1 + base/settings/R/addSecrets.R | 12 +- base/settings/R/check.all.settings.R | 240 +++++++++--------- base/settings/R/clean.settings.R | 2 +- base/settings/R/fix.deprecated.settings.R | 16 +- base/settings/R/papply.R | 4 +- base/settings/R/read.settings.R | 14 +- base/settings/R/update.settings.R | 52 ++-- base/settings/R/write.settings.R | 2 +- base/settings/tests/testthat.R | 2 +- .../tests/testthat/test.deprecated.settings.R | 6 +- .../tests/testthat/test.read.settings.R | 4 +- base/utils/DESCRIPTION | 1 + base/utils/NAMESPACE | 22 ++ base/utils/R/convert.input.R | 60 ++--- base/utils/R/ensemble.R | 16 +- base/utils/R/get.analysis.filenames.r | 8 +- base/utils/R/get.model.output.R | 2 +- base/utils/R/get.parameter.samples.R | 14 +- base/utils/R/get.results.R | 12 +- base/utils/R/mail.R | 2 +- base/utils/R/open.tunnel.R | 8 +- base/utils/R/r2bugs.distributions.R | 2 +- base/utils/R/remote.R | 20 +- base/utils/R/run.write.configs.R | 16 +- base/utils/R/sensitivity.R | 4 +- base/utils/R/start.model.runs.R | 18 +- base/utils/R/status.R | 2 +- base/utils/R/utils.R | 14 +- base/utils/man/logger.debug.Rd | 11 + base/utils/tests/testthat.R | 2 +- base/visualization/DESCRIPTION | 1 + base/visualization/tests/testthat.R | 2 +- models/biocro/DESCRIPTION | 1 + models/biocro/R/met2model.BIOCRO.R | 8 +- models/biocro/R/write.configs.BIOCRO.R | 10 +- models/biocro/tests/testthat.R | 2 +- models/cable/DESCRIPTION | 1 + models/cable/R/met2model.CABLE.R | 2 +- models/cable/R/model2netcdf.CABLE.R | 2 +- models/cable/R/read_restart.CABLE.R | 2 +- models/cable/R/write.config.CABLE.R | 4 +- models/cable/R/write_restart.CABLE.R | 2 +- models/cable/tests/testthat.R | 2 +- models/clm45/DESCRIPTION | 1 + models/clm45/tests/testthat.R | 2 +- models/dalec/DESCRIPTION | 1 + models/dalec/R/met2model.DALEC.R | 14 +- models/dalec/R/write.configs.dalec.R | 2 +- models/ed/DESCRIPTION | 1 + models/ed/NAMESPACE | 1 - models/ed/R/met2model.ED2.R | 10 +- models/ed/R/model2netcdf.ED2.R | 31 ++- models/ed/R/veg2model.ED2.R | 8 +- models/ed/tests/testthat.R | 2 +- .../ed/tests/testthat/test.model2netcdf.ED2.R | 2 +- models/fates/DESCRIPTION | 1 + models/fates/R/met2model.FATES.R | 2 +- models/fates/R/model2netcdf.FATES.R | 11 +- models/fates/tests/testthat.R | 2 +- models/gday/DESCRIPTION | 1 + models/gday/NAMESPACE | 2 - models/gday/R/met2model.GDAY.R | 5 +- models/gday/tests/testthat.R | 2 +- models/jules/DESCRIPTION | 1 + models/jules/R/write.config.JULES.R | 6 +- models/jules/tests/testthat.R | 2 +- models/linkages/DESCRIPTION | 1 + models/linkages/R/met2model.LINKAGES.R | 2 +- models/linkages/tests/testthat.R | 2 +- models/lpjguess/DESCRIPTION | 1 + models/lpjguess/R/model2netcdf.LPJGUESS.R | 2 +- models/lpjguess/R/write.config.LPJGUESS.R | 2 +- models/lpjguess/tests/testthat.R | 2 +- models/maat/DESCRIPTION | 1 + models/maat/NAMESPACE | 4 - models/maat/R/met2model.MAAT.R | 5 +- models/maat/R/write.config.MAAT.R | 9 +- models/maat/inst/simple_workflow.R | 8 +- models/maat/tests/testthat.R | 2 +- models/maespa/DESCRIPTION | 1 + models/maespa/R/met2model.MAESPA.R | 6 +- models/maespa/tests/testthat.R | 2 +- models/preles/DESCRIPTION | 1 + models/preles/R/runPRELES.jobsh.R | 2 +- models/preles/tests/testthat.R | 2 +- models/sipnet/DESCRIPTION | 1 + models/sipnet/R/met2model.SIPNET.R | 6 +- models/sipnet/tests/testthat.R | 2 +- models/template/DESCRIPTION | 1 + models/template/R/met2model.MODEL.R | 2 +- models/template/R/model2netcdf.MODEL.R | 2 +- models/template/R/write.config.MODEL.R | 4 +- models/template/tests/testthat.R | 2 +- modules/allometry/DESCRIPTION | 1 + modules/allometry/tests/testthat.R | 2 +- modules/assim.batch/DESCRIPTION | 1 + modules/assim.batch/R/pda.bayesian.tools.R | 6 +- .../assim.batch/R/pda.bayestools.helpers.R | 2 +- modules/assim.batch/R/pda.emulator.R | 16 +- modules/assim.batch/R/pda.load.data.R | 2 +- modules/assim.batch/R/pda.mcmc.R | 4 +- modules/assim.batch/R/pda.mcmc.bs.R | 4 +- modules/assim.batch/R/pda.neff.R | 2 +- modules/assim.batch/R/pda.postprocess.R | 6 +- modules/assim.batch/R/pda.utils.R | 28 +- modules/assim.sequential/DESCRIPTION | 1 + .../assim.sequential/R/load_data_paleon_sda.R | 10 +- modules/benchmark/DESCRIPTION | 1 + modules/benchmark/R/calc_benchmark.R | 2 +- modules/benchmark/R/define_benchmark.R | 6 +- modules/data.atmosphere/DESCRIPTION | 1 + modules/data.atmosphere/tests/testthat.R | 2 +- modules/data.hydrology/DESCRIPTION | 1 + modules/data.hydrology/tests/testthat.R | 2 +- modules/data.land/DESCRIPTION | 1 + modules/data.land/R/extract_FIA.R | 22 +- modules/data.land/R/extract_veg.R | 4 +- modules/data.land/R/fia2ED.R | 42 +-- modules/data.land/R/get.veg.module.R | 2 +- modules/data.land/R/load_veg.R | 4 +- modules/data.land/R/put.veg.module.R | 4 +- modules/data.land/R/write_ic.R | 2 +- modules/data.land/tests/testthat.R | 2 +- modules/data.mining/DESCRIPTION | 2 + modules/data.mining/tests/testthat.R | 2 +- modules/data.remote/DESCRIPTION | 1 + modules/emulator/DESCRIPTION | 1 + modules/meta.analysis/DESCRIPTION | 1 + modules/meta.analysis/R/jagify.R | 2 +- .../meta.analysis/R/meta.analysis.summary.R | 8 +- modules/meta.analysis/R/run.meta.analysis.R | 24 +- modules/meta.analysis/R/single.MA.R | 2 +- modules/meta.analysis/tests/testthat.R | 2 +- modules/photosynthesis/DESCRIPTION | 1 + modules/priors/DESCRIPTION | 2 + modules/priors/R/priors.R | 4 +- modules/priors/tests/testthat.R | 2 +- modules/rtm/DESCRIPTION | 1 + modules/uncertainty/DESCRIPTION | 1 + modules/uncertainty/R/run.ensemble.analysis.R | 18 +- .../uncertainty/R/run.sensitivity.analysis.R | 8 +- modules/uncertainty/tests/testthat.R | 2 +- qaqc/DESCRIPTION | 2 + qaqc/tests/testthat.R | 2 +- scripts/workflow.bm.R | 2 +- shiny/global-sensitivity/load_ensemble.R | 2 +- tests/interactive-workflow.R | 8 +- 155 files changed, 602 insertions(+), 546 deletions(-) create mode 100644 base/utils/man/logger.debug.Rd diff --git a/Makefile b/Makefile index a1188a08e4f..ca7c4991855 100644 --- a/Makefile +++ b/Makefile @@ -39,10 +39,10 @@ ALL_PKGS_D := $(BASE_D) $(MODELS_D) $(MODULES_D) .doc/models/template all: install document -document: .doc/all -install: .install/all -check: .check/all -test: .test/all +document: .doc/base/all +install: .install/base/all +check: .check/base/all +test: .test/base/all ### Dependencies .doc/all: $(ALL_PKGS_D) diff --git a/base/all/DESCRIPTION b/base/all/DESCRIPTION index 3c00a91e4e7..4af39ff46c2 100644 --- a/base/all/DESCRIPTION +++ b/base/all/DESCRIPTION @@ -18,6 +18,7 @@ Depends: PEcAn.DB, PEcAn.settings, PEcAn.MA, + PEcAn.logger, PEcAn.utils, PEcAn.uncertainty, PEcAn.data.atmosphere, diff --git a/base/all/tests/testthat.R b/base/all/tests/testthat.R index 107138eef92..99550795433 100644 --- a/base/all/tests/testthat.R +++ b/base/all/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) test_check("PEcAn.all") diff --git a/base/db/DESCRIPTION b/base/db/DESCRIPTION index 69f85d36030..01a546e9d2c 100644 --- a/base/db/DESCRIPTION +++ b/base/db/DESCRIPTION @@ -15,6 +15,7 @@ Depends: DBI, PEcAn.utils Imports: + PEcAn.logger, plyr (>= 1.8.4) Suggests: RPostgreSQL, diff --git a/base/db/R/dbfiles.R b/base/db/R/dbfiles.R index dae1d114936..9ad11d724e3 100644 --- a/base/db/R/dbfiles.R +++ b/base/db/R/dbfiles.R @@ -74,7 +74,7 @@ dbfile.input.insert <- function(in.path, in.prefix, siteid, startdate, enddate, if(is.null(inputid) && !allow.conflicting.dates) { print(existing.input, digits=10) - logger.error(paste0( + PEcAn.logger::logger.error(paste0( "Duplicate inputs (in terms of site_id, name, and format_id) with differing ", "start/end dates are not allowed. The existing input record printed above would ", " conflict with the one to be inserted, which has requested start/end dates of ", @@ -111,12 +111,12 @@ dbfile.input.insert <- function(in.path, in.prefix, siteid, startdate, enddate, if(nrow(dbfile) > 0) { if(nrow(dbfile) > 1) { print(dbfile) - logger.warn("Multiple dbfiles found. Using last.") + PEcAn.logger::logger.warn("Multiple dbfiles found. Using last.") dbfile <- dbfile[nrow(dbfile),] } if(dbfile$file_name != in.prefix || dbfile$file_path != in.path) { print(dbfile, digits=10) - logger.error(paste0( + PEcAn.logger::logger.error(paste0( "The existing dbfile record printed above has the same machine_id and container ", "but a diferent file name than expected (prefix='", in.prefix, "', path=", in.path, ").", "This is not allowed." @@ -205,7 +205,7 @@ dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, f } if(length(inputs$id) > 1){ - logger.warn("Found multiple matching inputs. Checking for one with associate files on host machine") + PEcAn.logger::logger.warn("Found multiple matching inputs. Checking for one with associate files on host machine") print(inputs) # ni = length(inputs$id) @@ -220,7 +220,7 @@ dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, f ## With the possibility of dbfile.check returning nothing, ## as.data.frame ensures a empty data.frame is returned ## rather than an empty list. - logger.info("File not found on host machine. Returning Valid input with file associated on different machine if possible") + PEcAn.logger::logger.info("File not found on host machine. Returning Valid input with file associated on different machine if possible") return(as.data.frame(dbfile.check('Input', inputs$id, con, hostname, machine.check = FALSE))) } @@ -232,7 +232,7 @@ dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, f }else{ - logger.warn("Found possible matching input. Checking if its associate files are on host machine") + PEcAn.logger::logger.warn("Found possible matching input. Checking if its associate files are on host machine") print(inputs) dbfile <- dbfile.check(type = 'Input', container.id = inputs$id, con = con, hostname = hostname, machine.check = TRUE) @@ -240,7 +240,7 @@ dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, f ## With the possibility of dbfile.check returning nothing, ## as.data.frame ensures an empty data.frame is returned ## rather than an empty list. - logger.info("File not found on host machine. Returning Valid input with file associated on different machine if possible") + PEcAn.logger::logger.info("File not found on host machine. Returning Valid input with file associated on different machine if possible") return(as.data.frame(dbfile.check(type = 'Input', container.id = inputs$id, con = con, hostname = hostname, machine.check = FALSE))) } @@ -276,7 +276,7 @@ dbfile.posterior.insert <- function(filename, pft, mimetype, formatname, con, ho # find appropriate pft pftid <- get.id("pfts", "name", pft, con) if (is.null(pftid)) { - logger.severe("Could not find pft, could not store file", filename) + PEcAn.logger::logger.severe("Could not find pft, could not store file", filename) } mimetypeid <- get.id('mimetypes', 'type_string', mimetype, con = con, create=TRUE) @@ -329,7 +329,7 @@ dbfile.posterior.check <- function(pft, mimetype, formatname, con, hostname=PEcA # find appropriate format mimetypeid <- get.id("mimetypes", "type_string", mimetype, con) - if(is.null(mimetypeid)) logger.error("mimetype ", mimetype, "does not exist") + if(is.null(mimetypeid)) PEcAn.logger::logger.error("mimetype ", mimetype, "does not exist") formatid <- get.id("formats", colnames = c("mimetype_id", "name"), values = c(mimetypeid, formatname), con) if (is.null(formatid)) { @@ -364,7 +364,7 @@ dbfile.posterior.check <- function(pft, mimetype, formatname, con, hostname=PEcA dbfile.insert <- function(in.path, in.prefix, type, id, con, reuse = TRUE, hostname=PEcAn.utils::fqdn()) { if (hostname == "localhost") hostname <- PEcAn.utils::fqdn() - if (substr(in.path, 1, 1) != '/') logger.error("path to dbfiles:", in.path, " is not a valid full path") + if (substr(in.path, 1, 1) != '/') PEcAn.logger::logger.error("path to dbfiles:", in.path, " is not a valid full path") # find appropriate host hostid <- get.id("machines", colname = "hostname", value = hostname, con, create=TRUE, dates=TRUE) @@ -397,7 +397,7 @@ dbfile.insert <- function(in.path, in.prefix, type, id, con, reuse = TRUE, hostn } else { if(dbfile$container_type != type || dbfile$container_id != id) { print(dbfile, digits=10) - logger.error(paste0( + PEcAn.logger::logger.error(paste0( "The existing dbfile record printed above has the same machine_id, file_path, and file_name ", "but is associated with a different input than requested (type='", type, "', id=", id, ").", "This is not allowed." @@ -448,7 +448,7 @@ dbfile.check <- function(type, container.id, con, hostname=PEcAn.utils::fqdn(), if(nrow(dbfiles) > 1 && !return.all){ - logger.warn("Multiple Valid Files found on host machine. Returning last updated record.") + PEcAn.logger::logger.warn("Multiple Valid Files found on host machine. Returning last updated record.") return(dbfiles[dbfiles$updated_at == max(dbfiles$updated_at),]) }else{ @@ -464,7 +464,7 @@ dbfile.check <- function(type, container.id, con, hostname=PEcAn.utils::fqdn(), if(nrow(dbfiles) > 1 && !return.all){ - logger.warn("Multiple Valid Files found on host machine. Returning last updated record.") + PEcAn.logger::logger.warn("Multiple Valid Files found on host machine. Returning last updated record.") return(dbfiles[dbfiles$updated_at == max(dbfiles$updated_at),]) }else{ @@ -501,12 +501,12 @@ dbfile.file <- function(type, id, con, hostname=PEcAn.utils::fqdn()) { files <- dbfile.check(type, id, con, hostname) if(nrow(files) > 1) { - logger.warn("multiple files found for", id, "returned; using the first one found") + PEcAn.logger::logger.warn("multiple files found for", id, "returned; using the first one found") invisible(file.path(files[1, 'file_path'], files[1, 'file_name'])) } else if (nrow(files) == 1) { invisible(file.path(files[1, 'file_path'], files[1, 'file_name'])) } else { - logger.warn("no files found for ", id, "in database") + PEcAn.logger::logger.warn("no files found for ", id, "in database") invisible(NA) } } @@ -545,12 +545,12 @@ dbfile.id <- function(type, file, con, hostname=PEcAn.utils::fqdn()) { ids <- db.query(paste0("SELECT container_id FROM dbfiles WHERE container_type='", type, "' AND file_path='", file_path, "' AND file_name='", file_name, "' AND machine_id=", hostid), con) if(nrow(ids) > 1) { - logger.warn("multiple ids found for", file, "returned; using the first one found") + PEcAn.logger::logger.warn("multiple ids found for", file, "returned; using the first one found") invisible(ids[1, 'container_id']) } else if (nrow(ids) == 1) { invisible(ids[1, 'container_id']) } else { - logger.warn("no id found for", file, "in database") + PEcAn.logger::logger.warn("no id found for", file, "in database") invisible(NA) } } diff --git a/base/db/R/query.trait.data.R b/base/db/R/query.trait.data.R index 0bac159cde4..3d6d928ad0c 100644 --- a/base/db/R/query.trait.data.R +++ b/base/db/R/query.trait.data.R @@ -40,7 +40,7 @@ fetch.stats2se <- function(connection, query){ ##' @author David LeBauer, Carl Davidson query.data <- function(trait, spstr, extra.columns='ST_X(ST_CENTROID(sites.geometry)) AS lon, ST_Y(ST_CENTROID(sites.geometry)) AS lat, ', con=NULL, store.unconverted=FALSE, ...) { if (is.null(con)) { - logger.error("No open database connection passed in.") + PEcAn.logger::logger.error("No open database connection passed in.") con <- db.open(settings$database$bety) on.exit(db.close(con)) } @@ -279,7 +279,7 @@ assign.treatments <- function(data){ #if only one treatment, it's control if(length(unique(data$trt_id[site.i])) == 1) data$trt_id[site.i] <- 'control' if(!'control' %in% data$trt_id[site.i]){ - logger.severe('No control treatment set for site_id:', + PEcAn.logger::logger.severe('No control treatment set for site_id:', unique(data$site_id[site.i]), 'and citation id', unique(data$citation_id[site.i]), diff --git a/base/db/tests/testthat.R b/base/db/tests/testthat.R index 81c96369427..b7d479f0d77 100644 --- a/base/db/tests/testthat.R +++ b/base/db/tests/testthat.R @@ -14,7 +14,7 @@ dbparms <- list(host = "localhost", driver = "PostgreSQL", user = "bety", dbname if(db.exists(dbparms)){ con <- db.open(dbparms) - logger.setQuitOnSevere(FALSE) + PEcAn.logger::logger.setQuitOnSevere(FALSE) test_check("PEcAn.DB") db.close(con) } diff --git a/base/settings/DESCRIPTION b/base/settings/DESCRIPTION index e36d071a7e8..b126c2d2658 100644 --- a/base/settings/DESCRIPTION +++ b/base/settings/DESCRIPTION @@ -14,6 +14,7 @@ Depends: PEcAn.utils, PEcAn.DB Imports: + PEcAn.logger, plyr (>= 1.8.4), lubridate (>= 1.6.0), XML (>= 3.98-1.3) diff --git a/base/settings/R/addSecrets.R b/base/settings/R/addSecrets.R index 442a631c7ae..9914d483e52 100644 --- a/base/settings/R/addSecrets.R +++ b/base/settings/R/addSecrets.R @@ -25,10 +25,10 @@ addSecrets <- function(settings, force=FALSE) { if(!force && !is.null(settings$settings.info$secrets.added) && settings$settings.info$secrets.added==TRUE) { - logger.info("Secret settings have been added already. Skipping.") + PEcAn.logger::logger.info("Secret settings have been added already. Skipping.") return(invisible(settings)) } else { - logger.info("Adding secret settings...") + PEcAn.logger::logger.info("Adding secret settings...") } if(is.MultiSettings(settings)) { @@ -41,9 +41,9 @@ addSecrets <- function(settings, force=FALSE) { for(key in c('database')) { for(section in names(pecan[[key]])) { if (section %in% names(settings[section])) { - logger.info("Already have a section for", section) + PEcAn.logger::logger.info("Already have a section for", section) } else { - logger.info("Imported section for", section) + PEcAn.logger::logger.info("Imported section for", section) settings[[key]][section] <- pecan[[key]][section] } } @@ -55,9 +55,9 @@ addSecrets <- function(settings, force=FALSE) { for(section in names(pecan[[key]])) { if (section %in% names(settings[section])) { - logger.info("Already have a section for", section) + PEcAn.logger::logger.info("Already have a section for", section) } else { - logger.info("Imported section for", section) + PEcAn.logger::logger.info("Imported section for", section) settings[[key]][section] <- pecan[[key]][section] } } diff --git a/base/settings/R/check.all.settings.R b/base/settings/R/check.all.settings.R index be2a299e487..41a93e91a05 100644 --- a/base/settings/R/check.all.settings.R +++ b/base/settings/R/check.all.settings.R @@ -15,7 +15,7 @@ check.inputs <- function(settings) { # don't know how to check inputs if (is.null(settings$database$bety)) { - logger.info("No database connection, can't check inputs.") + PEcAn.logger::logger.info("No database connection, can't check inputs.") return (settings) } @@ -40,9 +40,9 @@ check.inputs <- function(settings) { # check if tag exists if (is.null(settings$run$inputs[[tag]])) { if (inputs$required[i]) { - logger.warn("Missing required input :", tag) + PEcAn.logger::logger.warn("Missing required input :", tag) } else { - logger.info("Missing optional input :", tag) + PEcAn.logger::logger.info("Missing optional input :", tag) } next } @@ -52,12 +52,12 @@ check.inputs <- function(settings) { id <- settings$run$inputs[[tag]][['id']] file <- PEcAn.DB::dbfile.file("Input", id, dbcon, hostname) if (is.na(file)) { - logger.error("No file found for", tag, " and id", id, "on host", hostname) + PEcAn.logger::logger.error("No file found for", tag, " and id", id, "on host", hostname) } else { if (is.null(settings$run$inputs[[tag]][['path']])) { settings$run$inputs[[tag]]['path'] <- file } else if (file != settings$run$inputs[[tag]][['path']]) { - logger.warn("Input file and id do not match for ", tag) + PEcAn.logger::logger.warn("Input file and id do not match for ", tag) } } } else if ("path" %in% names(settings$run$inputs[[tag]])) { @@ -67,7 +67,7 @@ check.inputs <- function(settings) { settings$run$inputs[[tag]][['id']] <- id } } - logger.info("path",settings$run$inputs[[tag]][['path']]) + PEcAn.logger::logger.info("path",settings$run$inputs[[tag]][['path']]) # check to see if format is right type if ("id" %in% names(settings$run$inputs[[tag]])) { formats <- PEcAn.DB::db.query(paste0("SELECT format_id FROM inputs WHERE id=", settings$run$inputs[[tag]][['id']]), con=dbcon) @@ -77,15 +77,15 @@ check.inputs <- function(settings) { settings$run$inputs[[tag]][['path']] <- NULL ## zero out path, do_conversions will need to convert specified input ID to model format } } else { - logger.error("Could not check format of", tag, ".") + PEcAn.logger::logger.error("Could not check format of", tag, ".") } } - logger.info("path",settings$run$inputs[[tag]][['path']]) + PEcAn.logger::logger.info("path",settings$run$inputs[[tag]][['path']]) } } if (length(allinputs) > 0) { - logger.info("Unused inputs found :", paste(allinputs, collapse=" ")) + PEcAn.logger::logger.info("Unused inputs found :", paste(allinputs, collapse=" ")) } return(settings) @@ -101,23 +101,23 @@ check.database <- function(database) { ## check database settings if (is.null(database$driver)) { database$driver <- "PostgreSQL" - logger.warn("Please specify a database driver; using default 'PostgreSQL'") + PEcAn.logger::logger.warn("Please specify a database driver; using default 'PostgreSQL'") } # Attempt to load the driver if (!require(paste0("R", database$driver), character.only=TRUE)) { - logger.warn("Could not load the database driver", paste0("R", database$driver)) + PEcAn.logger::logger.warn("Could not load the database driver", paste0("R", database$driver)) } # MySQL specific checks if (database$driver == "MySQL") { if (!is.null(database$passwd)) { - logger.info("passwd in database section should be password for MySQL") + PEcAn.logger::logger.info("passwd in database section should be password for MySQL") database$password <- database$passwd database$passwd <- NULL } if (!is.null(database$name)) { - logger.info("name in database section should be dbname for MySQL") + PEcAn.logger::logger.info("name in database section should be dbname for MySQL") database$dbname <- database$name database$name <- NULL } @@ -126,12 +126,12 @@ check.database <- function(database) { # PostgreSQL specific checks if (database$driver == "PostgreSQL") { if (!is.null(database$passwd)) { - logger.info("passwd in database section should be password for PostgreSQL") + PEcAn.logger::logger.info("passwd in database section should be password for PostgreSQL") database$password <- database$passwd database$passwd <- NULL } if (!is.null(database$name)) { - logger.info("name in database section should be dbname for PostgreSQL") + PEcAn.logger::logger.info("name in database section should be dbname for PostgreSQL") database$dbname <- database$name database$name <- NULL } @@ -152,15 +152,15 @@ check.database <- function(database) { ## convert strings around from old format to new format if(is.null(database[["user"]])){ if (!is.null(database$userid)) { - logger.info("'userid' in database section should be 'user'") + PEcAn.logger::logger.info("'userid' in database section should be 'user'") database$user <- database$userid } else if (!is.null(database$username)) { - logger.info("'username' in database section should be 'user'") + PEcAn.logger::logger.info("'username' in database section should be 'user'") database$user <- database$username } else { - logger.info("no database user specified, using 'bety'") + PEcAn.logger::logger.info("no database user specified, using 'bety'") database$user <- "bety" } } @@ -175,11 +175,11 @@ check.database <- function(database) { } if (!PEcAn.DB::db.exists(params=database, FALSE, table=NA)) { - logger.severe("Invalid Database Settings : ", unlist(database)) + PEcAn.logger::logger.severe("Invalid Database Settings : ", unlist(database)) } # connected - logger.info("Successfully connected to database : ", unlist(database)) + PEcAn.logger::logger.info("Successfully connected to database : ", unlist(database)) # return fixed up database return(database) @@ -194,26 +194,26 @@ check.bety.version <- function(dbcon) { # there should always be a versin 1 if (! ("1" %in% versions)) { - logger.severe("No version 1, how did this database get created?") + PEcAn.logger::logger.severe("No version 1, how did this database get created?") } # check for specific version if (! ("20140617163304" %in% versions)) { - logger.severe("Missing migration 20140617163304, this associates files with models.") + PEcAn.logger::logger.severe("Missing migration 20140617163304, this associates files with models.") } if (! ("20140708232320" %in% versions)) { - logger.severe("Missing migration 20140708232320, this introduces geometry column in sites") + PEcAn.logger::logger.severe("Missing migration 20140708232320, this introduces geometry column in sites") } if (! ("20140729045640" %in% versions)) { - logger.severe("Missing migration 20140729045640, this introduces modeltypes table") + PEcAn.logger::logger.severe("Missing migration 20140729045640, this introduces modeltypes table") } if (! ("20151011190026" %in% versions)) { - logger.severe("Missing migration 20151011190026, this introduces notes and user_id in workflows") + PEcAn.logger::logger.severe("Missing migration 20151011190026, this introduces notes and user_id in workflows") } # check if database is newer if (tail(versions, n=1) > "20141009160121") { - logger.warn("Last migration", tail(versions, n=1), "is more recent than expected 20141009160121.", + PEcAn.logger::logger.warn("Last migration", tail(versions, n=1), "is more recent than expected 20141009160121.", "This could result in PEcAn not working as expected.") } } @@ -230,10 +230,10 @@ check.bety.version <- function(dbcon) { ##' @export check.settings check.settings <- function(settings, force=FALSE) { if(!force && !is.null(settings$settings.info$checked) && settings$settings.info$checked==TRUE) { - logger.info("Settings have been checked already. Skipping.") + PEcAn.logger::logger.info("Settings have been checked already. Skipping.") return(invisible(settings)) } else { - logger.info("Checking settings...") + PEcAn.logger::logger.info("Checking settings...") } if(is.MultiSettings(settings)) { @@ -255,18 +255,18 @@ check.settings <- function(settings, force=FALSE) { # make sure there are pfts defined if (is.null(settings$pfts) || (length(settings$pfts) == 0)) { - logger.warn("No PFTS specified.") + PEcAn.logger::logger.warn("No PFTS specified.") } # check to make sure a host is given if (is.null(settings$host$name)) { - logger.info("Setting localhost for execution host.") + PEcAn.logger::logger.info("Setting localhost for execution host.") settings$host$name <- "localhost" } # check if there is either ensemble or sensitivy.analysis if (is.null(settings$ensemble) && is.null(settings$sensitivity.analysis)) { - logger.warn("No ensemble or sensitivity analysis specified, no models will be executed!") + PEcAn.logger::logger.warn("No ensemble or sensitivity analysis specified, no models will be executed!") } settings <- papply(settings, check.run.settings, dbcon=dbcon) @@ -275,24 +275,24 @@ check.settings <- function(settings, force=FALSE) { if(!is.null(settings$meta.analysis)){ if (is.null(settings$meta.analysis$iter)) { settings$meta.analysis$iter <- 3000 - logger.info("Setting meta.analysis iterations to ", settings$meta.analysis$iter) + PEcAn.logger::logger.info("Setting meta.analysis iterations to ", settings$meta.analysis$iter) } if (is.null(settings$meta.analysis$random.effects)) { settings$meta.analysis$random.effects <- FALSE - logger.info("Setting meta.analysis random effects to ", settings$meta.analysis$random.effects) + PEcAn.logger::logger.info("Setting meta.analysis random effects to ", settings$meta.analysis$random.effects) } else { settings$meta.analysis$random.effects <- as.logical(settings$meta.analysis$random.effects) } if (is.null(settings$meta.analysis$threshold)) { settings$meta.analysis$threshold <- 1.2 - logger.info("Setting meta.analysis threshold to ", settings$meta.analysis$threshold) + PEcAn.logger::logger.info("Setting meta.analysis threshold to ", settings$meta.analysis$threshold) } if (is.null(settings$meta.analysis$update)) { settings$meta.analysis$update <- 'AUTO' - logger.info("Setting meta.analysis update to only update if no previous meta analysis was found") + PEcAn.logger::logger.info("Setting meta.analysis update to only update if no previous meta analysis was found") } if ((settings$meta.analysis$update != 'AUTO') && is.na(as.logical(settings$meta.analysis$update))) { - logger.info("meta.analysis update can only be AUTO/TRUE/FALSE, defaulting to FALSE") + PEcAn.logger::logger.info("meta.analysis update can only be AUTO/TRUE/FALSE, defaulting to FALSE") settings$meta.analysis$update <- FALSE } } @@ -308,15 +308,15 @@ check.settings <- function(settings, force=FALSE) { if ("qsub" %in% names(settings$host)) { if (is.null(settings$host$qsub)) { settings$host$qsub <- "qsub -V -N @NAME@ -o @STDOUT@ -e @STDERR@ -S /bin/bash" - logger.info("qsub not specified using default value :", settings$host$qsub) + PEcAn.logger::logger.info("qsub not specified using default value :", settings$host$qsub) } if (is.null(settings$host$qsub.jobid)) { settings$host$qsub.jobid <- "Your job ([0-9]+) .*" - logger.info("qsub.jobid not specified using default value :", settings$host$qsub.jobid) + PEcAn.logger::logger.info("qsub.jobid not specified using default value :", settings$host$qsub.jobid) } if (is.null(settings$host$qstat)) { settings$host$qstat <- "qstat -j @JOBID@ &> /dev/null || echo DONE" - logger.info("qstat not specified using default value :", settings$host$qstat) + PEcAn.logger::logger.info("qstat not specified using default value :", settings$host$qstat) } } @@ -324,31 +324,31 @@ check.settings <- function(settings, force=FALSE) { if ("modellauncher" %in% names(settings$host)) { if (is.null(settings$host$modellauncher$binary)) { settings$host$modellauncher$binary <- "modellauncher" - logger.info("binary not specified using default value :", settings$host$modellauncher$binary) + PEcAn.logger::logger.info("binary not specified using default value :", settings$host$modellauncher$binary) } if (is.null(settings$host$modellauncher$qsub.extra)) { - logger.severe("qsub.extra not specified, can not launch in parallel environment.") + PEcAn.logger::logger.severe("qsub.extra not specified, can not launch in parallel environment.") } if (is.null(settings$host$modellauncher$mpirun)) { settings$host$modellauncher$mpirun <- "mpirun" - logger.info("mpirun not specified using default value :", settings$host$modellauncher$mpirun) + PEcAn.logger::logger.info("mpirun not specified using default value :", settings$host$modellauncher$mpirun) } } # some warnings for deprecated job.sh if ("job.sh" %in% names(settings$model)) { if ("prerun" %in% names(settings$model)) { - logger.severe("You have both settings$model$job.sh and settings$model$prerun, please combine.") + PEcAn.logger::logger.severe("You have both settings$model$job.sh and settings$model$prerun, please combine.") } - logger.info("settings$model$job.sh is deprecated use settings$model$prerun instead.") + PEcAn.logger::logger.info("settings$model$job.sh is deprecated use settings$model$prerun instead.") settings$model$prerun <- settings$model$job.sh settings$model$job.sh <- NULL } if ("job.sh" %in% names(settings$host)) { if ("prerun" %in% names(settings$host)) { - logger.severe("You have both settings$host$job.sh and settings$host$prerun, please combine.") + PEcAn.logger::logger.severe("You have both settings$host$job.sh and settings$host$prerun, please combine.") } - logger.info("settings$host$job.sh is deprecated use settings$host$prerun instead.") + PEcAn.logger::logger.info("settings$host$job.sh is deprecated use settings$host$prerun instead.") settings$host$prerun <- settings$host$job.sh settings$host$job.sh <- NULL } @@ -358,7 +358,7 @@ check.settings <- function(settings, force=FALSE) { settings$database$dbfiles <- full.path("~/.pecan/dbfiles") } else { if (substr(settings$database$dbfiles, 1, 1) != '/'){ - logger.warn("settings$database$dbfiles pathname", settings$database$dbfiles, " is invalid\n + PEcAn.logger::logger.warn("settings$database$dbfiles pathname", settings$database$dbfiles, " is invalid\n placing it in the home directory ", Sys.getenv("HOME")) settings$database$dbfiles <- file.path(Sys.getenv("HOME"), settings$database$dbfiles) } @@ -377,7 +377,7 @@ check.settings <- function(settings, force=FALSE) { settings$rundir <- file.path(settings$outdir, "run") } if (!file.exists(settings$rundir) && !dir.create(settings$rundir, recursive=TRUE)) { - logger.severe("Could not create run folder", settings$rundir) + PEcAn.logger::logger.severe("Could not create run folder", settings$rundir) } # check/create the local model out folder @@ -385,25 +385,25 @@ check.settings <- function(settings, force=FALSE) { settings$modeloutdir <- file.path(settings$outdir, "out") } if (!file.exists(settings$modeloutdir) && !dir.create(settings$modeloutdir, recursive=TRUE)) { - logger.severe("Could not create model out folder", settings$modeloutdir) + PEcAn.logger::logger.severe("Could not create model out folder", settings$modeloutdir) } # make sure remote folders are specified if need be if (!is.localhost(settings$host)) { if (is.null(settings$host$folder)) { settings$host$folder <- paste0(remote.execute.cmd("pwd", host=settings$host), "/pecan_remote") - logger.info("Using ", settings$host$folder, "to store output on remote machine") + PEcAn.logger::logger.info("Using ", settings$host$folder, "to store output on remote machine") } if (is.null(settings$host$rundir)) { settings$host$rundir <- paste0(settings$host$folder, "/@WORKFLOW@/run") } settings$host$rundir <- gsub("@WORKFLOW@", settings$workflow$id, settings$host$rundir) - logger.info("Using ", settings$host$rundir, "to store runs on remote machine") + PEcAn.logger::logger.info("Using ", settings$host$rundir, "to store runs on remote machine") if (is.null(settings$host$outdir)) { settings$host$outdir <- paste0(settings$host$folder, "/@WORKFLOW@/out") } settings$host$outdir <- gsub("@WORKFLOW@", settings$workflow$id, settings$host$outdir) - logger.info("Using ", settings$host$outdir, "to store output on remote machine") + PEcAn.logger::logger.info("Using ", settings$host$outdir, "to store output on remote machine") } else if (settings$host$name == "localhost") { settings$host$rundir <- settings$rundir settings$host$outdir <- settings$modeloutdir @@ -414,10 +414,10 @@ check.settings <- function(settings, force=FALSE) { for (i in 1:length(settings$pfts)) { #check if name tag within pft if (!"name" %in% names(settings$pfts[i]$pft)) { - logger.severe("No name specified for pft of index: ", i, ", please specify name") + PEcAn.logger::logger.severe("No name specified for pft of index: ", i, ", please specify name") } if (settings$pfts[i]$pft$name == "") { - logger.severe("Name specified for pft of index: ", i, " can not be empty.") + PEcAn.logger::logger.severe("Name specified for pft of index: ", i, " can not be empty.") } #check to see if name of each pft in xml file is actually a name of a pft already in database @@ -432,27 +432,27 @@ check.settings <- function(settings, force=FALSE) { " AND modeltypes.id=pfts.modeltype_id;"), con=dbcon) } if (nrow(x) == 0) { - logger.severe("Did not find a pft with name ", settings$pfts[i]$pft$name, + PEcAn.logger::logger.severe("Did not find a pft with name ", settings$pfts[i]$pft$name, "\nfor model type", settings$model$type) } if (nrow(x) > 1) { - logger.warn("Found multiple entries for pft with name ", settings$pfts[i]$pft$name, + PEcAn.logger::logger.warn("Found multiple entries for pft with name ", settings$pfts[i]$pft$name, "\nfor model type", settings$model$type) } } if (is.null(settings$pfts[i]$pft$outdir)) { settings$pfts[i]$pft$outdir <- file.path(settings$outdir, "pft", settings$pfts[i]$pft$name) - logger.info("Storing pft", settings$pfts[i]$pft$name, "in", settings$pfts[i]$pft$outdir) + PEcAn.logger::logger.info("Storing pft", settings$pfts[i]$pft$name, "in", settings$pfts[i]$pft$outdir) } else { - logger.debug("Storing pft", settings$pfts[i]$pft$name, "in", settings$pfts[i]$pft$outdir) + PEcAn.logger::logger.debug("Storing pft", settings$pfts[i]$pft$name, "in", settings$pfts[i]$pft$outdir) } out.dir <- settings$pfts[i]$pft$outdir if (!file.exists(out.dir) && !dir.create(out.dir, recursive=TRUE)) { if(identical(dir(out.dir), character(0))){ - logger.warn(out.dir, "exists but is empty") + PEcAn.logger::logger.warn(out.dir, "exists but is empty") } else { - logger.severe("Could not create folder", out.dir) + PEcAn.logger::logger.severe("Could not create folder", out.dir) } } } @@ -474,20 +474,20 @@ check.run.settings <- function(settings, dbcon=NULL) { # check for a run settings if (is.null(settings[['run']])) { - logger.warn("No Run Settings specified") + PEcAn.logger::logger.warn("No Run Settings specified") } # check start/end date are specified and correct if (is.null(settings$run$start.date)) { - logger.warn("No start.date specified in run section.") + PEcAn.logger::logger.warn("No start.date specified in run section.") } else if (is.null(settings$run$end.date)) { - logger.warn("No end.date specified in run section.") + PEcAn.logger::logger.warn("No end.date specified in run section.") } else { startdate <- lubridate::parse_date_time(settings$run$start.date, "ymd_HMS", truncated=3) enddate <- lubridate::parse_date_time(settings$run$end.date, "ymd_HMS", truncated=3) if (startdate >= enddate) { - logger.severe("Start date should come before the end date.") + PEcAn.logger::logger.severe("Start date should come before the end date.") } } @@ -495,57 +495,57 @@ check.run.settings <- function(settings, dbcon=NULL) { if (!is.null(settings$ensemble)) { if (is.null(settings$ensemble$variable)) { if (is.null(settings$sensitivity.analysis$variable)) { - logger.severe("No variable specified to compute ensemble for.") + PEcAn.logger::logger.severe("No variable specified to compute ensemble for.") } - logger.info("Setting ensemble variable to the same as sensitivity analysis variable [", settings$sensitivity.analysis$variable, "]") + PEcAn.logger::logger.info("Setting ensemble variable to the same as sensitivity analysis variable [", settings$sensitivity.analysis$variable, "]") settings$ensemble$variable <- settings$sensitivity.analysis$variable } if (is.null(settings$ensemble$size)) { - logger.info("Setting ensemble size to 1.") + PEcAn.logger::logger.info("Setting ensemble size to 1.") settings$ensemble$size <- 1 } if(is.null(settings$ensemble$start.year)) { if(!is.null(settings$run$start.date)) { settings$ensemble$start.year <- lubridate::year(settings$run$start.date) - logger.info("No start date passed to ensemble - using the run date (", + PEcAn.logger::logger.info("No start date passed to ensemble - using the run date (", settings$ensemble$start.year, ").") } else if(!is.null(settings$sensitivity.analysis$start.year)) { settings$ensemble$start.year <- settings$sensitivity.analysis$start.year - logger.info("No start date passed to ensemble - using the sensitivity.analysis date (", + PEcAn.logger::logger.info("No start date passed to ensemble - using the sensitivity.analysis date (", settings$ensemble$start.year, ").") } else { - logger.info("No start date passed to ensemble, and no default available.") + PEcAn.logger::logger.info("No start date passed to ensemble, and no default available.") } } if(is.null(settings$ensemble$end.year)) { if(!is.null(settings$run$end.date)) { settings$ensemble$end.year <- lubridate::year(settings$run$end.date) - logger.info("No end date passed to ensemble - using the run date (", + PEcAn.logger::logger.info("No end date passed to ensemble - using the run date (", settings$ensemble$end.year, ").") } else if(!is.null(settings$sensitivity.analysis$end.year)){ settings$ensemble$end.year <- settings$sensitivity.analysis$end.year - logger.info("No end date passed to ensemble - using the sensitivity.analysis date (", + PEcAn.logger::logger.info("No end date passed to ensemble - using the sensitivity.analysis date (", settings$ensemble$end.year, ").") } else { - logger.info("No end date passed to ensemble, and no default available.") + PEcAn.logger::logger.info("No end date passed to ensemble, and no default available.") } } # check start and end dates if (exists("startdate") && !is.null(settings$ensemble$start.year) && lubridate::year(startdate) > settings$ensemble$start.year) { - logger.severe("Start year of ensemble should come after the start.date of the run") + PEcAn.logger::logger.severe("Start year of ensemble should come after the start.date of the run") } if (exists("enddate") && !is.null(settings$ensemble$end.year) && lubridate::year(enddate) < settings$ensemble$end.year) { - logger.severe("End year of ensemble should come before the end.date of the run") + PEcAn.logger::logger.severe("End year of ensemble should come before the end.date of the run") } if (!is.null(settings$ensemble$start.year) && !is.null(settings$ensemble$end.year) && settings$ensemble$start.year > settings$ensemble$end.year) { - logger.severe("Start year of ensemble should come before the end year of the ensemble") + PEcAn.logger::logger.severe("Start year of ensemble should come before the end year of the ensemble") } } @@ -553,9 +553,9 @@ check.run.settings <- function(settings, dbcon=NULL) { if (!is.null(settings$sensitivity.analysis)) { if (is.null(settings$sensitivity.analysis$variable)) { if (is.null(settings$ensemble$variable)) { - logger.severe("No variable specified to compute sensitivity.analysis for.") + PEcAn.logger::logger.severe("No variable specified to compute sensitivity.analysis for.") } - logger.info("Setting sensitivity.analysis variable to the same as ensemble variable [", + PEcAn.logger::logger.info("Setting sensitivity.analysis variable to the same as ensemble variable [", settings$ensemble$variable, "]") settings$sensitivity.analysis$variable <- settings$ensemble$variable } @@ -563,28 +563,28 @@ check.run.settings <- function(settings, dbcon=NULL) { if(is.null(settings$sensitivity.analysis$start.year)) { if(!is.null(settings$run$start.date)) { settings$sensitivity.analysis$start.year <- lubridate::year(settings$run$start.date) - logger.info("No start date passed to sensitivity.analysis - using the run date (", + PEcAn.logger::logger.info("No start date passed to sensitivity.analysis - using the run date (", settings$sensitivity.analysis$start.year, ").") } else if(!is.null(settings$ensemble$start.year)) { settings$sensitivity.analysis$start.year <- settings$ensemble$start.year - logger.info("No start date passed to sensitivity.analysis - using the ensemble date (", + PEcAn.logger::logger.info("No start date passed to sensitivity.analysis - using the ensemble date (", settings$sensitivity.analysis$start.year, ").") } else { - logger.info("No start date passed to sensitivity.analysis, and no default available.") + PEcAn.logger::logger.info("No start date passed to sensitivity.analysis, and no default available.") } } if(is.null(settings$sensitivity.analysis$end.year)) { if(!is.null(settings$run$end.date)) { settings$sensitivity.analysis$end.year <- lubridate::year(settings$run$end.date) - logger.info("No end date passed to sensitivity.analysis - using the run date (", + PEcAn.logger::logger.info("No end date passed to sensitivity.analysis - using the run date (", settings$sensitivity.analysis$end.year, ").") } else if(!is.null(settings$ensemble$end.year)){ settings$sensitivity.analysis$end.year <- settings$ensemble$end.year - logger.info("No end date passed to sensitivity.analysis - using the ensemble date (", + PEcAn.logger::logger.info("No end date passed to sensitivity.analysis - using the ensemble date (", settings$sensitivity.analysis$end.year, ").") } else { - logger.info("No end date passed to sensitivity.analysis, and no default available.") + PEcAn.logger::logger.info("No end date passed to sensitivity.analysis, and no default available.") } } @@ -592,16 +592,16 @@ check.run.settings <- function(settings, dbcon=NULL) { # check start and end dates if (exists("startdate") && !is.null(settings$sensitivity.analysis$start.year) && lubridate::year(startdate) > settings$sensitivity.analysis$start.year) { - logger.severe("Start year of SA should come after the start.date of the run") + PEcAn.logger::logger.severe("Start year of SA should come after the start.date of the run") } if (exists("enddate") && !is.null(settings$sensitivity.analysis$end.year) && lubridate::year(enddate) < settings$sensitivity.analysis$end.year) { - logger.severe("End year of SA should come before the end.date of the run") + PEcAn.logger::logger.severe("End year of SA should come before the end.date of the run") } if (!is.null(settings$sensitivity.analysis$start.year) && !is.null(settings$sensitivity.analysis$end.year) && settings$sensitivity.analysis$start.year > settings$sensitivity.analysis$end.year) { - logger.severe("Start year of SA should come before the end year of the SA") + PEcAn.logger::logger.severe("Start year of SA should come before the end year of the SA") } } @@ -628,36 +628,36 @@ check.run.settings <- function(settings, dbcon=NULL) { if((!is.null(settings$run$site$met)) && settings$run$site$met == "NULL") settings$run$site$met <- NULL if (is.null(settings$run$site$name)) { if ((is.null(site$sitename) || site$sitename == "")) { - logger.info("No site name specified.") + PEcAn.logger::logger.info("No site name specified.") settings$run$site$name <- "NA" } else { settings$run$site$name <- site$sitename - logger.info("Setting site name to ", settings$run$site$name) + PEcAn.logger::logger.info("Setting site name to ", settings$run$site$name) } } else if (site$sitename != settings$run$site$name) { - logger.warn("Specified site name [", settings$run$site$name, "] does not match sitename in database [", site$sitename, "]") + PEcAn.logger::logger.warn("Specified site name [", settings$run$site$name, "] does not match sitename in database [", site$sitename, "]") } if (is.null(settings$run$site$lat)) { if ((is.null(site$lat) || site$lat == "")) { - logger.severe("No lat specified for site.") + PEcAn.logger::logger.severe("No lat specified for site.") } else { settings$run$site$lat <- as.numeric(site$lat) - logger.info("Setting site lat to ", settings$run$site$lat) + PEcAn.logger::logger.info("Setting site lat to ", settings$run$site$lat) } } else if (as.numeric(site$lat) != as.numeric(settings$run$site$lat)) { - logger.warn("Specified site lat [", settings$run$site$lat, "] does not match lat in database [", site$lat, "]") + PEcAn.logger::logger.warn("Specified site lat [", settings$run$site$lat, "] does not match lat in database [", site$lat, "]") } if (is.null(settings$run$site$lon)) { if ((is.null(site$lon) || site$lon == "")) { - logger.severe("No lon specified for site.") + PEcAn.logger::logger.severe("No lon specified for site.") } else { settings$run$site$lon <- as.numeric(site$lon) - logger.info("Setting site lon to ", settings$run$site$lon) + PEcAn.logger::logger.info("Setting site lon to ", settings$run$site$lon) } } else if (as.numeric(site$lon) != as.numeric(settings$run$site$lon)) { - logger.warn("Specified site lon [", settings$run$site$lon, "] does not match lon in database [", site$lon, "]") + PEcAn.logger::logger.warn("Specified site lon [", settings$run$site$lon, "] does not match lon in database [", site$lon, "]") } } } else { @@ -682,7 +682,7 @@ check.model.settings <- function(settings, dbcon=NULL) { if(as.numeric(settings$model$id) >= 0){ model <- PEcAn.DB::db.query(paste0("SELECT models.id AS id, models.revision AS revision, modeltypes.name AS type FROM models, modeltypes WHERE models.id=", settings$model$id, " AND models.modeltype_id=modeltypes.id;"), con=dbcon) if(nrow(model) == 0) { - logger.error("There is no record of model_id = ", settings$model$id, "in database") + PEcAn.logger::logger.error("There is no record of model_id = ", settings$model$id, "in database") } } else { model <- list() @@ -695,15 +695,15 @@ check.model.settings <- function(settings, dbcon=NULL) { paste0("AND revision like '%", settings$model$revision, "%' ")), "ORDER BY models.updated_at"), con=dbcon) if(nrow(model) > 1){ - logger.warn("multiple records for", settings$model$name, "returned; using the latest") + PEcAn.logger::logger.warn("multiple records for", settings$model$name, "returned; using the latest") row <- which.max(model$updated_at) if (length(row) == 0) row <- nrow(model) model <- model[row, ] } else if (nrow(model) == 0) { - logger.warn("Model type", settings$model$type, "not in database") + PEcAn.logger::logger.warn("Model type", settings$model$type, "not in database") } } else { - logger.warn("no model settings given") + PEcAn.logger::logger.warn("no model settings given") model <- list() } } else { @@ -714,41 +714,41 @@ check.model.settings <- function(settings, dbcon=NULL) { if (!is.null(model$id)) { if (is.null(settings$model$id) || (settings$model$id == "")) { settings$model$id <- model$id - logger.info("Setting model id to ", settings$model$id) + PEcAn.logger::logger.info("Setting model id to ", settings$model$id) } else if (settings$model$id != model$id) { - logger.warn("Model id specified in settings file does not match database.") + PEcAn.logger::logger.warn("Model id specified in settings file does not match database.") } } else { if (is.null(settings$model$id) || (settings$model$id == "")) { settings$model$id <- -1 - logger.info("Setting model id to ", settings$model$id) + PEcAn.logger::logger.info("Setting model id to ", settings$model$id) } } if (!is.null(model$type)) { if (is.null(settings$model$type) || (settings$model$type == "")) { settings$model$type <- model$type - logger.info("Setting model type to ", settings$model$type) + PEcAn.logger::logger.info("Setting model type to ", settings$model$type) } else if (settings$model$type != model$type) { - logger.warn("Model type specified in settings file does not match database.") + PEcAn.logger::logger.warn("Model type specified in settings file does not match database.") } } if (!is.null(model$revision)) { if (is.null(settings$model$revision) || (settings$model$revision == "")) { settings$model$revision <- model$revision - logger.info("Setting model revision to ", settings$model$revision) + PEcAn.logger::logger.info("Setting model revision to ", settings$model$revision) } else if (settings$model$revision != model$revision) { - logger.warn("Model revision specified in settings file does not match database.") + PEcAn.logger::logger.warn("Model revision specified in settings file does not match database.") } } # make sure we have model type if ((is.null(settings$model$type) || settings$model$type == "")) { - logger.severe("Need a model type.") + PEcAn.logger::logger.severe("Need a model type.") } # Set model$delete.raw to FALSE by default if (is.null(settings$model$delete.raw) || !is.logical(as.logical(settings$model$delete.raw))) { - logger.info("Option to delete raw model output not set or not logical. Will keep all model output.") + PEcAn.logger::logger.info("Option to delete raw model output not set or not logical. Will keep all model output.") settings$model$delete.raw = FALSE } @@ -758,13 +758,13 @@ check.model.settings <- function(settings, dbcon=NULL) { if (!is.na(binary)) { if (is.null(settings$model$binary)) { settings$model$binary <- binary - logger.info("Setting model binary to ", settings$model$binary) + PEcAn.logger::logger.info("Setting model binary to ", settings$model$binary) } else if (binary != settings$model$binary) { - logger.warn("Specified binary [", settings$model$binary, "] does not match path in database [", binary, "]") + PEcAn.logger::logger.warn("Specified binary [", settings$model$binary, "] does not match path in database [", binary, "]") } } } else { - logger.warn("No model binary sepcified in database for model ", settings$model$type) + PEcAn.logger::logger.warn("No model binary sepcified in database for model ", settings$model$type) } } @@ -806,9 +806,9 @@ check.workflow.settings <- function(settings, dbcon=NULL) { if (substr(settings$outdir, 1, 1) != '/') { settings$outdir <- file.path(getwd(), settings$outdir) } - logger.info("output folder =", settings$outdir) + PEcAn.logger::logger.info("output folder =", settings$outdir) if (!file.exists(settings$outdir) && !dir.create(settings$outdir, recursive=TRUE)) { - logger.severe("Could not create folder", settings$outdir) + PEcAn.logger::logger.severe("Could not create folder", settings$outdir) } #update workflow @@ -835,20 +835,20 @@ check.database.settings <- function(settings) { if (!is.null(settings$database$bety)) { # should runs be written to database if (is.null(settings$database$bety$write)) { - logger.info("Writing all runs/configurations to database.") + PEcAn.logger::logger.info("Writing all runs/configurations to database.") settings$database$bety$write <- TRUE } else { settings$database$bety$write <- as.logical(settings$database$bety$write) if (settings$database$bety$write) { - logger.debug("Writing all runs/configurations to database.") + PEcAn.logger::logger.debug("Writing all runs/configurations to database.") } else { - logger.warn("Will not write runs/configurations to database.") + PEcAn.logger::logger.warn("Will not write runs/configurations to database.") } } # check if we can connect to the database with write permissions if (settings$database$bety$write && !PEcAn.DB::db.exists(params=settings$database$bety, TRUE, table='users')) { - logger.severe("Invalid Database Settings : ", unlist(settings$database)) + PEcAn.logger::logger.severe("Invalid Database Settings : ", unlist(settings$database)) } # TODO check userid and userpassword @@ -860,10 +860,10 @@ check.database.settings <- function(settings) { # check database version check.bety.version(dbcon) } else { - logger.warn("No BETY database information specified; not using database.") + PEcAn.logger::logger.warn("No BETY database information specified; not using database.") } } else { - logger.warn("No BETY database information specified; not using database.") + PEcAn.logger::logger.warn("No BETY database information specified; not using database.") } return(settings) } diff --git a/base/settings/R/clean.settings.R b/base/settings/R/clean.settings.R index e0c1bf35dab..fba28a4b7bf 100644 --- a/base/settings/R/clean.settings.R +++ b/base/settings/R/clean.settings.R @@ -24,7 +24,7 @@ ##' } clean.settings <- function(inputfile = "pecan.xml", outputfile = "pecan.xml", write=TRUE) { if (is.null(inputfile) || !file.exists(inputfile)) { - logger.severe("Could not find input file.") + PEcAn.logger::logger.severe("Could not find input file.") } settings <- XML::xmlToList(XML::xmlParse(inputfile)) diff --git a/base/settings/R/fix.deprecated.settings.R b/base/settings/R/fix.deprecated.settings.R index c272b2ea78e..c18272a1c6c 100644 --- a/base/settings/R/fix.deprecated.settings.R +++ b/base/settings/R/fix.deprecated.settings.R @@ -16,10 +16,10 @@ fix.deprecated.settings <- function(settings, force=FALSE) { if(!force && !is.null(settings$settings.info$deprecated.settings.fixed) && settings$settings.info$deprecated.settings.fixed==TRUE) { - logger.info("Deprecated settings have been fixed already. Skipping.") + PEcAn.logger::logger.info("Deprecated settings have been fixed already. Skipping.") return(invisible(settings)) } else { - logger.info("Fixing deprecated settings...") + PEcAn.logger::logger.info("Fixing deprecated settings...") } if(is.MultiSettings(settings)) { @@ -29,9 +29,9 @@ fix.deprecated.settings <- function(settings, force=FALSE) { # settings$model$jobtemplate if(!is.null(settings$run$jobtemplate)) { if(!is.null(settings$model$jobtemplate)) { - logger.severe("You have both deprecated settings$run$jobtemplate and settings$model$jobtemplate. Use latter only.") + PEcAn.logger::logger.severe("You have both deprecated settings$run$jobtemplate and settings$model$jobtemplate. Use latter only.") } - logger.info("settings$run$jobtemplate is deprecated. uwe settings$model$jobtemplate instead") + PEcAn.logger::logger.info("settings$run$jobtemplate is deprecated. uwe settings$model$jobtemplate instead") settings$model$jobtemplate <- settings$run$jobtemplate settings$run$jobtemplate <- NULL } @@ -39,9 +39,9 @@ fix.deprecated.settings <- function(settings, force=FALSE) { # settings$database$dbfiles if(!is.null(settings$run$dbfiles)) { if(!is.null(settings$database$dbfiles)) { - logger.severe("You have both deprecated settings$run$dbfiles and settings$database$dbfiles. Use latter only.") + PEcAn.logger::logger.severe("You have both deprecated settings$run$dbfiles and settings$database$dbfiles. Use latter only.") } - logger.info("settings$run$dbfiles is deprecated. uwe settings$database$dbfiles instead") + PEcAn.logger::logger.info("settings$run$dbfiles is deprecated. uwe settings$database$dbfiles instead") settings$database$dbfiles <- settings$run$dbfiles settings$run$dbfiles <- NULL } @@ -49,9 +49,9 @@ fix.deprecated.settings <- function(settings, force=FALSE) { # settings$host if(!is.null(settings$run$host)) { if(!is.null(settings$host)) { - logger.severe("You have both deprecated settings$run$host and settings$host. Use latter only.") + PEcAn.logger::logger.severe("You have both deprecated settings$run$host and settings$host. Use latter only.") } - logger.info("settings$run$host is deprecated. uwe settings$host instead") + PEcAn.logger::logger.info("settings$run$host is deprecated. uwe settings$host instead") settings$host <- settings$run$host settings$run$host <- NULL } diff --git a/base/settings/R/papply.R b/base/settings/R/papply.R index 4a7e2e2bbd8..4d6896402f1 100644 --- a/base/settings/R/papply.R +++ b/base/settings/R/papply.R @@ -39,7 +39,7 @@ papply <- function(settings, fn, ..., stop.on.error = FALSE) { result <- list() errors <- character(0) for (i in seq_along(settings)) { - logger.debug(paste0("papply executing ", deparse(substitute(fn)), + PEcAn.logger::logger.debug(paste0("papply executing ", deparse(substitute(fn)), " on element ", i, " of ", length(settings), ".")) result.i <- try(fn(settings[[i]], ...), silent = TRUE) @@ -86,6 +86,6 @@ papply <- function(settings, fn, ..., stop.on.error = FALSE) { # Assume it's settings list that hasn't been coerced to Settings class... return(fn(as.Settings(settings), ...)) } else { - logger.severe("The function", fn, "requires input of type MultiSettings or Settings") + PEcAn.logger::logger.severe("The function", fn, "requires input of type MultiSettings or Settings") } } # papply diff --git a/base/settings/R/read.settings.R b/base/settings/R/read.settings.R index e68f1d2a32e..8a84e7c6287 100644 --- a/base/settings/R/read.settings.R +++ b/base/settings/R/read.settings.R @@ -46,7 +46,7 @@ ##' } read.settings <- function(inputfile = "pecan.xml"){ if(inputfile == "") { - logger.warn("settings files specified as empty string; \n\t\tthis may be caused by an incorrect argument to system.file.") + PEcAn.logger::logger.warn("settings files specified as empty string; \n\t\tthis may be caused by an incorrect argument to system.file.") } loc <- which(commandArgs() == "--settings") @@ -55,7 +55,7 @@ read.settings <- function(inputfile = "pecan.xml"){ # 1 filename is passed as argument to R for(idx in loc) { if (!is.null(commandArgs()[idx+1]) && file.exists(commandArgs()[idx+1])) { - logger.info("Loading --settings=", commandArgs()[idx+1]) + PEcAn.logger::logger.info("Loading --settings=", commandArgs()[idx+1]) xml <- XML::xmlParse(commandArgs()[idx+1]) break } @@ -63,21 +63,21 @@ read.settings <- function(inputfile = "pecan.xml"){ ## if settings file on $PATH } else if (file.exists(Sys.getenv("PECAN_SETTINGS"))) { # 2 load from PECAN_SETTINGS - logger.info("Loading PECAN_SETTINGS=", Sys.getenv("PECAN_SETTINGS")) + PEcAn.logger::logger.info("Loading PECAN_SETTINGS=", Sys.getenv("PECAN_SETTINGS")) xml <- XML::xmlParse(Sys.getenv("PECAN_SETTINGS")) ## if settings file passed to read.settings function } else if(!is.null(inputfile) && file.exists(inputfile)) { # 3 filename passed into function - logger.info("Loading inpufile=", inputfile) + PEcAn.logger::logger.info("Loading inpufile=", inputfile) xml <- XML::xmlParse(inputfile) ## use pecan.xml in cwd only if none exists } else if (file.exists("pecan.xml")) { # 4 load ./pecan.xml - logger.info("Loading ./pecan.xml") + PEcAn.logger::logger.info("Loading ./pecan.xml") xml <- XML::xmlParse("pecan.xml") } else { # file not found - logger.severe("Could not find a pecan.xml file") + PEcAn.logger::logger.severe("Could not find a pecan.xml file") } ## convert the xml to a list @@ -91,4 +91,4 @@ read.settings <- function(inputfile = "pecan.xml"){ } return(invisible(settings)) -} \ No newline at end of file +} diff --git a/base/settings/R/update.settings.R b/base/settings/R/update.settings.R index 9c414760574..8f5ab053855 100644 --- a/base/settings/R/update.settings.R +++ b/base/settings/R/update.settings.R @@ -19,10 +19,10 @@ update.settings <- function(settings, force=FALSE) { if(!force && !is.null(settings$settings.info$settings.updated) && settings$settings.info$settings.updated==TRUE) { - logger.info("Deprecated settings have been fixed already. Skipping.") + PEcAn.logger::logger.info("Deprecated settings have been fixed already. Skipping.") return(invisible(settings)) } else { - logger.info("Fixing deprecated settings...") + PEcAn.logger::logger.info("Fixing deprecated settings...") } if(is.MultiSettings(settings)) { @@ -35,10 +35,10 @@ update.settings <- function(settings, force=FALSE) { # simple check to make sure the database tag is updated if (!is.null(settings$database$dbname)) { if (!is.null(settings$database$bety)) { - logger.severe("Please remove dbname etc from database configuration.") + PEcAn.logger::logger.severe("Please remove dbname etc from database configuration.") } - logger.info("Database tag has changed, please use to store", + PEcAn.logger::logger.info("Database tag has changed, please use to store", "information about accessing the BETY database. See also", "https://github.com/PecanProject/pecan/wiki/PEcAn-Configuration#database-access.") @@ -51,7 +51,7 @@ update.settings <- function(settings, force=FALSE) { # warn user about change and update settings if (!is.null(settings$bety$write)) { - logger.warn(" is now part of the database settings. For more", + PEcAn.logger::logger.warn(" is now part of the database settings. For more", "information about the database settings see", "https://github.com/PecanProject/pecan/wiki/PEcAn-Configuration#database-access.") if (is.null(settings$database$bety$write)) { @@ -66,13 +66,13 @@ update.settings <- function(settings, force=FALSE) { if (!is.null(settings$model$model_type)) { if (!is.null(settings$model$type)) { if (settings$model$model_type != settings$model$type) { - logger.severe("Please remove model_type from model configuration.") + PEcAn.logger::logger.severe("Please remove model_type from model configuration.") } else { - logger.info("Please remove model_type from model configuration.") + PEcAn.logger::logger.info("Please remove model_type from model configuration.") } } - logger.info("Model tag has changed, please use to specify", + PEcAn.logger::logger.info("Model tag has changed, please use to specify", "type of model. See also", "https://github.com/PecanProject/pecan/wiki/PEcAn-Configuration#model_setup.") settings$model$type <- settings$model$model_type @@ -81,13 +81,13 @@ update.settings <- function(settings, force=FALSE) { if (!is.null(settings$model$name)) { if (!is.null(settings$model$type)) { if (settings$model$name != settings$model$type) { - logger.severe("Please remove name from model configuration.") + PEcAn.logger::logger.severe("Please remove name from model configuration.") } else { - logger.info("Please remove name from model configuration.") + PEcAn.logger::logger.info("Please remove name from model configuration.") } } - logger.info("Model tag has changed, please use to specify", + PEcAn.logger::logger.info("Model tag has changed, please use to specify", "type of model. See also", "https://github.com/PecanProject/pecan/wiki/PEcAn-Configuration#model_setup.") settings$model$type <- settings$model$name @@ -98,15 +98,15 @@ update.settings <- function(settings, force=FALSE) { if (!is.null(settings$run$site$met)) { if (!is.null(settings$run$inputs$met)) { if (settings$run$site$met != settings$run$inputs$met) { - logger.severe("Please remove met from model configuration.") + PEcAn.logger::logger.severe("Please remove met from model configuration.") } else { - logger.info("Please remove met from model configuration.") + PEcAn.logger::logger.info("Please remove met from model configuration.") } } if (is.null(settings$run$inputs)) { settings$run$inputs <- list() } - logger.info("Model tag has changed, please use to specify", + PEcAn.logger::logger.info("Model tag has changed, please use to specify", "met file for a run. See also", "https://github.com/PecanProject/pecan/wiki/PEcAn-Configuration#run_setup.") settings$run$inputs$met$path <- settings$run$site$met @@ -134,9 +134,9 @@ update.settings <- function(settings, force=FALSE) { if (tagid %in% names(settings$run$inputs)) { if ('id' %in% names(settings$run$inputs[[tag]])) { if (settings$run$inputs[[tagid]] != settings$run$inputs[[tag]][['id']]) { - logger.severe("Please remove", tagid, "from inputs configuration.") + PEcAn.logger::logger.severe("Please remove", tagid, "from inputs configuration.") } else { - logger.info("Please remove", tagid, "from inputs configuration.") + PEcAn.logger::logger.info("Please remove", tagid, "from inputs configuration.") } settings$run$inputs[[tagid]] <- NULL } else { @@ -151,15 +151,15 @@ update.settings <- function(settings, force=FALSE) { if (!is.null(settings$model$veg)) { if (!is.null(settings$run$inputs$veg)) { if (settings$model$veg != settings$run$inputs$veg) { - logger.severe("Please remove veg from model configuration.") + PEcAn.logger::logger.severe("Please remove veg from model configuration.") } else { - logger.info("Please remove veg from model configuration.") + PEcAn.logger::logger.info("Please remove veg from model configuration.") } } if (is.null(settings$run$inputs)) { settings$run$inputs <- list() } - logger.info("Model tag has changed, please use to specify", + PEcAn.logger::logger.info("Model tag has changed, please use to specify", "veg file for a run. See also", "https://github.com/PecanProject/pecan/wiki/PEcAn-Configuration#run_setup.") settings$run$inputs$veg <- settings$model$veg @@ -168,15 +168,15 @@ update.settings <- function(settings, force=FALSE) { if (!is.null(settings$model$soil)) { if (!is.null(settings$run$inputs$soil)) { if (settings$model$soil != settings$run$inputs$soil) { - logger.severe("Please remove soil from model configuration.") + PEcAn.logger::logger.severe("Please remove soil from model configuration.") } else { - logger.info("Please remove soil from model configuration.") + PEcAn.logger::logger.info("Please remove soil from model configuration.") } } if (is.null(settings$run$inputs)) { settings$run$inputs <- list() } - logger.info("Model tag has changed, please use to specify", + PEcAn.logger::logger.info("Model tag has changed, please use to specify", "soil file for a run. See also", "https://github.com/PecanProject/pecan/wiki/PEcAn-Configuration#run_setup.") settings$run$inputs$soil <- settings$model$soil @@ -184,12 +184,12 @@ update.settings <- function(settings, force=FALSE) { } if (!is.null(settings$model$psscss)) { if (!is.null(settings$run$inputs$pss)) { - logger.info("Please remove psscss from model configuration.") + PEcAn.logger::logger.info("Please remove psscss from model configuration.") } if (is.null(settings$run$inputs)) { settings$run$inputs <- list() } - logger.info("Model tag has changed, please use to specify", + PEcAn.logger::logger.info("Model tag has changed, please use to specify", "pss/css/site file for a run. See also", "https://github.com/PecanProject/pecan/wiki/PEcAn-Configuration#run_setup.") settings$run$inputs$pss <- file.path(settings$model$psscss, "foo.pss") @@ -199,12 +199,12 @@ update.settings <- function(settings, force=FALSE) { } if (!is.null(settings$model$inputs)) { if (!is.null(settings$run$inputs$inputs)) { - logger.info("Please remove inputs from model configuration.") + PEcAn.logger::logger.info("Please remove inputs from model configuration.") } if (is.null(settings$run$inputs)) { settings$run$inputs <- list() } - logger.info("Model tag has changed, please use to specify", + PEcAn.logger::logger.info("Model tag has changed, please use to specify", "lu/thsums file for a run. See also", "https://github.com/PecanProject/pecan/wiki/PEcAn-Configuration#run_setup.") settings$run$inputs$lu <- file.path(settings$model$inputs, "glu") diff --git a/base/settings/R/write.settings.R b/base/settings/R/write.settings.R index 477d2f48941..0bf22b6000f 100644 --- a/base/settings/R/write.settings.R +++ b/base/settings/R/write.settings.R @@ -12,7 +12,7 @@ write.settings <- function(settings, outputfile, outputdir=settings$outdir){ pecanfile <- file.path(outputdir, outputfile) if (file.exists(pecanfile)) { - logger.warn(paste("File already exists [", pecanfile, "] file will be overwritten")) + PEcAn.logger::logger.warn(paste("File already exists [", pecanfile, "] file will be overwritten")) } saveXML(listToXml(settings, "pecan"), file=pecanfile) } diff --git a/base/settings/tests/testthat.R b/base/settings/tests/testthat.R index a3e9c521477..ce3d8f46741 100644 --- a/base/settings/tests/testthat.R +++ b/base/settings/tests/testthat.R @@ -9,7 +9,7 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) # tests are disbabled until https://github.com/PecanProject/bety/issues/180 is # resolved. #test_check("PEcAn.settings") diff --git a/base/settings/tests/testthat/test.deprecated.settings.R b/base/settings/tests/testthat/test.deprecated.settings.R index 22f21d9cd7b..0fd82fe169d 100644 --- a/base/settings/tests/testthat/test.deprecated.settings.R +++ b/base/settings/tests/testthat/test.deprecated.settings.R @@ -7,8 +7,8 @@ ## which accompanies this distribution, and is available at ## http://opensource.ncsa.illinois.edu/license.html ## #------------------------------------------------------------------------------- -logger.setQuitOnSevere(FALSE) -logger.setLevel("OFF") +PEcAn.logger::logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setLevel("OFF") context("fix.deprecated.settings") source('get.test.settings.R') @@ -61,4 +61,4 @@ test_that("deprecated host settings handled correctly", { settings = fix.deprecated.settings(settings) expect_equal(settings$host, host) expect_null(settings$run$dbfiles) -}) \ No newline at end of file +}) diff --git a/base/settings/tests/testthat/test.read.settings.R b/base/settings/tests/testthat/test.read.settings.R index dc8bd770348..cd4930501e8 100644 --- a/base/settings/tests/testthat/test.read.settings.R +++ b/base/settings/tests/testthat/test.read.settings.R @@ -7,8 +7,8 @@ ## which accompanies this distribution, and is available at ## http://opensource.ncsa.illinois.edu/license.html ## #------------------------------------------------------------------------------- -logger.setQuitOnSevere(FALSE) -logger.setLevel("OFF") +PEcAn.logger::logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setLevel("OFF") context("tests for read.settings and related functions") source('get.test.settings.R') diff --git a/base/utils/DESCRIPTION b/base/utils/DESCRIPTION index 5d1b454c550..dd26232b044 100644 --- a/base/utils/DESCRIPTION +++ b/base/utils/DESCRIPTION @@ -21,6 +21,7 @@ Depends: abind, RCurl Imports: + PEcAn.logger, abind (>= 1.4.5), coda (>= 0.18), lubridate (>= 1.6.0), diff --git a/base/utils/NAMESPACE b/base/utils/NAMESPACE index b0c5f8edb2d..3636c8756f3 100644 --- a/base/utils/NAMESPACE +++ b/base/utils/NAMESPACE @@ -38,6 +38,17 @@ export(left.pad.zeros) export(listToArgString) export(listToXml) export(load.modelpkg) +export(logger.debug) +export(logger.error) +export(logger.getLevel) +export(logger.getLevelNumber) +export(logger.info) +export(logger.setLevel) +export(logger.setOutputFile) +export(logger.setQuitOnSevere) +export(logger.setWidth) +export(logger.severe) +export(logger.warn) export(misc.are.convertible) export(misc.convert) export(model2netcdf) @@ -82,3 +93,14 @@ export(write.ensemble.configs) export(write.sa.configs) export(zero.truncate) import(randtoolbox) +importFrom(PEcAn.logger,logger.debug) +importFrom(PEcAn.logger,logger.error) +importFrom(PEcAn.logger,logger.getLevel) +importFrom(PEcAn.logger,logger.getLevelNumber) +importFrom(PEcAn.logger,logger.info) +importFrom(PEcAn.logger,logger.setLevel) +importFrom(PEcAn.logger,logger.setOutputFile) +importFrom(PEcAn.logger,logger.setQuitOnSevere) +importFrom(PEcAn.logger,logger.setWidth) +importFrom(PEcAn.logger,logger.severe) +importFrom(PEcAn.logger,logger.warn) diff --git a/base/utils/R/convert.input.R b/base/utils/R/convert.input.R index b32f34e6287..2ca00dd2316 100644 --- a/base/utils/R/convert.input.R +++ b/base/utils/R/convert.input.R @@ -12,7 +12,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st allow.conflicting.dates = TRUE, insert.new.file = FALSE, pattern = NULL,...) { input.args <- list(...) - logger.debug(paste("Convert.Inputs", fcn, input.id, host$name, outfolder, formatname, + PEcAn.logger::logger.debug(paste("Convert.Inputs", fcn, input.id, host$name, outfolder, formatname, mimetype, site.id, start_date, end_date)) # TODO see issue #18 @@ -25,7 +25,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st outname <- tail(unlist(strsplit(outfolder, "/")), n = 1) - logger.info(paste("start CHECK Convert.Inputs", fcn, input.id, host$name, outfolder, + PEcAn.logger::logger.info(paste("start CHECK Convert.Inputs", fcn, input.id, host$name, outfolder, formatname, mimetype, site.id, start_date, end_date)) @@ -48,13 +48,13 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st ) - logger.debug("File id =", existing.dbfile$id, + PEcAn.logger::logger.debug("File id =", existing.dbfile$id, " File name =", existing.dbfile$file_name, " File path =", existing.dbfile$file_path, " Input id =", existing.dbfile$container_id, digits = 10) - logger.info("end CHECK for existing input record") + PEcAn.logger::logger.info("end CHECK for existing input record") if (nrow(existing.dbfile) > 0) { @@ -87,12 +87,12 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st # Schedule files to be replaced or deleted on exiting the function successful <- FALSE on.exit(if (exists("successful") && successful) { - logger.info("Conversion successful, with overwrite=TRUE. Deleting old files.") + PEcAn.logger::logger.info("Conversion successful, with overwrite=TRUE. Deleting old files.") remote.execute.R( file.deletion.commands$delete.tmp, host, user = NA, verbose = TRUE, R = Rbinary, scratchdir = outfolder ) } else { - logger.info("Conversion failed. Replacing old files.") + PEcAn.logger::logger.info("Conversion failed. Replacing old files.") remote.execute.R( file.deletion.commands$replace.from.tmp, host, user = NA, verbose = TRUE, R = Rbinary, scratchdir = outfolder ) @@ -113,15 +113,15 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st if (existing.machine$id != machine$id) { - logger.info("Valid Input record found that spans desired dates, but valid files do not exist on this machine.") - logger.info("Downloading all years of Valid input to ensure consistency") + PEcAn.logger::logger.info("Valid Input record found that spans desired dates, but valid files do not exist on this machine.") + PEcAn.logger::logger.info("Downloading all years of Valid input to ensure consistency") insert.new.file <- TRUE start_date <- existing.input$start_date end_date <- existing.input$end_date } else { # There's an existing input that spans desired start/end dates with files on this machine - logger.info("Skipping this input conversion because files are already available.") + PEcAn.logger::logger.info("Skipping this input conversion because files are already available.") return(list(input.id = existing.input$id, dbfile.id = existing.dbfile$id)) } @@ -145,13 +145,13 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st pattern = pattern ) - logger.debug("File id =", existing.dbfile$id, + PEcAn.logger::logger.debug("File id =", existing.dbfile$id, " File name =", existing.dbfile$file_name, " File path =", existing.dbfile$file_path, " Input id =", existing.dbfile$container_id, digits = 10) - logger.info("end CHECK for existing input record.") + PEcAn.logger::logger.info("end CHECK for existing input record.") if (nrow(existing.dbfile) > 0) { @@ -183,14 +183,14 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st # Schedule files to be replaced or deleted on exiting the function successful <- FALSE on.exit(if (exists("successful") && successful) { - logger.info("Conversion successful, with overwrite=TRUE. Deleting old files.") + PEcAn.logger::logger.info("Conversion successful, with overwrite=TRUE. Deleting old files.") remote.execute.R( file.deletion.commands$delete.tmp, host, user = NA, verbose = TRUE, R = Rbinary, scratchdir = outfolder ) } else { - logger.info("Conversion failed. Replacing old files.") + PEcAn.logger::logger.info("Conversion failed. Replacing old files.") remote.execute.R( file.deletion.commands$replace.from.tmp, host, user = NA, verbose = TRUE, R = Rbinary, scratchdir = outfolder ) @@ -210,14 +210,14 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st machine.host, "'"), con) if(existing.machine$id != machine$id){ - logger.info("Valid Input record found that spans desired dates, but valid files do not exist on this machine.") - logger.info("Downloading all years of Valid input to ensure consistency") + PEcAn.logger::logger.info("Valid Input record found that spans desired dates, but valid files do not exist on this machine.") + PEcAn.logger::logger.info("Downloading all years of Valid input to ensure consistency") insert.new.file <- TRUE start_date <- existing.input$start_date end_date <- existing.input$end_date } else { # There's an existing input that spans desired start/end dates with files on this machine - logger.info("Skipping this input conversion because files are already available.") + PEcAn.logger::logger.info("Skipping this input conversion because files are already available.") return(list(input.id = existing.input$id, dbfile.id = existing.dbfile$id)) } @@ -226,7 +226,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st # timeframe start_date <- min(start_date, existing.input$start_date) end_date <- max(end_date, existing.input$end_date) - logger.info( + PEcAn.logger::logger.info( paste0( "Changed start/end dates to '", start_date, @@ -255,7 +255,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st machine.host, "'"), con) if (nrow(machine) == 0) { - logger.error("machine not found", host$name) + PEcAn.logger::logger.error("machine not found", host$name) return(NULL) } @@ -264,18 +264,18 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st } else { input <- db.query(paste("SELECT * from inputs where id =", input.id), con) if (nrow(input) == 0) { - logger.error("input not found", input.id) + PEcAn.logger::logger.error("input not found", input.id) return(NULL) } dbfile <- db.query(paste("SELECT * from dbfiles where container_id =", input.id, " and container_type = 'Input' and machine_id =", machine$id), con) if (nrow(dbfile) == 0) { - logger.error("dbfile not found", input.id) + PEcAn.logger::logger.error("dbfile not found", input.id) return(NULL) } if (nrow(dbfile) > 1) { - logger.warn("multiple dbfile records, using last", dbfile) + PEcAn.logger::logger.warn("multiple dbfile records, using last", dbfile) dbfile <- dbfile[nrow(dbfile), ] } } @@ -305,7 +305,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st } else if (formatname == "LINKAGES met") { outputtype <- "linkages.dat" } else { - logger.severe(paste("Unknown formatname", formatname)) + PEcAn.logger::logger.severe(paste("Unknown formatname", formatname)) } } @@ -320,7 +320,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st out.html <- getURL(paste0("http://dap-dev.ncsa.illinois.edu:8184/inputs/", browndog$inputtype), .opts = curloptions) if (outputtype %in% unlist(strsplit(out.html, "\n"))) { - logger.info(paste("Conversion from", browndog$inputtype, "to", outputtype, + PEcAn.logger::logger.info(paste("Conversion from", browndog$inputtype, "to", outputtype, "through Brown Dog")) conversion <- "browndog" } @@ -401,18 +401,18 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st } cmdFcn <- paste0(pkg, "::", fcn, "(", arg.string, ")") - logger.debug(paste0("convert.input executing the following function:\n", cmdFcn)) + PEcAn.logger::logger.debug(paste0("convert.input executing the following function:\n", cmdFcn)) result <- remote.execute.R(script = cmdFcn, host, user = NA, verbose = TRUE, R = Rbinary, scratchdir = outfolder) } - logger.info("RESULTS: Convert.Input") - logger.info(result) - logger.info(names(result)) + PEcAn.logger::logger.info("RESULTS: Convert.Input") + PEcAn.logger::logger.info(result) + PEcAn.logger::logger.info(names(result)) if (length(result) <= 1){ - logger.debug(paste0("Processing data failed, please check validity of args:", arg.string)) - logger.severe(paste0("Unable to process data using this function:",fcn)) + PEcAn.logger::logger.debug(paste0("Processing data failed, please check validity of args:", arg.string)) + PEcAn.logger::logger.severe(paste0("Unable to process data using this function:",fcn)) } #--------------------------------------------------------------------------------------------------# @@ -477,7 +477,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st successful <- TRUE return(newinput) } else { - logger.warn("Input was not added to the database") + PEcAn.logger::logger.warn("Input was not added to the database") successful <- TRUE return(NULL) } diff --git a/base/utils/R/ensemble.R b/base/utils/R/ensemble.R index d77226f161b..08bb77ba93e 100644 --- a/base/utils/R/ensemble.R +++ b/base/utils/R/ensemble.R @@ -40,7 +40,7 @@ read.ensemble.output <- function(ensemble.size, pecandir, outdir, start.year, en ensemble.output <- list() for (row in rownames(ens.run.ids)) { run.id <- ens.run.ids[row, "id"] - logger.info("reading ensemble output from run id: ", run.id) + PEcAn.logger::logger.info("reading ensemble output from run id: ", run.id) for(var in seq_along(variables)){ out.tmp <- read.output(run.id, file.path(outdir, run.id), start.year, end.year, variables[var]) @@ -78,7 +78,7 @@ get.ensemble.samples <- function(ensemble.size, pft.samples, env.samples, method = "uniform", ...) { if (is.null(method)) { - logger.info("No sampling method supplied, defaulting to uniform random sampling") + PEcAn.logger::logger.info("No sampling method supplied, defaulting to uniform random sampling") method <- "uniform" } @@ -100,31 +100,31 @@ get.ensemble.samples <- function(ensemble.size, pft.samples, env.samples, random.samples <- NULL if (method == "halton") { - logger.info("Using ", method, "method for sampling") + PEcAn.logger::logger.info("Using ", method, "method for sampling") random.samples <- halton(n = ensemble.size, dim = total.sample.num, ...) ## force as a matrix in case length(samples)=1 random.samples <- as.matrix(random.samples) } else if (method == "sobol") { - logger.info("Using ", method, "method for sampling") + PEcAn.logger::logger.info("Using ", method, "method for sampling") random.samples <- sobol(n = ensemble.size, dim = total.sample.num, ...) ## force as a matrix in case length(samples)=1 random.samples <- as.matrix(random.samples) } else if (method == "torus") { - logger.info("Using ", method, "method for sampling") + PEcAn.logger::logger.info("Using ", method, "method for sampling") random.samples <- torus(n = ensemble.size, dim = total.sample.num, ...) ## force as a matrix in case length(samples)=1 random.samples <- as.matrix(random.samples) } else if (method == "lhc") { - logger.info("Using ", method, "method for sampling") + PEcAn.logger::logger.info("Using ", method, "method for sampling") random.samples <- lhc(t(matrix(0:1, ncol = total.sample.num, nrow = 2)), ensemble.size) } else if (method == "uniform") { - logger.info("Using ", method, "random sampling") + PEcAn.logger::logger.info("Using ", method, "random sampling") # uniform random random.samples <- matrix(runif(ensemble.size * total.sample.num), ensemble.size, total.sample.num) } else { - logger.info("Method ", method, " has not been implemented yet, using uniform random sampling") + PEcAn.logger::logger.info("Method ", method, " has not been implemented yet, using uniform random sampling") # uniform random random.samples <- matrix(runif(ensemble.size * total.sample.num), ensemble.size, diff --git a/base/utils/R/get.analysis.filenames.r b/base/utils/R/get.analysis.filenames.r index 92c4e4e3162..b67afa272c6 100644 --- a/base/utils/R/get.analysis.filenames.r +++ b/base/utils/R/get.analysis.filenames.r @@ -81,13 +81,13 @@ sensitivity.filename <- function(settings, ind <- which(sapply(settings$pfts, function(x) x$name) == pft) if (length(ind) == 0) { ## no match - logger.warn("sensitivity.filename: unmatched PFT = ", pft, " not among ", + PEcAn.logger::logger.warn("sensitivity.filename: unmatched PFT = ", pft, " not among ", sapply(settings$pfts, function(x) x$name)) sensitivity.dir <- file.path(settings$outdir, "pfts", pft) } else { if (length(ind) > 1) { ## multiple matches - logger.warn("sensitivity.filename: multiple matchs of PFT = ", pft, + PEcAn.logger::logger.warn("sensitivity.filename: multiple matchs of PFT = ", pft, " among ", sapply(settings$pfts, function(x) x$name), " USING") ind <- ind[1] } @@ -101,12 +101,12 @@ sensitivity.filename <- function(settings, dir.create(sensitivity.dir, showWarnings = FALSE, recursive = TRUE) if (!dir.exists(sensitivity.dir)) { - logger.error("sensitivity.filename: could not create directory, please check permissions ", + PEcAn.logger::logger.error("sensitivity.filename: could not create directory, please check permissions ", sensitivity.dir, " will try ", settings$outdir) if (dir.exists(settings$outdir)) { sensitivity.dir <- settings$outdir } else { - logger.error("sensitivity.filename: no OUTDIR ", settings$outdir) + PEcAn.logger::logger.error("sensitivity.filename: no OUTDIR ", settings$outdir) } } diff --git a/base/utils/R/get.model.output.R b/base/utils/R/get.model.output.R index 640a7ca3d87..af2ce092198 100644 --- a/base/utils/R/get.model.output.R +++ b/base/utils/R/get.model.output.R @@ -24,5 +24,5 @@ ##' ##' @author Michael Dietze, Shawn Serbin, David LeBauer get.model.output <- function(model, settings) { - logger.severe("Same as get.results(settings), please update your workflow") + PEcAn.logger::logger.severe("Same as get.results(settings), please update your workflow") } # get.model.output diff --git a/base/utils/R/get.parameter.samples.R b/base/utils/R/get.parameter.samples.R index b48bad739f1..08e6cf06271 100644 --- a/base/utils/R/get.parameter.samples.R +++ b/base/utils/R/get.parameter.samples.R @@ -30,7 +30,7 @@ get.parameter.samples <- function(settings, } ### End of for loop to extract pft names - logger.info("Selected PFT(s): ", pft.names) + PEcAn.logger::logger.info("Selected PFT(s): ", pft.names) ## Generate empty list arrays for output. trait.samples <- sa.samples <- ensemble.samples <- env.samples <- runs.samples <- list() @@ -75,22 +75,22 @@ get.parameter.samples <- function(settings, ## report which traits use MA results, which use priors if (length(ma.traits) > 0) { - logger.info("PFT", pft.names[i], "has MCMC samples for:\n", + PEcAn.logger::logger.info("PFT", pft.names[i], "has MCMC samples for:\n", paste0(ma.traits, collapse = "\n ")) } if (!all(priors %in% ma.traits)) { - logger.info("PFT", pft.names[i], "will use prior distributions for:\n", + PEcAn.logger::logger.info("PFT", pft.names[i], "will use prior distributions for:\n", paste0(priors[!priors %in% ma.traits], collapse = "\n ")) } } else { ma.traits <- NULL samples.num <- 20000 - logger.info("No MCMC results for PFT", pft.names[i]) - logger.info("PFT", pft.names[i], "will use prior distributions for", + PEcAn.logger::logger.info("No MCMC results for PFT", pft.names[i]) + PEcAn.logger::logger.info("PFT", pft.names[i], "will use prior distributions for", priors) } - logger.info("using ", samples.num, "samples per trait") + PEcAn.logger::logger.info("using ", samples.num, "samples per trait") for (prior in priors) { if (prior %in% ma.traits) { samples <- as.matrix(trait.mcmc[[prior]][, "beta.o"]) @@ -109,7 +109,7 @@ get.parameter.samples <- function(settings, sa.years <- data.frame(sa.start = settings$sensitivity.analysis$start.year, sa.end = settings$sensitivity.analysis$end.year) - logger.info("\n Selected Quantiles: ", vecpaste(round(quantiles, 3))) + PEcAn.logger::logger.info("\n Selected Quantiles: ", vecpaste(round(quantiles, 3))) ### Generate list of sample quantiles for SA run sa.samples <- get.sa.sample.list(pft = trait.samples, env = env.samples, diff --git a/base/utils/R/get.results.R b/base/utils/R/get.results.R index f99a17a3d76..c5933bfa992 100644 --- a/base/utils/R/get.results.R +++ b/base/utils/R/get.results.R @@ -44,7 +44,7 @@ get.results <- function(settings, sa.ensemble.id = NULL, ens.ensemble.id = NULL, } if (!file.exists(fname)) { - logger.severe("No sensitivity analysis samples file found!") + PEcAn.logger::logger.severe("No sensitivity analysis samples file found!") } load(fname) @@ -81,14 +81,14 @@ get.results <- function(settings, sa.ensemble.id = NULL, ens.ensemble.id = NULL, if ("variable" %in% names(settings$sensitivity.analysis)) { variable.sa <- settings$sensitivity.analysis[names(settings$sensitivity.analysis) == "variable"] } else { - logger.severe("no variable defined for sensitivity analysis") + PEcAn.logger::logger.severe("no variable defined for sensitivity analysis") } } # Only handling one variable at a time for now if (length(variable.sa) > 1) { variable.sa <- variable.sa[1] - logger.warn(paste0("Currently performs sensitivity analysis on only one variable at a time. Using first (", + PEcAn.logger::logger.warn(paste0("Currently performs sensitivity analysis on only one variable at a time. Using first (", variable.sa, ")")) } @@ -145,7 +145,7 @@ get.results <- function(settings, sa.ensemble.id = NULL, ens.ensemble.id = NULL, fname <- file.path(outdir, "samples.Rdata") } if (!file.exists(fname)) { - logger.severe("No ensemble samples file found!") + PEcAn.logger::logger.severe("No ensemble samples file found!") } load(fname) @@ -188,12 +188,12 @@ get.results <- function(settings, sa.ensemble.id = NULL, ens.ensemble.id = NULL, } if (is.null(variable.ens)) - logger.sever("No variables for ensemble analysis!") + PEcAn.logger::logger.sever("No variables for ensemble analysis!") # Only handling one variable at a time for now if (length(variable.ens) > 1) { variable.ens <- variable.ens[1] - logger.warn(paste0("Currently performs ensemble analysis on only one variable at a time. Using first (", + PEcAn.logger::logger.warn(paste0("Currently performs ensemble analysis on only one variable at a time. Using first (", variable.ens, ")")) } diff --git a/base/utils/R/mail.R b/base/utils/R/mail.R index b473de3a466..50ee429b72b 100644 --- a/base/utils/R/mail.R +++ b/base/utils/R/mail.R @@ -24,7 +24,7 @@ ##' } sendmail <- function(from, to, subject, body) { if (is.null(to)) { - logger.error("No receipient specified, mail is not send.") + PEcAn.logger::logger.error("No receipient specified, mail is not send.") } else { if (is.null(from)) { from <- to diff --git a/base/utils/R/open.tunnel.R b/base/utils/R/open.tunnel.R index a7c98b53c76..bc17beb7eca 100644 --- a/base/utils/R/open.tunnel.R +++ b/base/utils/R/open.tunnel.R @@ -30,12 +30,12 @@ open_tunnel <- function(remote_host,user=NULL,password=NULL,tunnel_dir = "~/.pec sshPassFile <- file.path(tunnel_dir,"password") if(file.exists(sshTunnel)){ - logger.warn("Tunnel already exists. If tunnel is not working try calling kill.tunnel then reopen") + PEcAn.logger::logger.warn("Tunnel already exists. If tunnel is not working try calling kill.tunnel then reopen") return(TRUE) } ## write password to temporary file - logger.warn(sshPassFile) + PEcAn.logger::logger.warn(sshPassFile) write(password,file = sshPassFile) # start <- system(paste0("ssh -nN -o ControlMaster=yes -o ControlPath=",sshTunnel," -l ",user," ",remote_host),wait = FALSE,input = password) @@ -49,7 +49,7 @@ open_tunnel <- function(remote_host,user=NULL,password=NULL,tunnel_dir = "~/.pec if(file.exists(sshPassFile)){ file.remove(sshPassFile) - logger.error("Tunnel open failed") + PEcAn.logger::logger.error("Tunnel open failed") return(FALSE) } @@ -60,4 +60,4 @@ open_tunnel <- function(remote_host,user=NULL,password=NULL,tunnel_dir = "~/.pec return(TRUE) } -} \ No newline at end of file +} diff --git a/base/utils/R/r2bugs.distributions.R b/base/utils/R/r2bugs.distributions.R index 3681c9f253e..b4c2e4ab49f 100644 --- a/base/utils/R/r2bugs.distributions.R +++ b/base/utils/R/r2bugs.distributions.R @@ -95,7 +95,7 @@ bugs.rdist <- function(prior = data.frame(distn = "norm", parama = 0, paramb = 1 } else if (grepl("chisq", prior$distn)) { model.string <- paste0("model{Y ~ d", prior$distn, "(", prior$parama, ")\n a <- x}") } else { - logger.severe(paste("Unknown model.string", model.string)) + PEcAn.logger::logger.severe(paste("Unknown model.string", model.string)) } writeLines(model.string, con = "test.bug") diff --git a/base/utils/R/remote.R b/base/utils/R/remote.R index 0e5bd5d4022..caacebc481c 100644 --- a/base/utils/R/remote.R +++ b/base/utils/R/remote.R @@ -39,19 +39,19 @@ remote.execute.cmd <- function(host, cmd, args = character(), stderr = FALSE) { } if ((host$name == "localhost") || (host$name == fqdn())) { - logger.debug(paste(cmd, args)) + PEcAn.logger::logger.debug(paste(cmd, args)) system2(cmd, args, stdout = TRUE, stderr = as.logical(stderr)) } else { remote <- c(host$name) if (!is.null(host$tunnel)) { if (!file.exists(host$tunnel)) { - logger.severe("Could not find tunnel", host$tunnel) + PEcAn.logger::logger.severe("Could not find tunnel", host$tunnel) } remote <- c("-o", paste0("ControlPath=\"", host$tunnel, "\""), remote) } else if (!is.null(host$user)) { remote <- c("-l", host$user, remote) } - logger.debug(paste(c("ssh", "-T", remote, cmd, args), collapse = " ")) + PEcAn.logger::logger.debug(paste(c("ssh", "-T", remote, cmd, args), collapse = " ")) system2("ssh", c("-T", remote, cmd, args), stdout = TRUE, stderr = as.logical(stderr)) } } # remote.execute.cmd @@ -91,7 +91,7 @@ remote.copy.from <- function(host, src, dst, delete = FALSE, stderr = FALSE) { if(!is.null(host$data_hostname)) hostname <- host$data_hostname if (!is.null(tunnel)) { if (!file.exists(tunnel)) { - logger.severe("Could not find tunnel", tunnel) + PEcAn.logger::logger.severe("Could not find tunnel", tunnel) } args <- c(args, "-e", paste0("ssh -o ControlPath=\"", tunnel, "\"", collapse = "")) @@ -102,7 +102,7 @@ remote.copy.from <- function(host, src, dst, delete = FALSE, stderr = FALSE) { args <- c(args, paste0(hostname, ":", src), dst) } } - logger.debug("rsync", shQuote(args)) + PEcAn.logger::logger.debug("rsync", shQuote(args)) system2("rsync", shQuote(args), stdout = TRUE, stderr = as.logical(stderr)) } # remote.copy.from @@ -141,7 +141,7 @@ remote.copy.to <- function(host, src, dst, delete = FALSE, stderr = FALSE) { if(!is.null(host$data_hostname)) hostname <- host$data_hostname if (!is.null(tunnel)) { if (!file.exists(tunnel)) { - logger.severe("Could not find tunnel", tunnel) + PEcAn.logger::logger.severe("Could not find tunnel", tunnel) } args <- c(args, "-e", paste0("ssh -o ControlPath=\"", tunnel, "\"", collapse = "")) @@ -152,7 +152,7 @@ remote.copy.to <- function(host, src, dst, delete = FALSE, stderr = FALSE) { args <- c(args, src, paste0(hostname, ":", dst)) } } - logger.debug("rsync", shQuote(args)) + PEcAn.logger::logger.debug("rsync", shQuote(args)) system2("rsync", shQuote(args), stdout = TRUE, stderr = as.logical(stderr)) } # remote.copy.to @@ -244,13 +244,13 @@ remote.execute.R <- function(script, host = "localhost", user = NA, verbose = FA remote <- c(host$name) if (!is.null(host$tunnel)) { if (!file.exists(host$tunnel)) { - logger.severe("Could not find tunnel", host$tunnel) + PEcAn.logger::logger.severe("Could not find tunnel", host$tunnel) } remote <- c("-o", paste0("ControlPath=\"", host$tunnel, "\""), remote) } else if (!is.null(host$user)) { remote <- c("-l", host$user, remote) } - logger.debug(paste(c("ssh", "-T", remote, R), collapse = " ")) + PEcAn.logger::logger.debug(paste(c("ssh", "-T", remote, R), collapse = " ")) result <- system2("ssh", c("-T", remote, R, "--no-save","--no-restore"), stdout = verbose, stderr = verbose, input = input) remote.copy.from(host, tmpfile, uuid) @@ -289,7 +289,7 @@ remote.copy.update <- function(input_id, remote_dir, remote_file_name = NULL, ho if(is.null(remote_file_name)){ local_file_name <- local_file_record$file_name if(length(local_file_name) > 1){ - logger.warn(paste0("Multiple file names found in the DB and no remote file name provided. Using the first file name for remote file name: ", + PEcAn.logger::logger.warn(paste0("Multiple file names found in the DB and no remote file name provided. Using the first file name for remote file name: ", local_file_record$file_name[1])) local_file_name <- local_file_record$file_name[1] } diff --git a/base/utils/R/run.write.configs.R b/base/utils/R/run.write.configs.R index b84d7f90fcd..b4cad2c2598 100644 --- a/base/utils/R/run.write.configs.R +++ b/base/utils/R/run.write.configs.R @@ -62,7 +62,7 @@ run.write.configs <- function(settings, write = TRUE, ens.sample.method = "unifo ## remove previous runs.txt if (overwrite && file.exists(file.path(settings$rundir, "runs.txt"))) { - logger.warn("Existing runs.txt file will be removed.") + PEcAn.logger::logger.warn("Existing runs.txt file will be removed.") unlink(file.path(settings$rundir, "runs.txt")) } @@ -72,7 +72,7 @@ run.write.configs <- function(settings, write = TRUE, ens.sample.method = "unifo my.write.config <- paste0("write.config.",model) if (!exists(my.write.config)) { - logger.error(my.write.config, + PEcAn.logger::logger.error(my.write.config, "does not exist, please make sure that the model package contains a function called", my.write.config) } @@ -99,7 +99,7 @@ run.write.configs <- function(settings, write = TRUE, ens.sample.method = "unifo cnt <- 0 assign("cnt", cnt, .GlobalEnv) } - logger.info("\n ----- Writing model run config files ----") + PEcAn.logger::logger.info("\n ----- Writing model run config files ----") sa.runs <- write.sa.configs(defaults = settings$pfts, quantile.samples = sa.samples, settings = settings, @@ -134,17 +134,17 @@ run.write.configs <- function(settings, write = TRUE, ens.sample.method = "unifo fname <- ensemble.filename(settings, "ensemble.samples", "Rdata", all.var.yr = TRUE) save(ens.run.ids, ens.ensemble.id, ens.samples, pft.names, trait.names, file = fname) } else { - logger.info("not writing config files for ensemble, settings are NULL") + PEcAn.logger::logger.info("not writing config files for ensemble, settings are NULL") } ### End of Ensemble - logger.info("###### Finished writing model run config files #####") - logger.info("config files samples in ", file.path(settings$outdir, "run")) + PEcAn.logger::logger.info("###### Finished writing model run config files #####") + PEcAn.logger::logger.info("config files samples in ", file.path(settings$outdir, "run")) ### Save output from SA/Ensemble runs # A lot of this is duplicate with the ensemble/sa specific output above, but kept for backwards compatibility. save(ensemble.samples, trait.samples, sa.samples, runs.samples, pft.names, trait.names, file = file.path(settings$outdir, "samples.Rdata")) - logger.info("parameter values for runs in ", file.path(settings$outdir, "samples.RData")) + PEcAn.logger::logger.info("parameter values for runs in ", file.path(settings$outdir, "samples.RData")) options(scipen = scipen) return(invisible(settings)) @@ -155,7 +155,7 @@ run.write.configs <- function(settings, write = TRUE, ens.sample.method = "unifo runModule.run.write.configs <- function(settings, overwrite = TRUE) { if (is.MultiSettings(settings)) { if (overwrite && file.exists(file.path(settings$rundir, "runs.txt"))) { - logger.warn("Existing runs.txt file will be removed.") + PEcAn.logger::logger.warn("Existing runs.txt file will be removed.") unlink(file.path(settings$rundir, "runs.txt")) } return(papply(settings, runModule.run.write.configs, overwrite = FALSE)) diff --git a/base/utils/R/sensitivity.R b/base/utils/R/sensitivity.R index d20cc4dbec6..7cb44e9ee0a 100644 --- a/base/utils/R/sensitivity.R +++ b/base/utils/R/sensitivity.R @@ -35,7 +35,7 @@ read.sa.output <- function(traits, quantiles, pecandir, outdir, pft.name = "", load(samples.file) sa.run.ids <- runs.samples$sa } else { - logger.error(samples.file, "not found, this file is required by the read.sa.output function") + PEcAn.logger::logger.error(samples.file, "not found, this file is required by the read.sa.output function") } } @@ -61,7 +61,7 @@ read.sa.output <- function(traits, quantiles, pecandir, outdir, pft.name = "", sa.output[quantile, trait] <- mean(out, na.rm=TRUE) } ## end loop over quantiles - logger.info("reading sensitivity analysis output for model run at ", quantiles, "quantiles of trait", trait) + PEcAn.logger::logger.info("reading sensitivity analysis output for model run at ", quantiles, "quantiles of trait", trait) } ## end loop over traits sa.output <- as.data.frame(sa.output) return(sa.output) diff --git a/base/utils/R/start.model.runs.R b/base/utils/R/start.model.runs.R index 2a6a9aa0db0..5ba9f5a1cbb 100644 --- a/base/utils/R/start.model.runs.R +++ b/base/utils/R/start.model.runs.R @@ -26,15 +26,15 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error=TRUE) { # check if runs need to be done if(!file.exists(file.path(settings$rundir, "runs.txt"))){ - logger.warn("runs.txt not found, assuming no runs need to be done") + PEcAn.logger::logger.warn("runs.txt not found, assuming no runs need to be done") return() } model <- settings$model$type - logger.info("-------------------------------------------------------------------") - logger.info(paste(" Starting model runs", model)) - logger.info("-------------------------------------------------------------------") + PEcAn.logger::logger.info("-------------------------------------------------------------------") + PEcAn.logger::logger.info(paste(" Starting model runs", model)) + PEcAn.logger::logger.info("-------------------------------------------------------------------") # loop through runs and either call start run, or launch job on remote machine jobids <- list() @@ -138,9 +138,9 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error=TRUE) { # check output to see if an error occurred during the model run if ("ERROR IN MODEL RUN" %in% out) { if(stop.on.error){ - logger.severe("Model run aborted, with error.\n", out) + PEcAn.logger::logger.severe("Model run aborted, with error.\n", out) } else { - logger.error("Model run aborted, with error.\n",out) + PEcAn.logger::logger.error("Model run aborted, with error.\n",out) } } @@ -214,7 +214,7 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error=TRUE) { # check output to see if an error occurred during the model run if ("ERROR IN MODEL RUN" %in% out) { - logger.severe("Model run aborted, with error.\n", out) + PEcAn.logger::logger.severe("Model run aborted, with error.\n", out) } # write finished time to database @@ -232,7 +232,7 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error=TRUE) { # wait for all qsub jobs to finish if (length(jobids) > 0) { - logger.debug("Waiting for the following jobs:", unlist(jobids, use.names = FALSE)) + PEcAn.logger::logger.debug("Waiting for the following jobs:", unlist(jobids, use.names = FALSE)) while (length(jobids) > 0) { Sys.sleep(10) for (run in names(jobids)) { @@ -252,7 +252,7 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error=TRUE) { if ((length(out) > 0) && (substring(out, nchar(out) - 3) == "DONE")) { - logger.debug("Job", jobids[run], "for run", format(run, scientific = FALSE), + PEcAn.logger::logger.debug("Job", jobids[run], "for run", format(run, scientific = FALSE), "finished") jobids[run] <- NULL diff --git a/base/utils/R/status.R b/base/utils/R/status.R index d192041ac61..12223d783cd 100644 --- a/base/utils/R/status.R +++ b/base/utils/R/status.R @@ -60,7 +60,7 @@ status.check <- function(name) { } status.data[name, ] if (is.na(status.data[name, 3])) { - logger.warn("UNKNOWN STATUS FOR", name) + PEcAn.logger::logger.warn("UNKNOWN STATUS FOR", name) return(0) } if (status.data[name, 3] == "DONE") { diff --git a/base/utils/R/utils.R b/base/utils/R/utils.R index 514e9cadd2a..c89145f3f7d 100644 --- a/base/utils/R/utils.R +++ b/base/utils/R/utils.R @@ -36,7 +36,7 @@ mstmipvar <- function(name, lat = NA, lon = NA, time = NA, nsoil = NA, silent = var <- mstmip_local[mstmip_local$Variable.Name == name, ] if (nrow(var) == 0) { if (!silent) { - logger.info("Don't know about variable", name, " in mstmip_vars in PEcAn.utils") + PEcAn.logger::logger.info("Don't know about variable", name, " in mstmip_vars in PEcAn.utils") } if (is.na(time)) { time <- ncdf4::ncdim_def(name = "time", units = "days since 1900-01-01 00:00:00", @@ -60,7 +60,7 @@ mstmipvar <- function(name, lat = NA, lon = NA, time = NA, nsoil = NA, silent = # skip } else { if (!silent) { - logger.info("Don't know dimension for", vd, "for variable", name) + PEcAn.logger::logger.info("Don't know dimension for", vd, "for variable", name) } } } @@ -117,7 +117,7 @@ zero.truncate <- function(y) { ##' @author Shawn Serbin #--------------------------------------------------------------------------------------------------# rsync <- function(args, from, to, pattern = "") { - logger.warn("NEED TO USE TUNNEL") + PEcAn.logger::logger.warn("NEED TO USE TUNNEL") system(paste0("rsync", " ", args, " ", from, pattern, " ", to), intern = TRUE) } # rsync @@ -132,7 +132,7 @@ rsync <- function(args, from, to, pattern = "") { ##' @export #--------------------------------------------------------------------------------------------------# ssh <- function(host, ..., args = "") { - logger.warn("NEED TO USE TUNNEL") + PEcAn.logger::logger.warn("NEED TO USE TUNNEL") if (host == "localhost") { command <- paste(..., args, sep = "") } else { @@ -581,7 +581,7 @@ load.modelpkg <- function(model) { if (pecan.modelpkg %in% rownames(installed.packages())) { do.call(require, args = list(pecan.modelpkg)) } else { - logger.error("I can't find a package for the ", model, + PEcAn.logger::logger.error("I can't find a package for the ", model, "model; I expect it to be named ", pecan.modelpkg) } } @@ -618,7 +618,7 @@ misc.convert <- function(x, u1, u2) { val <- udunits2::ud.convert(x,u1,u2) -# logger.severe(paste("Unknown units", u1, u2)) +# PEcAn.logger::logger.severe(paste("Unknown units", u1, u2)) } return(val) } # misc.convert @@ -702,7 +702,7 @@ download.file <- function(url, filename, method) { if (startsWith(url, "ftp://")) { method <- if (missing(method)) getOption("download.ftp.method", default = "auto") if (method == "ncftpget") { - logger.debug(paste0("FTP Method: ",method)) + PEcAn.logger::logger.debug(paste0("FTP Method: ",method)) #system2("ncftpget", c("-c", "url", ">", filename)) system(paste(method,"-c",url,">",filename,sep=" ")) } else { diff --git a/base/utils/man/logger.debug.Rd b/base/utils/man/logger.debug.Rd new file mode 100644 index 00000000000..7a0fb99009b --- /dev/null +++ b/base/utils/man/logger.debug.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/logger.R +\name{logger.debug} +\alias{logger.debug} +\title{Logger functions (imported temporarily from PEcAn.logger)} +\usage{ +logger.debug(...) +} +\description{ +Logger functions (imported temporarily from PEcAn.logger) +} diff --git a/base/utils/tests/testthat.R b/base/utils/tests/testthat.R index 1a41470be1d..7c41d64906e 100644 --- a/base/utils/tests/testthat.R +++ b/base/utils/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) test_check("PEcAn.utils") diff --git a/base/visualization/DESCRIPTION b/base/visualization/DESCRIPTION index 149afaa511a..3274dd4031f 100644 --- a/base/visualization/DESCRIPTION +++ b/base/visualization/DESCRIPTION @@ -31,6 +31,7 @@ Depends: dbplyr, plotly Imports: + PEcAn.logger, lubridate (>= 1.6.0), ncdf4 (>= 1.15), plyr (>= 1.8.4), diff --git a/base/visualization/tests/testthat.R b/base/visualization/tests/testthat.R index 1968e163f88..7effa5ce57a 100644 --- a/base/visualization/tests/testthat.R +++ b/base/visualization/tests/testthat.R @@ -10,5 +10,5 @@ library(testthat) library(PEcAn.visualization) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) #test_package("PEcAn.visualization") diff --git a/models/biocro/DESCRIPTION b/models/biocro/DESCRIPTION index 93d8aef5dc6..7d601e14e76 100644 --- a/models/biocro/DESCRIPTION +++ b/models/biocro/DESCRIPTION @@ -7,6 +7,7 @@ Author: David LeBauer, Deepak Jaiswal Maintainer: David LeBauer Description: This module provides functions to link BioCro to PEcAn. Imports: + PEcAn.logger, PEcAn.utils, PEcAn.settings, PEcAn.data.atmosphere, diff --git a/models/biocro/R/met2model.BIOCRO.R b/models/biocro/R/met2model.BIOCRO.R index c90a234d0d9..2165e0245b8 100644 --- a/models/biocro/R/met2model.BIOCRO.R +++ b/models/biocro/R/met2model.BIOCRO.R @@ -43,7 +43,7 @@ met2model.BIOCRO <- function(in.path, in.prefix, outfolder, overwrite = FALSE, csvfile <- file.path(outfolder, paste(in.prefix, year, "csv", sep = ".")) if (file.exists(csvfile) && as.logical(overwrite) != TRUE){ - logger.warn(paste("Output file", csvfile, "already exists! Moving to next year.")) + PEcAn.logger::logger.warn(paste("Output file", csvfile, "already exists! Moving to next year.")) next } @@ -150,7 +150,7 @@ cf2biocro <- function(met, longitude = NULL, zulu2solarnoon = FALSE) { "Kelvin", "Celsius"), press = udunits2::ud.convert(met$air_pressure, "Pa", "hPa")) met <- cbind(met, relative_humidity = rh * 100) } else { - logger.error("neither relative_humidity nor [air_temperature, air_pressure, and specific_humidity]", + PEcAn.logger::logger.error("neither relative_humidity nor [air_temperature, air_pressure, and specific_humidity]", "are in met data") } } @@ -161,14 +161,14 @@ cf2biocro <- function(met, longitude = NULL, zulu2solarnoon = FALSE) { par <- sw2par(met$surface_downwelling_shortwave_flux_in_air) ppfd <- par2ppfd(par) } else { - logger.error("Need either ppfd or surface_downwelling_shortwave_flux_in_air in met dataset") + PEcAn.logger::logger.error("Need either ppfd or surface_downwelling_shortwave_flux_in_air in met dataset") } } if (!"wind_speed" %in% colnames(met)) { if (all(c("northward_wind", "eastward_wind") %in% colnames(met))) { wind_speed <- sqrt(met$northward_wind^2 + met$eastward_wind^2) } else { - logger.error("neither wind_speed nor both eastward_wind and northward_wind are present in met data") + PEcAn.logger::logger.error("neither wind_speed nor both eastward_wind and northward_wind are present in met data") } } diff --git a/models/biocro/R/write.configs.BIOCRO.R b/models/biocro/R/write.configs.BIOCRO.R index f7ee3f21034..ba142212dcc 100644 --- a/models/biocro/R/write.configs.BIOCRO.R +++ b/models/biocro/R/write.configs.BIOCRO.R @@ -110,7 +110,7 @@ write.config.BIOCRO <- function(defaults = NULL, trait.values, settings, run.id) species <- utils::read.csv(file.path(settings$pfts$pft$outdir, "species.csv")) genus <- unique(species$genus) if (length(genus) > 1) { - logger.severe("BioCro can not combine multiple genera") + PEcAn.logger::logger.severe("BioCro can not combine multiple genera") } ### Set defaults @@ -122,7 +122,7 @@ write.config.BIOCRO <- function(defaults = NULL, trait.values, settings, run.id) } else if (grepl("RData", defaults.file)) { load(defaults.file) } else { - logger.severe("Defaults file", defaults.file, " not found; using package defaults") + PEcAn.logger::logger.severe("Defaults file", defaults.file, " not found; using package defaults") defaults.file <- NULL } } else if (is.null(defaults.file)) { @@ -132,11 +132,11 @@ write.config.BIOCRO <- function(defaults = NULL, trait.values, settings, run.id) if (file.exists(defaults.file)) { defaults <- XML::xmlToList(XML::xmlParse(defaults.file)) } else { - logger.severe("no defaults file given and ", genus, "not supported in BioCro") + PEcAn.logger::logger.severe("no defaults file given and ", genus, "not supported in BioCro") } if (is.null(defaults)) { - logger.error("No defaults values set") + PEcAn.logger::logger.error("No defaults values set") } traits.used <- sapply(defaults, is.null) @@ -159,7 +159,7 @@ write.config.BIOCRO <- function(defaults = NULL, trait.values, settings, run.id) sep = ":", strip.white = TRUE)))) { if (sum(unused.traits) > 0) { - logger.warn("the following traits parameters are not added to config file:", + PEcAn.logger::logger.warn("the following traits parameters are not added to config file:", vecpaste(names(unused.traits)[unused.traits == TRUE])) } } diff --git a/models/biocro/tests/testthat.R b/models/biocro/tests/testthat.R index b6fd9659c5f..45bd65b95e6 100644 --- a/models/biocro/tests/testthat.R +++ b/models/biocro/tests/testthat.R @@ -9,5 +9,5 @@ library(PEcAn.utils) library(PEcAn.settings) library(testthat) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) # test_check('PEcAn.BIOCRO') diff --git a/models/cable/DESCRIPTION b/models/cable/DESCRIPTION index 80e9512bc0c..850f0580ab8 100644 --- a/models/cable/DESCRIPTION +++ b/models/cable/DESCRIPTION @@ -7,6 +7,7 @@ Author: Kaitlin Ragosta Maintainer: Anthony Gardella Description: This module provides functions to link the (CABLE) to PEcAn. Imports: + PEcAn.logger, PEcAn.utils (>= 1.4.8) Suggests: testthat (>= 1.0.2) diff --git a/models/cable/R/met2model.CABLE.R b/models/cable/R/met2model.CABLE.R index f495e5bee9c..0433d0247ce 100644 --- a/models/cable/R/met2model.CABLE.R +++ b/models/cable/R/met2model.CABLE.R @@ -21,7 +21,7 @@ ##' @author Rob Kooper ##-------------------------------------------------------------------------------------------------# met2model.CABLE <- function(in.path, in.prefix, outfolder, overwrite = FALSE) { - logger.severe("NOT IMPLEMENTED") + PEcAn.logger::logger.severe("NOT IMPLEMENTED") # Please follow the PEcAn style guide: # https://pecan.gitbooks.io/pecan-documentation/content/developers_guide/Coding_style.html diff --git a/models/cable/R/model2netcdf.CABLE.R b/models/cable/R/model2netcdf.CABLE.R index 8d0d2d44a2b..3bf4b333ff0 100644 --- a/models/cable/R/model2netcdf.CABLE.R +++ b/models/cable/R/model2netcdf.CABLE.R @@ -22,7 +22,7 @@ ##' ##' @author Rob Kooper model2netcdf.CABLE <- function(outdir, sitelat, sitelon, start_date, end_date) { - logger.severe("NOT IMPLEMENTED") + PEcAn.logger::logger.severe("NOT IMPLEMENTED") # Please follow the PEcAn style guide: # https://pecan.gitbooks.io/pecan-documentation/content/developers_guide/Coding_style.html diff --git a/models/cable/R/read_restart.CABLE.R b/models/cable/R/read_restart.CABLE.R index 8c6939a7d16..dce1359d73d 100644 --- a/models/cable/R/read_restart.CABLE.R +++ b/models/cable/R/read_restart.CABLE.R @@ -19,6 +19,6 @@ read_restart.CABLE <- function(outdir, settings, var.names, params) { -logger.severe("NOT IMPLEMENTED") +PEcAn.logger::logger.severe("NOT IMPLEMENTED") } diff --git a/models/cable/R/write.config.CABLE.R b/models/cable/R/write.config.CABLE.R index 654702d4203..8ddb6123201 100644 --- a/models/cable/R/write.config.CABLE.R +++ b/models/cable/R/write.config.CABLE.R @@ -98,9 +98,9 @@ write.config.CABLE <- function(defaults, trait.values, settings, run.id) { } } if (filename == "") { - logger.severe("Could not find config template") + PEcAn.logger::logger.severe("Could not find config template") } - logger.info("Using", filename, "as template") + PEcAn.logger::logger.info("Using", filename, "as template") config.text <- readLines(con = filename, n = -1) } diff --git a/models/cable/R/write_restart.CABLE.R b/models/cable/R/write_restart.CABLE.R index d826cfd6ae4..61eda3defe8 100644 --- a/models/cable/R/write_restart.CABLE.R +++ b/models/cable/R/write_restart.CABLE.R @@ -16,5 +16,5 @@ write_restart.CABLE <- function(outdir, stop.time, settings, new.state) { -logger.severe("NOT IMPLEMENTED") +PEcAn.logger::logger.severe("NOT IMPLEMENTED") } diff --git a/models/cable/tests/testthat.R b/models/cable/tests/testthat.R index 905113b058b..d93798b4ffe 100644 --- a/models/cable/tests/testthat.R +++ b/models/cable/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) #test_check("PEcAn.ModelName") diff --git a/models/clm45/DESCRIPTION b/models/clm45/DESCRIPTION index 63faadbef1e..e0552f5b871 100644 --- a/models/clm45/DESCRIPTION +++ b/models/clm45/DESCRIPTION @@ -12,6 +12,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific efficacy of scientific investigation. This package provides functions to link the Community Land Model, version 4.5, to PEcAn. Depends: + PEcAn.logger, PEcAn.utils Imports: udunits2 (>= 0.11), diff --git a/models/clm45/tests/testthat.R b/models/clm45/tests/testthat.R index eca6cc3b99a..2582bc74de6 100644 --- a/models/clm45/tests/testthat.R +++ b/models/clm45/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) #test_check("PEcAn.CLM45") diff --git a/models/dalec/DESCRIPTION b/models/dalec/DESCRIPTION index 894985e076d..3c67dafcdbe 100644 --- a/models/dalec/DESCRIPTION +++ b/models/dalec/DESCRIPTION @@ -7,6 +7,7 @@ Author: Mike Dietze, Tristain Quaife Maintainer: Mike Dietze Description: This module provides functions to link DALEC to PEcAn. Imports: + PEcAn.logger, lubridate (>= 1.6.0), ncdf4 (>= 1.15), udunits2 (>= 0.11), diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index 05e37682356..d346b651db8 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -47,7 +47,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, if(!is.null(spin_nyear)){ ## if spinning up, extend processed met by resampling or cycling met - logger.info("Adding Spin-up met for DALEC") + PEcAn.logger::logger.info("Adding Spin-up met for DALEC") spin_nyear <- as.numeric(spin_nyear) spin_nsample <- as.numeric(spin_nsample) spin_resample <- as.logical(spin_resample) @@ -56,7 +56,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, # start_date <- as.POSIXlt(strftime(start_date, "%Y-%m-%d"), tz = "UTC") # start_date <- strptime(paste0(start_year,"-01-01"),"%Y-%m-%d", tz = "UTC") start_date_string <- paste0(lubridate::year(start_date),"-01-01") ## strptime can't parse negative years - logger.info("New Start Date",start_date_string) + PEcAn.logger::logger.info("New Start Date",start_date_string) } out.file <- paste0(in.prefix, start_date_string,".", @@ -76,7 +76,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, print(results) if (file.exists(out.file.full) && !overwrite) { - logger.debug("File '", out.file.full, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", out.file.full, "' already exists, skipping to next file.") return(invisible(results)) } @@ -130,21 +130,21 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, ## is CO2 present? if (!is.numeric(CO2)) { - logger.warn("CO2 not found in", old.file, "setting to default: 400 ppm") + PEcAn.logger::logger.warn("CO2 not found in", old.file, "setting to default: 400 ppm") CO2 <- rep(400, length(Tair)) } if (length(leafN) == 1) { - logger.warn("Leaf N not specified, setting to default: ", leafN) + PEcAn.logger::logger.warn("Leaf N not specified, setting to default: ", leafN) leafN <- rep(leafN, length(Tair)) } if (length(HydResist) == 1) { - logger.warn("total plant-soil hydraulic resistance (MPa.m2.s/mmol-1) not specified, setting to default: ", + PEcAn.logger::logger.warn("total plant-soil hydraulic resistance (MPa.m2.s/mmol-1) not specified, setting to default: ", HydResist) HydResist <- rep(HydResist, length(Tair)) } if (length(LeafWaterPot) == 1) { - logger.warn("maximum soil-leaf water potential difference (MPa) not specified, setting to default: ", + PEcAn.logger::logger.warn("maximum soil-leaf water potential difference (MPa) not specified, setting to default: ", LeafWaterPot) LeafWaterPot <- rep(LeafWaterPot, length(Tair)) } diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 7f037436c32..83409ebdd3f 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -99,7 +99,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } else { if (!is.null(trait.values[[group]])) { params <- convert.samples.DALEC(trait.values[[group]]) - logger.info(names(params)) + PEcAn.logger::logger.info(names(params)) for (i in seq_along(params)) { cmdFlags <- paste0(cmdFlags, " -", names(params)[i], " ", params[[i]]) } diff --git a/models/ed/DESCRIPTION b/models/ed/DESCRIPTION index 5545e8c12a3..d30d936f1ee 100644 --- a/models/ed/DESCRIPTION +++ b/models/ed/DESCRIPTION @@ -16,6 +16,7 @@ Depends: PEcAn.utils, coda Imports: + PEcAn.logger, abind (>= 1.4.5), ncdf4 (>= 1.15), stringr(>= 1.1.0), diff --git a/models/ed/NAMESPACE b/models/ed/NAMESPACE index 4a6c0c9977c..70aa2523ff9 100644 --- a/models/ed/NAMESPACE +++ b/models/ed/NAMESPACE @@ -16,7 +16,6 @@ export(write.config.jobsh.ED2) export(write.config.xml.ED2) export(write_restart.ED2) import(PEcAn.utils) -importFrom(PEcAn.utils,logger.info) importFrom(ncdf4,ncatt_get) importFrom(ncdf4,ncdim_def) importFrom(ncdf4,ncvar_add) diff --git a/models/ed/R/met2model.ED2.R b/models/ed/R/met2model.ED2.R index 34e52ba2dc9..97dbe2cb787 100644 --- a/models/ed/R/met2model.ED2.R +++ b/models/ed/R/met2model.ED2.R @@ -91,7 +91,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l if (is.na(lat)) { lat <- flat } else if (lat != flat) { - logger.warn("Latitude does not match that of file", lat, "!=", flat) + PEcAn.logger::logger.warn("Latitude does not match that of file", lat, "!=", flat) } flon <- try(ncvar_get(nc, "longitude"), silent = TRUE) @@ -101,7 +101,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l if (is.na(lon)) { lon <- flon } else if (lon != flon) { - logger.warn("Longitude does not match that of file", lon, "!=", flon) + PEcAn.logger::logger.warn("Longitude does not match that of file", lon, "!=", flon) } ## determine GMT adjustment lst <- site$LST_shift[which(site$acro == froot)] @@ -174,7 +174,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l rng <- length(doy) - length(ytmp):1 + 1 if (!all(rng >= 0)) { skip <- TRUE - logger.warn(paste(year, "is not a complete year and will not be included")) + PEcAn.logger::logger.warn(paste(year, "is not a complete year and will not be included")) break } asec[rng] <- asec[rng] - asec[rng[1]] @@ -185,7 +185,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l rng <- (length(yr) + 1):length(sec) if (!all(rng >= 0)) { skip <- TRUE - logger.warn(paste(year, "is not a complete year and will not be included")) + PEcAn.logger::logger.warn(paste(year, "is not a complete year and will not be included")) break } yr[rng] <- rep(y + 1, length(rng)) @@ -259,7 +259,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l h5createFile(mout) } if (overwrite == FALSE) { - logger.warn("The file already exists! Moving to next month!") + PEcAn.logger::logger.warn("The file already exists! Moving to next month!") next } } else { diff --git a/models/ed/R/model2netcdf.ED2.R b/models/ed/R/model2netcdf.ED2.R index 9b5aa42085d..4a3c097da90 100644 --- a/models/ed/R/model2netcdf.ED2.R +++ b/models/ed/R/model2netcdf.ED2.R @@ -18,7 +18,6 @@ ##' @param start_date Start time of the simulation ##' @param end_date End time of the simulation ##' @importFrom ncdf4 ncdim_def ncatt_get ncvar_add -##' @importFrom PEcAn.utils logger.info ##' @export ##' ##' @author Michael Dietze, Shawn Serbin, Rob Kooper, Toni Viskari, Istem Fer @@ -63,13 +62,13 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out[[col]] <- array(dat, dim = (end - start)) } else { if (start != 0) { - logger.warn("start date is not 0 this year, but data already exists in this col", + PEcAn.logger::logger.warn("start date is not 0 this year, but data already exists in this col", col, "how is this possible?") } out[[col]] <- abind::abind(out[[col]], array(dat, dim = (end - start)), along = 1) } } else { - logger.warn("expected a single value") + PEcAn.logger::logger.warn("expected a single value") } } else if (length(dims) == 1) { dat <- dat[1:(end - start)] @@ -77,7 +76,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out[[col]] <- dat } else { if (start != 0) { - logger.warn("start date is not 0 this year, but data already exists in this col", + PEcAn.logger::logger.warn("start date is not 0 this year, but data already exists in this col", col, "how is this possible?") } out[[col]] <- abind::abind(out[[col]], dat, along = 1) @@ -90,19 +89,19 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out[[col]] <- dat } else { if (start != 0) { - logger.warn("start date is not 0 this year, but data already exists in this col", + PEcAn.logger::logger.warn("start date is not 0 this year, but data already exists in this col", col, "how is this possible?") } out[[col]] <- abind::abind(out[[col]], dat, along = 1) } } else { - logger.debug("-------------------------------------------------------------") - logger.debug("col=", col) - logger.debug("length=", length(dat)) - logger.debug("start=", start) - logger.debug("end=", end) - logger.debug("dims=", dims) - logger.warn("Don't know how to handle larger arrays yet.") + PEcAn.logger::logger.debug("-------------------------------------------------------------") + PEcAn.logger::logger.debug("col=", col) + PEcAn.logger::logger.debug("length=", length(dat)) + PEcAn.logger::logger.debug("start=", start) + PEcAn.logger::logger.debug("end=", end) + PEcAn.logger::logger.debug("dims=", dims) + PEcAn.logger::logger.warn("Don't know how to handle larger arrays yet.") } ## finally make sure we use -999 for invalid values @@ -116,7 +115,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { if (var %in% names(nc$var)) { return(ncdf4::ncvar_get(nc, var)) } else { - logger.warn("Could not find", var, "in ed hdf5 output.") + PEcAn.logger::logger.warn("Could not find", var, "in ed hdf5 output.") return(-999) } } @@ -155,7 +154,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out <- list() ## prevTime <- NULL print(y) #print(paste("----- Processing year: ", yrs[y])) - logger.info(paste0("----- Processing year: ",yrs[y])) + PEcAn.logger::logger.info(paste0("----- Processing year: ",yrs[y])) ## if(haveTime) prevTime <- progressBar() row <- 1 for (i in ysel) { @@ -164,14 +163,14 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { block <- ifelse(lubridate::leap_year(yrs[y]) == TRUE, ncT$dim$phony_dim_0$len/366, # a leaper ncT$dim$phony_dim_0$len/365) # non leap - logger.info(paste0("Output interval: ",86400/block," sec")) + PEcAn.logger::logger.info(paste0("Output interval: ",86400/block," sec")) ## if (file.exists(file.path(outdir, sub("-T-", "-Y-", flist[i])))) { ncY <- ncdf4::nc_open(file.path(outdir, sub("-T-", "-Y-", flist[i]))) slzdata <- getHdf5Data(ncY, "SLZ") ncdf4::nc_close(ncY) } else { - logger.warn("Could not find SLZ in Y file, making a crude assumpution.") + PEcAn.logger::logger.warn("Could not find SLZ in Y file, making a crude assumpution.") slzdata <- array(c(-2, -1.5, -1, -0.8, -0.6, -0.4, -0.2, -0.1, -0.05)) } diff --git a/models/ed/R/veg2model.ED2.R b/models/ed/R/veg2model.ED2.R index 376dc80f2f6..3dedfefc315 100644 --- a/models/ed/R/veg2model.ED2.R +++ b/models/ed/R/veg2model.ED2.R @@ -87,9 +87,9 @@ veg2model.ED2 <- function(outfolder, veg_info, start_date, new_site, source){ # Remove rows that don't map to any patch css <- css[which(css$patch %in% pss$patch), ] if (nrow(css) == 0) { - logger.severe("No trees map to previously selected patches.") + PEcAn.logger::logger.severe("No trees map to previously selected patches.") } else { - logger.debug(paste0(nrow(css), " trees that map to selected patches.")) + PEcAn.logger::logger.debug(paste0(nrow(css), " trees that map to selected patches.")) } @@ -107,7 +107,7 @@ veg2model.ED2 <- function(outfolder, veg_info, start_date, new_site, source){ # suitable years av.years <- inv.years[inv.years <= start_year] if(length(av.years) == 0){ - logger.severe("No available years found in the data.") + PEcAn.logger::logger.severe("No available years found in the data.") } css$time <- max(av.years) # filter out other years @@ -124,7 +124,7 @@ veg2model.ED2 <- function(outfolder, veg_info, start_date, new_site, source){ for (p in seq_along(css$pft)) { css$pft.number[p] <- pftmapping$ED[pftmapping$PEcAn == as.character(css$pft[p])] if (is.null(css$pft.number[p])) { - logger.severe(paste0("Couldn't find an ED2 PFT number for ", as.character(css$pft[p]))) + PEcAn.logger::logger.severe(paste0("Couldn't find an ED2 PFT number for ", as.character(css$pft[p]))) } } diff --git a/models/ed/tests/testthat.R b/models/ed/tests/testthat.R index b034a37d5e4..5f913145300 100644 --- a/models/ed/tests/testthat.R +++ b/models/ed/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) test_check("PEcAn.ED2") diff --git a/models/ed/tests/testthat/test.model2netcdf.ED2.R b/models/ed/tests/testthat/test.model2netcdf.ED2.R index 5aaff2a7881..df093d1e0cf 100644 --- a/models/ed/tests/testthat/test.model2netcdf.ED2.R +++ b/models/ed/tests/testthat/test.model2netcdf.ED2.R @@ -63,7 +63,7 @@ test_that("variables have MsTMIP standard units",{ ms.units <- mstmip_vars[mstmip_vars$Variable.Name == var$name, "Units"] if(!(ms.units == var$units)) { ed.output.message <- paste(var$name, "units", var$units, "do not match MsTMIP Units", ms.units) - logger.warn(ed.output.message) + PEcAn.logger::logger.warn(ed.output.message) } } } diff --git a/models/fates/DESCRIPTION b/models/fates/DESCRIPTION index a40ee2e57c5..3b38d13dcec 100644 --- a/models/fates/DESCRIPTION +++ b/models/fates/DESCRIPTION @@ -14,6 +14,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific Depends: PEcAn.utils Imports: + PEcAn.logger, lubridate (>= 1.6.0), ncdf4 (>= 1.15) Suggests: diff --git a/models/fates/R/met2model.FATES.R b/models/fates/R/met2model.FATES.R index a5bc1e63ed8..b3b71dc1129 100644 --- a/models/fates/R/met2model.FATES.R +++ b/models/fates/R/met2model.FATES.R @@ -151,7 +151,7 @@ met2model.FATES <- function(in.path, in.prefix, outfolder, start_date, end_date, } ## end file exists } ### end loop over met files - logger.info("Done with met2model.FATES") + PEcAn.logger::logger.info("Done with met2model.FATES") return(data.frame(file = paste0(outfolder, "/"), host = c(fqdn()), diff --git a/models/fates/R/model2netcdf.FATES.R b/models/fates/R/model2netcdf.FATES.R index 516f87a295d..79ec21391de 100644 --- a/models/fates/R/model2netcdf.FATES.R +++ b/models/fates/R/model2netcdf.FATES.R @@ -24,11 +24,6 @@ ##' @importFrom ncdf4 ncdim_def ncvar_def ncatt_get ncvar_add model2netcdf.FATES <- function(outdir) { -# misc.convert <- PEcAn.utils::misc.convert # unit conversions - logger.info <- PEcAn.logger::logger.info - logger.severe <- PEcAn.logger::logger.severe - logger.warn <- PEcAn.logger::logger.warn - # var_update("AR","AutoResp","kgC m-2 s-1") var_update <- function(out,oldname,newname,newunits=NULL){ @@ -64,12 +59,12 @@ model2netcdf.FATES <- function(outdir) { for (year in unique(years)) { ysel <- which(years == year) ## subselect files for selected year if (length(ysel) > 1) { - logger.warn("PEcAn.FATES::model2netcdf.FATES does not currently support multiple files per year") + PEcAn.logger::logger.warn("PEcAn.FATES::model2netcdf.FATES does not currently support multiple files per year") } fname <- files[ysel[1]] oname <- file.path(dirname(fname), paste0(year, ".nc")) - logger.info(paste("model2netcdf.FATES - Converting:", fname, "to", oname)) + PEcAn.logger::logger.info(paste("model2netcdf.FATES - Converting:", fname, "to", oname)) ncin <- ncdf4::nc_open(fname, write = TRUE) ## FATES time is in multiple columns, create 'time' @@ -82,7 +77,7 @@ model2netcdf.FATES <- function(outdir) { # !! Is this a useful/reasonable check? That is that our calculated time # matches FATES internal time var. if (length(time)!=length(nc.time)) { - logger.severe("Time dimension mismatch in output, simulation error?") + PEcAn.logger::logger.severe("Time dimension mismatch in output, simulation error?") } #******************** Declare netCDF dimensions ********************# diff --git a/models/fates/tests/testthat.R b/models/fates/tests/testthat.R index e1ed15d2dff..5dec6bcf474 100644 --- a/models/fates/tests/testthat.R +++ b/models/fates/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) #test_check("PEcAn.FATES") diff --git a/models/gday/DESCRIPTION b/models/gday/DESCRIPTION index 360c71fb792..e5350dbf964 100644 --- a/models/gday/DESCRIPTION +++ b/models/gday/DESCRIPTION @@ -9,6 +9,7 @@ Description: This module provides functions to link the GDAY model to PEcAn. Depends: PEcAn.utils Imports: + PEcAn.logger, lubridate (>= 1.6.0), ncdf4 (>= 1.15) Suggests: diff --git a/models/gday/NAMESPACE b/models/gday/NAMESPACE index 4645ed9c183..2af9ca6e598 100644 --- a/models/gday/NAMESPACE +++ b/models/gday/NAMESPACE @@ -3,8 +3,6 @@ export(met2model.GDAY) export(model2netcdf.GDAY) export(write.config.GDAY) -importFrom(PEcAn.utils,fqdn) -importFrom(PEcAn.utils,logger.debug) importFrom(ncdf4,nc_close) importFrom(ncdf4,nc_create) importFrom(ncdf4,ncdim_def) diff --git a/models/gday/R/met2model.GDAY.R b/models/gday/R/met2model.GDAY.R index 18a04a49437..8da2af03dfd 100644 --- a/models/gday/R/met2model.GDAY.R +++ b/models/gday/R/met2model.GDAY.R @@ -28,7 +28,6 @@ ##' @param verbose should the function be very verbose ##' ##' @author Martin De Kauwe, Tony Gardella -##' @importFrom PEcAn.utils logger.debug fqdn met2model.GDAY <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { @@ -54,7 +53,7 @@ met2model.GDAY <- function(in.path, in.prefix, outfolder, start_date, end_date, out.file.full <- file.path(outfolder, out.file) results <- data.frame(file = c(out.file.full), - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = c("text/csv"), formatname = c("GDAY-met"), startdate = c(start_date), @@ -63,7 +62,7 @@ met2model.GDAY <- function(in.path, in.prefix, outfolder, start_date, end_date, stringsAsFactors = FALSE) if (file.exists(out.file.full) && !overwrite) { - logger.debug("File '", out.file.full, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", out.file.full, "' already exists, skipping to next file.") return(invisible(results)) } diff --git a/models/gday/tests/testthat.R b/models/gday/tests/testthat.R index 2d40350addd..93d4460ba89 100644 --- a/models/gday/tests/testthat.R +++ b/models/gday/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) #test_check("PEcAn.GDAY") diff --git a/models/jules/DESCRIPTION b/models/jules/DESCRIPTION index 1839a275475..d1d9f79e8f9 100644 --- a/models/jules/DESCRIPTION +++ b/models/jules/DESCRIPTION @@ -9,6 +9,7 @@ Description: This module provides functions to link the (JULES) to PEcAn. Depends: PEcAn.utils Imports: + PEcAn.logger, lubridate (>= 1.6.0), ncdf4 (>= 1.15) Suggests: diff --git a/models/jules/R/write.config.JULES.R b/models/jules/R/write.config.JULES.R index bf7b915042b..7d2a42e0ca3 100644 --- a/models/jules/R/write.config.JULES.R +++ b/models/jules/R/write.config.JULES.R @@ -355,7 +355,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { pft.file <- file.path(local.rundir, "pft_params.nml") pft.text <- readLines(con = pft.file, n = -1) if (length(pft.text) < 3) { - logger.severe("No DEFAULT parameters provided for JULES") + PEcAn.logger::logger.severe("No DEFAULT parameters provided for JULES") } ## split NML into variable list and parameter values @@ -392,7 +392,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { } else if (is.na(pft.id[i])) { pft.id[i] <- 5 } else { - logger.severe("Unknown PFT") + PEcAn.logger::logger.severe("Unknown PFT") } } @@ -532,7 +532,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { ## detect any unmatched variables mch <- which(rownames(defaults) == names(pft[v])) if (length(mch) != 1) { - logger.warn("unmatched parameter in write.configs.JULES", names(pft[v]), "in PFT", + PEcAn.logger::logger.warn("unmatched parameter in write.configs.JULES", names(pft[v]), "in PFT", names(trait.values)[i]) } else { ## insert into defaults table diff --git a/models/jules/tests/testthat.R b/models/jules/tests/testthat.R index ba523cdf1d7..060471e6cbb 100644 --- a/models/jules/tests/testthat.R +++ b/models/jules/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) #test_check("PEcAn.JULES") diff --git a/models/linkages/DESCRIPTION b/models/linkages/DESCRIPTION index b872d658daf..e7c85ec5eba 100644 --- a/models/linkages/DESCRIPTION +++ b/models/linkages/DESCRIPTION @@ -9,6 +9,7 @@ Description: This module provides functions to link the (LINKAGES) to PEcAn. Depends: PEcAn.utils Imports: + PEcAn.logger, lubridate (>= 1.6.0), ncdf4 (>= 1.15), udunits2 (>= 0.11) diff --git a/models/linkages/R/met2model.LINKAGES.R b/models/linkages/R/met2model.LINKAGES.R index 689c6790494..e421459ea89 100644 --- a/models/linkages/R/met2model.LINKAGES.R +++ b/models/linkages/R/met2model.LINKAGES.R @@ -42,7 +42,7 @@ met2model.LINKAGES <- function(in.path, in.prefix, outfolder, start_date, end_da print(results) if (file.exists(out.file) && !overwrite) { - logger.debug("File '", out.file, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", out.file, "' already exists, skipping to next file.") return(invisible(results)) } diff --git a/models/linkages/tests/testthat.R b/models/linkages/tests/testthat.R index c8c623452d7..15a638d15e9 100644 --- a/models/linkages/tests/testthat.R +++ b/models/linkages/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) test_check("PEcAn.LINKAGES") diff --git a/models/lpjguess/DESCRIPTION b/models/lpjguess/DESCRIPTION index eecbb201635..1e4bbb84a2e 100644 --- a/models/lpjguess/DESCRIPTION +++ b/models/lpjguess/DESCRIPTION @@ -9,6 +9,7 @@ Description: This module provides functions to link LPJ-GUESS to PEcAn. Depends: PEcAn.utils Imports: + PEcAn.logger, lubridate (>= 1.6.0), ncdf4 (>= 1.15) Suggests: diff --git a/models/lpjguess/R/model2netcdf.LPJGUESS.R b/models/lpjguess/R/model2netcdf.LPJGUESS.R index 04615049371..c77d60c4dd9 100644 --- a/models/lpjguess/R/model2netcdf.LPJGUESS.R +++ b/models/lpjguess/R/model2netcdf.LPJGUESS.R @@ -26,7 +26,7 @@ model2netcdf.LPJGUESS <- function(outdir, sitelat, sitelon, start_date, end_date lpjguess.out.files <- list.files(outdir, pattern = "\\.out$") if (length(lpjguess.out.files) == 0) { - logger.error("No output files found at ", outdir) + PEcAn.logger::logger.error("No output files found at ", outdir) } lpjguess.output <- lapply(file.path(outdir, lpjguess.out.files), read.table, header = TRUE, sep = "") diff --git a/models/lpjguess/R/write.config.LPJGUESS.R b/models/lpjguess/R/write.config.LPJGUESS.R index 7ecca5dc0f9..5d6338b314b 100644 --- a/models/lpjguess/R/write.config.LPJGUESS.R +++ b/models/lpjguess/R/write.config.LPJGUESS.R @@ -155,7 +155,7 @@ write.insfile.LPJGUESS <- function(settings, trait.values, rundir, outdir, run.i CO2 <- co2.1850.2011[1:which(co2.1850.2011[, 1] == end.year), ] } } else { - logger.severe("End year should be < 2012 for CO2") + PEcAn.logger::logger.severe("End year should be < 2012 for CO2") } write.table(CO2, file = co2.file, row.names = FALSE, col.names = FALSE, sep = "\t", eol = "\n") guessins <- gsub("@CO2_FILE@", co2.file, guessins) diff --git a/models/lpjguess/tests/testthat.R b/models/lpjguess/tests/testthat.R index ccd461ee2fd..59cf12a4475 100644 --- a/models/lpjguess/tests/testthat.R +++ b/models/lpjguess/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) #test_check("PEcAn.LPJGUESS") diff --git a/models/maat/DESCRIPTION b/models/maat/DESCRIPTION index cb0ad16737a..bbd8da076bb 100644 --- a/models/maat/DESCRIPTION +++ b/models/maat/DESCRIPTION @@ -7,6 +7,7 @@ Author: Shawn Serbin, Anthony Walker Maintainer: Shawn Serbin Description: This module provides functions to link the MAAT to PEcAn. Imports: + PEcAn.logger, PEcAn.utils, lubridate (>= 1.6.0), ncdf4 (>= 1.15), diff --git a/models/maat/NAMESPACE b/models/maat/NAMESPACE index 45ea0a99adf..595fd6dc473 100644 --- a/models/maat/NAMESPACE +++ b/models/maat/NAMESPACE @@ -4,10 +4,6 @@ export(convert.samples.MAAT) export(met2model.MAAT) export(model2netcdf.MAAT) export(write.config.MAAT) -importFrom(PEcAn.utils,listToXml) -importFrom(PEcAn.utils,logger.debug) -importFrom(PEcAn.utils,logger.info) -importFrom(PEcAn.utils,logger.warn) importFrom(PEcAn.utils,misc.convert) importFrom(PEcAn.utils,mstmipvar) importFrom(XML,addChildren) diff --git a/models/maat/R/met2model.MAAT.R b/models/maat/R/met2model.MAAT.R index 4a39fd30ab3..d3b959917b8 100644 --- a/models/maat/R/met2model.MAAT.R +++ b/models/maat/R/met2model.MAAT.R @@ -30,7 +30,6 @@ PREFIX_XML <- "\n" ##' @param verbose should the function be very verbose ##' @export ##' @author Shawn P. Serbin -##' @importFrom PEcAn.utils logger.debug logger.warn listToXml ##' @importFrom udunits2 ud.convert ##' @importFrom ncdf4 ncvar_get ##' @importFrom XML saveXML @@ -64,7 +63,7 @@ met2model.MAAT <- function(in.path, in.prefix, outfolder, start_date, end_date, print(results) if (file.exists(out.file.full) && !overwrite) { - logger.debug("File '", out.file.full, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", out.file.full, "' already exists, skipping to next file.") return(invisible(results)) } @@ -159,7 +158,7 @@ met2model.MAAT <- function(in.path, in.prefix, outfolder, start_date, end_date, rng <- length(doy) - length(ytmp):1 + 1 if (!all(rng >= 0)) { skip <- TRUE - logger.warn(paste(year, "is not a complete year and will not be included")) + PEcAn.logger::logger.warn(paste(year, "is not a complete year and will not be included")) break } asec[rng] <- asec[rng] - asec[rng[1]] diff --git a/models/maat/R/write.config.MAAT.R b/models/maat/R/write.config.MAAT.R index a25d9cb673c..f56b6a5f309 100644 --- a/models/maat/R/write.config.MAAT.R +++ b/models/maat/R/write.config.MAAT.R @@ -85,7 +85,6 @@ convert.samples.MAAT <- function(trait.samples) { ##' @return configuration file for MAAT for given run ##' @export ##' @author Shawn Serbin, Anthony Walker, Rob Kooper -##' @importFrom PEcAn.utils listToXml logger.info ##' @importFrom XML saveXML addChildren write.config.MAAT <- function(defaults = NULL, trait.values, settings, run.id) { @@ -100,14 +99,14 @@ write.config.MAAT <- function(defaults = NULL, trait.values, settings, run.id) { file.path(settings$model$binary, "src"))) ### Parse config options to XML - xml <- listToXml(settings$model$config, "default") + xml <- PEcAn.utils::listToXml(settings$model$config, "default") ### Run rename and conversion function on PEcAn trait values traits <- convert.samples.MAAT(trait.samples = trait.values[[settings$pfts$pft$name]]) ### Convert traits to list traits.list <- as.list(traits) - traits.xml <- listToXml(traits.list, "pars") + traits.xml <- PEcAn.utils::listToXml(traits.list, "pars") ### Finalize XML xml[[1]] <- addChildren(xml[[1]], traits.xml) @@ -122,7 +121,7 @@ write.config.MAAT <- function(defaults = NULL, trait.values, settings, run.id) { ### Write out new XML _ NEED TO FIX THIS BIT. NEED TO CONVERT WHOLE LIST TO XML #saveXML(xml, file = file.path(settings$rundir, run.id, "leaf_default.xml"), indent=TRUE, prefix = PREFIX_XML) if (is.null(settings$run$inputs$met)) { - logger.info("-- No met selected. Running without a met driver --") + PEcAn.logger::logger.info("-- No met selected. Running without a met driver --") jobsh <- paste0("#!/bin/bash\n","Rscript ",rundir,"/run_MAAT.R"," ", "\"odir <- ","'",outdir,"'","\""," > ",rundir, "/logfile.txt","\n",'echo "', @@ -163,4 +162,4 @@ write.config.MAAT <- function(defaults = NULL, trait.values, settings, run.id) { } # write.config.MAAT ##-------------------------------------------------------------------------------------------------# -## EOF \ No newline at end of file +## EOF diff --git a/models/maat/inst/simple_workflow.R b/models/maat/inst/simple_workflow.R index 710c3510e25..2ec86558a16 100644 --- a/models/maat/inst/simple_workflow.R +++ b/models/maat/inst/simple_workflow.R @@ -39,14 +39,14 @@ run.meta.analysis(settings$pfts, settings$meta.analysis$iter, settings$meta.anal if (!file.exists(file.path(settings$rundir, "runs.txt")) | settings$meta.analysis$update == "TRUE") { run.write.configs(settings, settings$database$bety$write) } else { - logger.info("Already wrote configuraiton files") + PEcAn.logger::logger.info("Already wrote configuraiton files") } #--------------------------------------------------------------------------------------------------# #--------------------------------------------------------------------------------------------------# # run model if (!file.exists(file.path(settings$rundir, "runs.txt"))) { - logger.severe("No ensemble or sensitivity analysis specified in pecan.xml, work is done.") + PEcAn.logger::logger.severe("No ensemble or sensitivity analysis specified in pecan.xml, work is done.") } else { start.model.runs(settings, settings$database$bety$write) } @@ -62,14 +62,14 @@ get.results(settings) #if (!file.exists(file.path(settings$outdir,"ensemble.ts.pdf"))) { # run.ensemble.analysis(TRUE) #} else { -# logger.info("Already executed run.ensemble.analysis()") +# PEcAn.logger::logger.info("Already executed run.ensemble.analysis()") #} # sensitivity analysis if (!file.exists(file.path(settings$outdir, "sensitivity.results.Rdata"))) { run.sensitivity.analysis() } else { - logger.info("Already executed run.sensitivity.analysis()") + PEcAn.logger::logger.info("Already executed run.sensitivity.analysis()") } db.print.connections() diff --git a/models/maat/tests/testthat.R b/models/maat/tests/testthat.R index 4c203150134..2da241e0ec7 100644 --- a/models/maat/tests/testthat.R +++ b/models/maat/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) test_check("PEcAn.MAAT") diff --git a/models/maespa/DESCRIPTION b/models/maespa/DESCRIPTION index fabb89ec1a5..ed262f4571d 100644 --- a/models/maespa/DESCRIPTION +++ b/models/maespa/DESCRIPTION @@ -14,6 +14,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific Depends: ncdf4 Imports: + PEcAn.logger, PEcAn.utils, lubridate (>= 1.6.0), ncdf4 (>= 1.15), diff --git a/models/maespa/R/met2model.MAESPA.R b/models/maespa/R/met2model.MAESPA.R index f2e98df4cbf..0b05aae4881 100755 --- a/models/maespa/R/met2model.MAESPA.R +++ b/models/maespa/R/met2model.MAESPA.R @@ -57,7 +57,7 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date print(results) if (file.exists(out.file.full) && !overwrite) { - logger.debug("File '", out.file.full, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", out.file.full, "' already exists, skipping to next file.") return(invisible(results)) } @@ -154,9 +154,9 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date ### Check for NA if (anyNA(out)) { - logger.debug("NA introduced in met data. Maespa will not be able to run properly. Please change Met Data Source or Site") + PEcAn.logger::logger.debug("NA introduced in met data. Maespa will not be able to run properly. Please change Met Data Source or Site") } else { - logger.debug("No NA values contained in data") + PEcAn.logger::logger.debug("No NA values contained in data") } ## Set Variable names diff --git a/models/maespa/tests/testthat.R b/models/maespa/tests/testthat.R index 5a2e1a7d055..f9eec820a52 100755 --- a/models/maespa/tests/testthat.R +++ b/models/maespa/tests/testthat.R @@ -6,5 +6,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) # test_check('PEcAn.MAESPA') diff --git a/models/preles/DESCRIPTION b/models/preles/DESCRIPTION index 2e4c5b234da..2766991a588 100644 --- a/models/preles/DESCRIPTION +++ b/models/preles/DESCRIPTION @@ -15,6 +15,7 @@ Description: This module provides functions to run the PREdict Light use Depends: PEcAn.utils Imports: + PEcAn.logger, lubridate (>= 1.6.0), ncdf4 (>= 1.15), udunits2 (>= 0.11) diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index 0965645c2bd..c009c7357aa 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -73,7 +73,7 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star ## Check for CO2 and PAR if (!is.numeric(CO2)) { - logger.warn("CO2 not found. Setting to default: 4.0e+8 mol/mol") # using rough estimate of atmospheric CO2 levels + PEcAn.logger::logger.warn("CO2 not found. Setting to default: 4.0e+8 mol/mol") # using rough estimate of atmospheric CO2 levels CO2 <- rep(4e+08, length(Precip)) } diff --git a/models/preles/tests/testthat.R b/models/preles/tests/testthat.R index 05385d860c6..73f5a5f9fb8 100644 --- a/models/preles/tests/testthat.R +++ b/models/preles/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) test_check("PEcAn.PRELES") diff --git a/models/sipnet/DESCRIPTION b/models/sipnet/DESCRIPTION index a0904b43155..c43ad81d1c8 100644 --- a/models/sipnet/DESCRIPTION +++ b/models/sipnet/DESCRIPTION @@ -13,6 +13,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific Depends: PEcAn.data.atmosphere Imports: + PEcAn.logger, PEcAn.utils, lubridate (>= 1.6.0), ncdf4 (>= 1.15), diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index b9caaff2c9d..01e67940b6d 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -50,7 +50,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date print(results) if (file.exists(out.file.full) && !overwrite) { - logger.debug("File '", out.file.full, "' already exists, skipping to next file.") + PEcAn.logger::logger.debug("File '", out.file.full, "' already exists, skipping to next file.") return(invisible(results)) } @@ -165,7 +165,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date rng <- length(doy) - length(ytmp):1 + 1 if (!all(rng >= 0)) { skip <- TRUE - logger.warn(paste(year, "is not a complete year and will not be included")) + PEcAn.logger::logger.warn(paste(year, "is not a complete year and will not be included")) break } asec[rng] <- asec[rng] - asec[rng[1]] @@ -175,7 +175,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date rng <- (length(yr) + 1):length(sec) if (!all(rng >= 0)) { skip <- TRUE - logger.warn(paste(year, "is not a complete year and will not be included")) + PEcAn.logger::logger.warn(paste(year, "is not a complete year and will not be included")) break } yr[rng] <- rep(y + 1, length(rng)) diff --git a/models/sipnet/tests/testthat.R b/models/sipnet/tests/testthat.R index 446f7166674..339f0c32a30 100644 --- a/models/sipnet/tests/testthat.R +++ b/models/sipnet/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) #test_check("PEcAn.SIPNET") diff --git a/models/template/DESCRIPTION b/models/template/DESCRIPTION index bf5d4543781..d993bba9364 100644 --- a/models/template/DESCRIPTION +++ b/models/template/DESCRIPTION @@ -7,6 +7,7 @@ Author: John Doe, Jane Doe Maintainer: John Doe Description: This module provides functions to link the (ModelName) to PEcAn. Imports: + PEcAn.logger, PEcAn.utils (>= 1.4.8) Suggests: testthat (>= 1.0.2) diff --git a/models/template/R/met2model.MODEL.R b/models/template/R/met2model.MODEL.R index 88f27140fcf..f1addf0fae3 100644 --- a/models/template/R/met2model.MODEL.R +++ b/models/template/R/met2model.MODEL.R @@ -21,7 +21,7 @@ ##' @author Rob Kooper ##-------------------------------------------------------------------------------------------------# met2model.MODEL <- function(in.path, in.prefix, outfolder, overwrite = FALSE) { - logger.severe("NOT IMPLEMENTED") + PEcAn.logger::logger.severe("NOT IMPLEMENTED") # Please follow the PEcAn style guide: # https://pecan.gitbooks.io/pecan-documentation/content/developers_guide/Coding_style.html diff --git a/models/template/R/model2netcdf.MODEL.R b/models/template/R/model2netcdf.MODEL.R index 7fa5137184b..dd99580ea70 100644 --- a/models/template/R/model2netcdf.MODEL.R +++ b/models/template/R/model2netcdf.MODEL.R @@ -22,7 +22,7 @@ ##' ##' @author Rob Kooper model2netcdf.MODEL <- function(outdir, sitelat, sitelon, start_date, end_date) { - logger.severe("NOT IMPLEMENTED") + PEcAn.logger::logger.severe("NOT IMPLEMENTED") # Please follow the PEcAn style guide: # https://pecan.gitbooks.io/pecan-documentation/content/developers_guide/Coding_style.html diff --git a/models/template/R/write.config.MODEL.R b/models/template/R/write.config.MODEL.R index e1321ae6c93..2b5ab0fa687 100644 --- a/models/template/R/write.config.MODEL.R +++ b/models/template/R/write.config.MODEL.R @@ -98,9 +98,9 @@ write.config.MODEL <- function(defaults, trait.values, settings, run.id) { } } if (filename == "") { - logger.severe("Could not find config template") + PEcAn.logger::logger.severe("Could not find config template") } - logger.info("Using", filename, "as template") + PEcAn.logger::logger.info("Using", filename, "as template") config.text <- readLines(con = filename, n = -1) } diff --git a/models/template/tests/testthat.R b/models/template/tests/testthat.R index 905113b058b..d93798b4ffe 100644 --- a/models/template/tests/testthat.R +++ b/models/template/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) #test_check("PEcAn.ModelName") diff --git a/modules/allometry/DESCRIPTION b/modules/allometry/DESCRIPTION index d771ada1876..3d64baa4ea1 100644 --- a/modules/allometry/DESCRIPTION +++ b/modules/allometry/DESCRIPTION @@ -11,6 +11,7 @@ Depends: mvtnorm, tools Imports: + PEcAn.logger, coda (>= 0.18), XML (>= 3.98-1.4) Suggests: diff --git a/modules/allometry/tests/testthat.R b/modules/allometry/tests/testthat.R index 4d8c9af8d92..a775e051786 100644 --- a/modules/allometry/tests/testthat.R +++ b/modules/allometry/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) # test_check("PEcAn.allometry") diff --git a/modules/assim.batch/DESCRIPTION b/modules/assim.batch/DESCRIPTION index d208ac17da5..2b22dd9e9a4 100644 --- a/modules/assim.batch/DESCRIPTION +++ b/modules/assim.batch/DESCRIPTION @@ -23,6 +23,7 @@ Depends: BayesianTools, PEcAn.MA Imports: + PEcAn.logger, coda (>= 0.18), lubridate (>= 1.6.0), ncdf4 (>= 1.15), diff --git a/modules/assim.batch/R/pda.bayesian.tools.R b/modules/assim.batch/R/pda.bayesian.tools.R index 77a611a20c4..26ad52ecbf1 100644 --- a/modules/assim.batch/R/pda.bayesian.tools.R +++ b/modules/assim.batch/R/pda.bayesian.tools.R @@ -71,7 +71,7 @@ pda.bayesian.tools <- function(settings, params.id = NULL, param.names = NULL, p do.call("require", list(paste0("PEcAn.", settings$model$type))) my.write.config <- paste("write.config.", settings$model$type, sep = "") if (!exists(my.write.config)) { - logger.severe(paste(my.write.config, "does not exist. Please make sure that the PEcAn interface is loaded for", + PEcAn.logger::logger.severe(paste(my.write.config, "does not exist. Please make sure that the PEcAn interface is loaded for", settings$model$type)) } @@ -83,7 +83,7 @@ pda.bayesian.tools <- function(settings, params.id = NULL, param.names = NULL, p ## NOTE: The listed samplers here require more than 1 parameter for now because of the way their ## cov is calculated if (sampler %in% c("M", "AM", "DR", "DRAM", "DREAM", "DREAMzs", "SMC") & sum(n.param) < 2) { - logger.error(paste0(sampler, " sampler can be used with >=2 paramaters")) + PEcAn.logger::logger.error(paste0(sampler, " sampler can be used with >=2 paramaters")) } ## Get the workflow id @@ -177,7 +177,7 @@ pda.bayesian.tools <- function(settings, params.id = NULL, param.names = NULL, p ## Create bayesianSetup object for BayesianTools bayesianSetup <- createBayesianSetup(bt.likelihood, bt.prior, best = parm[prior.ind.all], parallel = FALSE) - logger.info(paste0("Extracting upper and lower boundaries from priors.")) # M/AM/DR/DRAM can't work with -Inf, Inf values + PEcAn.logger::logger.info(paste0("Extracting upper and lower boundaries from priors.")) # M/AM/DR/DRAM can't work with -Inf, Inf values rng <- matrix(c(sapply(prior.fn.all$qprior[prior.ind.all], eval, list(p = 1e-05)), sapply(prior.fn.all$qprior[prior.ind.all], eval, list(p = 0.99999))), nrow = sum(n.param)) diff --git a/modules/assim.batch/R/pda.bayestools.helpers.R b/modules/assim.batch/R/pda.bayestools.helpers.R index 50f754fd80c..ac4af800442 100644 --- a/modules/assim.batch/R/pda.bayestools.helpers.R +++ b/modules/assim.batch/R/pda.bayestools.helpers.R @@ -132,7 +132,7 @@ pda.settings.bt <- function(settings) { } else if (sampler == "SMC") { bt.settings <- list(initialParticles = list("prior", iterations)) } else { - logger.error(paste0(sampler, " sampler not found!")) + PEcAn.logger::logger.error(paste0(sampler, " sampler not found!")) } return(bt.settings) diff --git a/modules/assim.batch/R/pda.emulator.R b/modules/assim.batch/R/pda.emulator.R index db639dfc7dd..2b91c15b49b 100644 --- a/modules/assim.batch/R/pda.emulator.R +++ b/modules/assim.batch/R/pda.emulator.R @@ -107,7 +107,7 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, do.call("library", list(paste0("PEcAn.", settings$model$type))) my.write.config <- paste("write.config.", settings$model$type, sep = "") if (!exists(my.write.config)) { - logger.severe(paste(my.write.config, + PEcAn.logger::logger.severe(paste(my.write.config, "does not exist. Please make sure that the PEcAn interface is loaded for", settings$model$type)) } @@ -369,10 +369,10 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, if(no.of.failed < no.of.allowed & (settings$assim.batch$n.knot - no.of.failed) > 1){ SS.list[[inputi]] <- SS.list[[inputi]][!rowSums(is.na(SS.list[[inputi]])), ] if( no.of.failed > 0){ - logger.info(paste0(no.of.failed, " runs failed. Emulator for ", names(n.of.obs)[inputi], " will be built with ", settings$assim.batch$n.knot - no.of.failed, " knots.")) + PEcAn.logger::logger.info(paste0(no.of.failed, " runs failed. Emulator for ", names(n.of.obs)[inputi], " will be built with ", settings$assim.batch$n.knot - no.of.failed, " knots.")) } } else{ - logger.error(paste0("Too many runs failed, not enough parameter set to build emulator for ", names(n.of.obs)[inputi], ".")) + PEcAn.logger::logger.error(paste0("Too many runs failed, not enough parameter set to build emulator for ", names(n.of.obs)[inputi], ".")) } } # for-loop @@ -389,7 +389,7 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, SS <- SS.list } - logger.info(paste0("Using 'mlegp' package for Gaussian Process Model fitting.")) + PEcAn.logger::logger.info(paste0("Using 'mlegp' package for Gaussian Process Model fitting.")) ## Generate emulator on SS, return a list ## @@ -410,7 +410,7 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, # Stop the clock ptm.finish <- proc.time() - ptm.start - logger.info(paste0("GP fitting took ", paste0(round(ptm.finish[3])), " seconds.")) + PEcAn.logger::logger.info(paste0("GP fitting took ", paste0(round(ptm.finish[3])), " seconds.")) gp <- GPmodel @@ -487,7 +487,7 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, mix <- "each" } - logger.info(paste0("Starting emulator MCMC. Please wait.")) + PEcAn.logger::logger.info(paste0("Starting emulator MCMC. Please wait.")) current.step <- "pre-MCMC" save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) @@ -499,7 +499,7 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, dcores <- parallel::detectCores() - 1 ncores <- min(max(dcores, 1), settings$assim.batch$chain) - logger.setOutputFile(file.path(settings$outdir, "pda.log")) + PEcAn.logger::logger.setOutputFile(file.path(settings$outdir, "pda.log")) cl <- parallel::makeCluster(ncores, type="FORK", outfile = file.path(settings$outdir, "pda.log")) @@ -526,7 +526,7 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, # Stop the clock ptm.finish <- proc.time() - ptm.start - logger.info(paste0("Emulator MCMC took ", paste0(round(ptm.finish[3])), " seconds for ", paste0(settings$assim.batch$iter), " iterations.")) + PEcAn.logger::logger.info(paste0("Emulator MCMC took ", paste0(round(ptm.finish[3])), " seconds for ", paste0(settings$assim.batch$iter), " iterations.")) current.step <- "post-MCMC" save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) diff --git a/modules/assim.batch/R/pda.load.data.R b/modules/assim.batch/R/pda.load.data.R index 012693ffd9b..de89a450e5e 100644 --- a/modules/assim.batch/R/pda.load.data.R +++ b/modules/assim.batch/R/pda.load.data.R @@ -36,7 +36,7 @@ load.pda.data <- function(settings, bety) { # because 'data.path <- query.file.path(obvs.id, con)' might return an incomplete path # which results in reading all the files in that particular directory in the load_x_netcdf step if (is.null(inputs[[i]]$input.id) | is.null(data.path)) { - logger.error("Must provide both ID and PATH for all data assimilation inputs.") + PEcAn.logger::logger.error("Must provide both ID and PATH for all data assimilation inputs.") } format <- query.format.vars(bety = bety, input.id = inputs[[i]]$input.id) diff --git a/modules/assim.batch/R/pda.mcmc.R b/modules/assim.batch/R/pda.mcmc.R index b030ebe74c2..58999036e47 100644 --- a/modules/assim.batch/R/pda.mcmc.R +++ b/modules/assim.batch/R/pda.mcmc.R @@ -64,7 +64,7 @@ pda.mcmc <- function(settings, params.id = NULL, param.names = NULL, prior.id = do.call("require", list(paste0("PEcAn.", settings$model$type))) my.write.config <- paste0("write.config.", settings$model$type) if (!exists(my.write.config)) { - logger.severe(paste(my.write.config, + PEcAn.logger::logger.severe(paste(my.write.config, "does not exist. Please make sure that the PEcAn interface is loaded for", settings$model$type)) } @@ -158,7 +158,7 @@ pda.mcmc <- function(settings, params.id = NULL, param.names = NULL, prior.id = ## --------------------------------- Main MCMC loop --------------------------------- ## for (i in start:finish) { - logger.info(paste("Data assimilation MCMC iteration", i, "of", finish)) + PEcAn.logger::logger.info(paste("Data assimilation MCMC iteration", i, "of", finish)) ## Adjust Jump distribution if (i%%settings$assim.batch$jump$adapt < 1) { diff --git a/modules/assim.batch/R/pda.mcmc.bs.R b/modules/assim.batch/R/pda.mcmc.bs.R index a5735fb511b..3ea2c59e2cc 100644 --- a/modules/assim.batch/R/pda.mcmc.bs.R +++ b/modules/assim.batch/R/pda.mcmc.bs.R @@ -71,7 +71,7 @@ pda.mcmc.bs <- function(settings, params.id = NULL, param.names = NULL, prior.id do.call("require", list(paste0("PEcAn.", settings$model$type))) my.write.config <- paste("write.config.", settings$model$type, sep = "") if (!exists(my.write.config)) { - logger.severe(paste(my.write.config, + PEcAn.logger::logger.severe(paste(my.write.config, "does not exist. Please make sure that the PEcAn interface is loaded for", settings$model$type)) } @@ -158,7 +158,7 @@ pda.mcmc.bs <- function(settings, params.id = NULL, param.names = NULL, prior.id ## --------------------------------- Main MCMC loop --------------------------------- ## for (i in start:finish) { - logger.info(paste("Data assimilation MCMC iteration", i, "of", finish)) + PEcAn.logger::logger.info(paste("Data assimilation MCMC iteration", i, "of", finish)) ## Adjust Jump distribution if ((i > (start + 1)) && ((i - start)%%settings$assim.batch$jump$adapt == 0)) { diff --git a/modules/assim.batch/R/pda.neff.R b/modules/assim.batch/R/pda.neff.R index 503b522386a..1de5aa0c41c 100644 --- a/modules/assim.batch/R/pda.neff.R +++ b/modules/assim.batch/R/pda.neff.R @@ -153,7 +153,7 @@ pda.autocorr.calc <- function(input, model = "heteroskedastic.laplacian"){ n.chains = 3) }else{ - logger.error(model, "is not data available as data model.") + PEcAn.logger::logger.error(model, "is not data available as data model.") } jags.out <- coda.samples (model = j.model, diff --git a/modules/assim.batch/R/pda.postprocess.R b/modules/assim.batch/R/pda.postprocess.R index fb0a3dd7305..57eec881377 100644 --- a/modules/assim.batch/R/pda.postprocess.R +++ b/modules/assim.batch/R/pda.postprocess.R @@ -56,7 +56,7 @@ pda.postprocess <- function(settings, con, mcmc.param.list, pname, prior, prior. pft.id, ") RETURNING id"), con) - logger.info(paste0("--- Posteriorid for ", settings$pfts[[i]]$name, " is ", posteriorid, " ---")) + PEcAn.logger::logger.info(paste0("--- Posteriorid for ", settings$pfts[[i]]$name, " is ", posteriorid, " ---")) settings$pfts[[i]]$posteriorid <- posteriorid ## save named distributions @@ -134,14 +134,14 @@ pda.plot.params <- function(settings, mcmc.param.list, prior.ind, par.file.name # rare, but this can happen; better to throw an error than continue, as it might lead # mis-interpretation of posteriors otherwise if (burnin == nrow(params.subset[[i]][[1]])) { - logger.severe(paste0("*** Burn-in is the same as the length of the chain, please run a longer chain ***")) + PEcAn.logger::logger.severe(paste0("*** Burn-in is the same as the length of the chain, please run a longer chain ***")) } params.subset[[i]] <- window(params.subset[[i]], start = max(burnin, na.rm = TRUE)) # chek number of iterations left after throwing the burnin, gelman.plot requires > 50 if (nrow(params.subset[[i]][[1]]) < 50) { - logger.info(paste0("*** Not enough iterations in the chain after removing burn-in, skipping gelman.plot ***")) + PEcAn.logger::logger.info(paste0("*** Not enough iterations in the chain after removing burn-in, skipping gelman.plot ***")) enough.iter <- FALSE } diff --git a/modules/assim.batch/R/pda.utils.R b/modules/assim.batch/R/pda.utils.R index 649c73a38ed..c98433fd981 100644 --- a/modules/assim.batch/R/pda.utils.R +++ b/modules/assim.batch/R/pda.utils.R @@ -26,7 +26,7 @@ assim.batch <- function(settings) { } else if (settings$assim.batch$method == "bayesian.tools") { settings <- pda.bayesian.tools(settings) } else { - logger.error(paste0("PDA method ", settings$assim.batch$method, " not found!")) + PEcAn.logger::logger.error(paste0("PDA method ", settings$assim.batch$method, " not found!")) } return(settings) @@ -76,7 +76,7 @@ pda.settings <- function(settings, params.id = NULL, param.names = NULL, prior.i settings$assim.batch$param.names <- param.names } if (is.null(settings$assim.batch$param.names)) { - logger.error("Parameter data assimilation requested, but no parameters specified for PDA") + PEcAn.logger::logger.error("Parameter data assimilation requested, but no parameters specified for PDA") } else { settings$assim.batch$param.names <- lapply(settings$assim.batch$param.names, as.list) } @@ -87,7 +87,7 @@ pda.settings <- function(settings, params.id = NULL, param.names = NULL, prior.i constant.names <- unlist(sapply(settings$pfts, function(x) names(x$constants))) params.in.constants <- which(unlist(settings$assim.batch$param.names) %in% constant.names) if (length(params.in.constants) > 0) { - logger.severe(paste0("PDA requested for parameter(s) [", + PEcAn.logger::logger.severe(paste0("PDA requested for parameter(s) [", paste(unlist(settings$assim.batch$param.names)[params.in.constants], collapse = ", "), "] but these parameters are specified as constants in pecan.xml!")) } @@ -223,7 +223,7 @@ pda.load.priors <- function(settings, con, extension.check = FALSE) { if (is.null(settings$assim.batch$prior$prior.id)) { - logger.info(paste0("Defaulting to most recent posterior/prior as PDA prior.")) + PEcAn.logger::logger.info(paste0("Defaulting to most recent posterior/prior as PDA prior.")) ## by default, use the most recent posterior/prior as the prior priorids <- list() for (i in seq_along(settings$pfts)) { @@ -256,7 +256,7 @@ pda.load.priors <- function(settings, con, extension.check = FALSE) { priorids <- settings$assim.batch$prior$prior.id } - logger.info(paste0("Using posterior ID(s) ", paste(unlist(priorids), collapse = ", "), " as PDA prior(s).")) + PEcAn.logger::logger.info(paste0("Using posterior ID(s) ", paste(unlist(priorids), collapse = ", "), " as PDA prior(s).")) prior.out <- list() @@ -314,7 +314,7 @@ pda.load.priors <- function(settings, con, extension.check = FALSE) { params.no.priors <- which(is.na(match(unlist(settings$assim.batch$param.names), unlist(lapply(prior.out, rownames))))) if (length(params.no.priors) > 0) { - logger.severe(paste0("PDA requested for parameter(s) [", paste(unlist(settings$assim.batch$param.names)[params.no.priors], + PEcAn.logger::logger.severe(paste0("PDA requested for parameter(s) [", paste(unlist(settings$assim.batch$param.names)[params.no.priors], collapse = ", "), "] but no prior found!")) } @@ -540,20 +540,20 @@ pda.init.run <- function(settings, con, my.write.config, workflow.id, params, ##' @author Ryan Kelly ##' @export pda.adjust.jumps <- function(settings, jmp.list, accept.rate, pnames = NULL) { - logger.info(paste0("Acceptance rates were (", paste(pnames, collapse = ", "), ") = (", + PEcAn.logger::logger.info(paste0("Acceptance rates were (", paste(pnames, collapse = ", "), ") = (", paste(round(accept.rate/settings$assim.batch$jump$adapt, 3), collapse = ", "), ")")) - # logger.info(paste0('Using jump variances (', + # PEcAn.logger::logger.info(paste0('Using jump variances (', # paste(round(unlist(settings$assim.batch$jump$jvar),3), collapse=', '), ')')) - logger.info(paste0("Old jump variances were (", paste(round(jmp.list, 3), collapse = ", "), ")")) + PEcAn.logger::logger.info(paste0("Old jump variances were (", paste(round(jmp.list, 3), collapse = ", "), ")")) adj <- accept.rate / settings$assim.batch$jump$adapt / settings$assim.batch$jump$ar.target adj[adj < settings$assim.batch$jump$adj.min] <- settings$assim.batch$jump$adj.min # settings$assim.batch$jump$jvar <- as.list(unlist(settings$assim.batch$jump$jvar) * adj) - # logger.info(paste0('New jump variances are (', + # PEcAn.logger::logger.info(paste0('New jump variances are (', # paste(round(unlist(settings$assim.batch$jump$jvar),3), collapse=', '), ')')) jmp.list <- jmp.list * adj - logger.info(paste0("New jump variances are (", paste(round(jmp.list, 3), collapse = ", "), ")")) + PEcAn.logger::logger.info(paste0("New jump variances are (", paste(round(jmp.list, 3), collapse = ", "), ")")) return(jmp.list) } # pda.adjust.jumps @@ -572,9 +572,9 @@ pda.adjust.jumps.bs <- function(settings, jcov, accept.count, params.recent) { params.recent <- params[(i - settings$assim.batch$jump$adapt):(i - 1), prior.ind] } pnames <- colnames(params.recent) - logger.info(paste0("Acceptance rate was ", + PEcAn.logger::logger.info(paste0("Acceptance rate was ", round(accept.count / settings$assim.batch$jump$adapt, 3))) - logger.info(paste0("Using jump variance diagonals (", + PEcAn.logger::logger.info(paste0("Using jump variance diagonals (", paste(pnames, collapse = ", "), ") = (", paste(round(diag(jcov), 3), collapse = ", "), ")")) @@ -595,7 +595,7 @@ pda.adjust.jumps.bs <- function(settings, jcov, accept.count, params.recent) { jcov <- rescale %*% corr %*% rescale } - logger.info(paste0("New jump variance diagonals are (", + PEcAn.logger::logger.info(paste0("New jump variance diagonals are (", paste(round(diag(jcov), 3), collapse = ", "), ")")) return(jcov) } # pda.adjust.jumps.bs diff --git a/modules/assim.sequential/DESCRIPTION b/modules/assim.sequential/DESCRIPTION index 278e9f46658..fd4e5f5a4ac 100644 --- a/modules/assim.sequential/DESCRIPTION +++ b/modules/assim.sequential/DESCRIPTION @@ -11,6 +11,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific streamline the interaction between data and models, and to improve the efficacy of scientific investigation. Imports: + PEcAn.logger, plyr (>= 1.8.4), magic (>= 1.5.0), lubridate (>= 1.6.0), diff --git a/modules/assim.sequential/R/load_data_paleon_sda.R b/modules/assim.sequential/R/load_data_paleon_sda.R index 73bf153fb18..b3d2ae5b60f 100644 --- a/modules/assim.sequential/R/load_data_paleon_sda.R +++ b/modules/assim.sequential/R/load_data_paleon_sda.R @@ -29,7 +29,7 @@ load_data_paleon_sda <- function(settings){ d <- settings$database$bety[c("dbname", "password", "host", "user")] bety <- src_postgres(host = d$host, user = d$user, password = d$password, dbname = d$dbname) - if(settings$host$name != 'localhost') logger.severe('ERROR: Code does not support anything but settings$host$name <- localhost at this time.') + if(settings$host$name != 'localhost') PEcAn.logger::logger.severe('ERROR: Code does not support anything but settings$host$name <- localhost at this time.') site <- PEcAn.DB::query.site(settings$run$site$id, bety$con) format_id <- settings$state.data.assimilation$data$format_id @@ -68,7 +68,7 @@ load_data_paleon_sda <- function(settings){ time.type <- format$vars$input_units[time.row] #THIS WONT WORK IF TIMESTEP ISNT ANNUAL # ---- LOAD INPUT DATA ---- # - logger.info(paste('Using PEcAn.benchmark::load_data.R on format_id',format_id[[i]],'-- may take a few minutes')) + PEcAn.logger::logger.info(paste('Using PEcAn.benchmark::load_data.R on format_id',format_id[[i]],'-- may take a few minutes')) obvs[[i]] <- PEcAn.benchmark::load_data(data.path, format, start_year = lubridate::year(start_date), end_year = lubridate::year(end_date), site) dataset <- obvs[[i]] @@ -83,7 +83,7 @@ load_data_paleon_sda <- function(settings){ arguments2 <- list(.(year), .(variable)) arguments3 <- list(.(MCMC_iteration), .(variable), .(year)) }else{ - logger.severe('ERROR: This data format has not been added to this function (ツ)_/¯ ') + PEcAn.logger::logger.severe('ERROR: This data format has not been added to this function (ツ)_/¯ ') } ### Map species to model specific PFTs @@ -95,7 +95,7 @@ load_data_paleon_sda <- function(settings){ x <- paste0('AGB.pft.', pft_mat$pft) names(x) <- spp_id$input_code - logger.info('Now, mapping data species to model PFTs') + PEcAn.logger::logger.info('Now, mapping data species to model PFTs') dataset$pft.cat <- x[dataset$species_id] dataset <- dataset[dataset$pft.cat!='NA_AbvGrndWood',] @@ -105,7 +105,7 @@ load_data_paleon_sda <- function(settings){ arguments3 <- list(.(MCMC_iteration), .(pft.cat, variable), .(year)) } - logger.info('Now, aggregating data and creating SDA input lists') + PEcAn.logger::logger.info('Now, aggregating data and creating SDA input lists') melt_id <- colnames(dataset)[-which(colnames(dataset) %in% variable)] melt.test <- reshape2::melt(dataset, id = melt_id, na.rm = TRUE) cast.test <- reshape2::dcast(melt.test, arguments, sum, margins = variable) diff --git a/modules/benchmark/DESCRIPTION b/modules/benchmark/DESCRIPTION index db43f19b8a7..2fb3fdbe588 100644 --- a/modules/benchmark/DESCRIPTION +++ b/modules/benchmark/DESCRIPTION @@ -11,6 +11,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific streamline the interaction between data and models, and to improve the efficacy of scientific investigation. Imports: + PEcAn.logger, lubridate (>= 1.6.0), ncdf4 (>= 1.15), udunits2 (>= 0.11), diff --git a/modules/benchmark/R/calc_benchmark.R b/modules/benchmark/R/calc_benchmark.R index d52dc73d261..0bd7a9c9320 100644 --- a/modules/benchmark/R/calc_benchmark.R +++ b/modules/benchmark/R/calc_benchmark.R @@ -132,7 +132,7 @@ calc_benchmark <- function(settings, bety) { # Check that the variables actually got loaded, otherwise don't send to calc_metrics if(!(var %in% names(obvs.calc))|!(var %in% names(model.calc))){ - logger.warn(paste0("Load did not work for ",var,". No metrics will be calculated.")) + PEcAn.logger::logger.warn(paste0("Load did not work for ",var,". No metrics will be calculated.")) next } diff --git a/modules/benchmark/R/define_benchmark.R b/modules/benchmark/R/define_benchmark.R index e146a5ccd79..3495d3379b2 100644 --- a/modules/benchmark/R/define_benchmark.R +++ b/modules/benchmark/R/define_benchmark.R @@ -14,8 +14,8 @@ define_benchmark <- function(settings, bety){ } bm.settings <- settings$benchmarking - logger.info(paste("Ensemble id:", bm.settings$ensemble_id)) - logger.info(paste(!is.null(bm.settings$ensemble_id))) + PEcAn.logger::logger.info(paste("Ensemble id:", bm.settings$ensemble_id)) + PEcAn.logger::logger.info(paste(!is.null(bm.settings$ensemble_id))) # Retrieve/create benchmark entries if(is.null(bm.settings$reference_run_id)){ @@ -68,7 +68,7 @@ define_benchmark <- function(settings, bety){ - logger.info(" ( %s, %s, %s, %s)", benchmark$input_id, benchmark$variable_id, + PEcAn.logger::logger.info(" ( %s, %s, %s, %s)", benchmark$input_id, benchmark$variable_id, benchmark$site_id, bm.settings$info$userid) diff --git a/modules/data.atmosphere/DESCRIPTION b/modules/data.atmosphere/DESCRIPTION index 484a274a6b1..d7390009e1c 100644 --- a/modules/data.atmosphere/DESCRIPTION +++ b/modules/data.atmosphere/DESCRIPTION @@ -13,6 +13,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific access diverse climate data sets. Additional Repositories: http://r-forge.r-project.org/ Imports: + PEcAn.logger, PEcAn.utils, PEcAn.DB, ggplot2, diff --git a/modules/data.atmosphere/tests/testthat.R b/modules/data.atmosphere/tests/testthat.R index 02e82cfc96a..4c07f74aeef 100644 --- a/modules/data.atmosphere/tests/testthat.R +++ b/modules/data.atmosphere/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) #test_check("PEcAn.data.atmosphere") diff --git a/modules/data.hydrology/DESCRIPTION b/modules/data.hydrology/DESCRIPTION index 0790cfa0801..2e234f01d55 100644 --- a/modules/data.hydrology/DESCRIPTION +++ b/modules/data.hydrology/DESCRIPTION @@ -12,6 +12,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific streamline the interaction between data and models, and to improve the efficacy of scientific investigation. Imports: + PEcAn.logger, PEcAn.utils Suggests: testthat (>= 1.0.2) diff --git a/modules/data.hydrology/tests/testthat.R b/modules/data.hydrology/tests/testthat.R index 18951e927db..21b568b4b6f 100644 --- a/modules/data.hydrology/tests/testthat.R +++ b/modules/data.hydrology/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) # test_check("PEcAn.data.hydrology") diff --git a/modules/data.land/DESCRIPTION b/modules/data.land/DESCRIPTION index 4a89ed95847..f5cfd4023c4 100644 --- a/modules/data.land/DESCRIPTION +++ b/modules/data.land/DESCRIPTION @@ -16,6 +16,7 @@ Depends: PEcAn.utils, dbplyr Imports: + PEcAn.logger, ncdf4 (>= 1.15), udunits2 (>= 0.11), traits, diff --git a/modules/data.land/R/extract_FIA.R b/modules/data.land/R/extract_FIA.R index 68d957067b6..b1c8ed526ae 100644 --- a/modules/data.land/R/extract_FIA.R +++ b/modules/data.land/R/extract_FIA.R @@ -39,7 +39,7 @@ extract_FIA <- function(lon, lat, start_date, end_date, gridres = 0.075, dbparms plot.info <- db.query(query, con = fia.con) if (nrow(plot.info) == 0) { - logger.severe("No plot data found on FIA.") + PEcAn.logger::logger.severe("No plot data found on FIA.") } for (statecd in unique(plot.info$statecd)) { @@ -59,7 +59,7 @@ extract_FIA <- function(lon, lat, start_date, end_date, gridres = 0.075, dbparms plot.info <- plot.info[.select.unique.fia.plot.records(plot.info$patch, plot.info$prev_plt_cn, plot.info$time, start_year), ] if (nrow(plot.info) == 0) { - logger.severe("All plot data were invalid.") + PEcAn.logger::logger.severe("All plot data were invalid.") } plot.info$trk[is.na(plot.info$trk)] <- 1 @@ -68,7 +68,7 @@ extract_FIA <- function(lon, lat, start_date, end_date, gridres = 0.075, dbparms # Dropping unneeded columns plot.info <- plot.info[, c("time", "patch", "trk", "age")] - logger.debug(paste0("Found ", nrow(plot.info), " patches for coordinates lat:", lat, " lon:", lon)) + PEcAn.logger::logger.debug(paste0("Found ", nrow(plot.info), " patches for coordinates lat:", lat, " lon:", lon)) veg_info[[1]] <- plot.info @@ -89,17 +89,17 @@ extract_FIA <- function(lon, lat, start_date, end_date, gridres = 0.075, dbparms names(tree.info) <- tolower(names(tree.info)) if (nrow(tree.info) == 0) { - logger.severe("No FIA data found.") + PEcAn.logger::logger.severe("No FIA data found.") } else { - logger.debug(paste0(nrow(tree.info), " trees found initially")) + PEcAn.logger::logger.debug(paste0(nrow(tree.info), " trees found initially")) } # Remove rows that don't map to any retained patch tree.info <- tree.info[which(tree.info$patch %in% plot.info$patch), ] if (nrow(tree.info) == 0) { - logger.severe("No trees map to previously selected patches.") + PEcAn.logger::logger.severe("No trees map to previously selected patches.") } else { - logger.debug(paste0(nrow(tree.info), " trees that map to previously selected patches.")) + PEcAn.logger::logger.debug(paste0(nrow(tree.info), " trees that map to previously selected patches.")) } ## Remove rows with no dbh, spcd, or n @@ -108,9 +108,9 @@ extract_FIA <- function(lon, lat, start_date, end_date, gridres = 0.075, dbparms tree.info <- tree.info[-notree, ] } if (nrow(tree.info) == 0) { - logger.severe("No trees remain after removing entries with no dbh, spcd, and/or n.") + PEcAn.logger::logger.severe("No trees remain after removing entries with no dbh, spcd, and/or n.") } else { - logger.debug(paste0(nrow(tree.info), " trees remain after removing entries with no dbh, spcd, and/or n.")) + PEcAn.logger::logger.debug(paste0(nrow(tree.info), " trees remain after removing entries with no dbh, spcd, and/or n.")) } veg_info[[2]] <- tree.info @@ -129,7 +129,7 @@ extract_FIA <- function(lon, lat, start_date, end_date, gridres = 0.075, dbparms # current code. But it could be useful for future updates. .select.unique.fia.plot.records <- function(plt_cn, prev_plt_cn, measyear, target.year) { if (length(plt_cn) != length(prev_plt_cn)) { - logger.error("Inputs must have same length!") + PEcAn.logger::logger.error("Inputs must have same length!") return(NULL) } @@ -183,4 +183,4 @@ extract_FIA <- function(lon, lat, start_date, end_date, gridres = 0.075, dbparms } return(sort(ind.keep)) -} # .select.unique.fia.plot.records \ No newline at end of file +} # .select.unique.fia.plot.records diff --git a/modules/data.land/R/extract_veg.R b/modules/data.land/R/extract_veg.R index 4dd24fbb8e8..72ca3c2418e 100644 --- a/modules/data.land/R/extract_veg.R +++ b/modules/data.land/R/extract_veg.R @@ -14,7 +14,7 @@ extract_veg <- function(new_site, start_date, end_date, fcnx <- paste0("extract_", source) # e.g. extract_FIA if (!exists(fcnx)) { - logger.severe(paste(fcnx, "does not exist.")) + PEcAn.logger::logger.severe(paste(fcnx, "does not exist.")) }else{ fcn <- match.fun(fcnx) } @@ -64,4 +64,4 @@ extract_veg <- function(new_site, start_date, end_date, return(invisible(results)) -} # extract_veg \ No newline at end of file +} # extract_veg diff --git a/modules/data.land/R/fia2ED.R b/modules/data.land/R/fia2ED.R index 043d770eddc..42bf49221ec 100644 --- a/modules/data.land/R/fia2ED.R +++ b/modules/data.land/R/fia2ED.R @@ -64,10 +64,10 @@ fia.to.psscss <- function(settings, pss.path = file.paths$ED2.patch, site.path = file.paths$ED2.site) - logger.info("Using existing pss, css, and site files.") + PEcAn.logger::logger.info("Using existing pss, css, and site files.") return(invisible(settings)) } else { - logger.info("No existing pss, css, and site files.") + PEcAn.logger::logger.info("No existing pss, css, and site files.") } } @@ -93,7 +93,7 @@ fia.to.psscss <- function(settings, pft.number <- pftmapping$ED[which(pftmapping == pft.i$name)] } if (is.null(pft.number)) { - logger.severe(paste0("Couldn't find an ED2 PFT number for ", pft.i$name)) + PEcAn.logger::logger.severe(paste0("Couldn't find an ED2 PFT number for ", pft.i$name)) } pfts$pft[pfts$pft == pft.i$name] <- pft.number } @@ -102,7 +102,7 @@ fia.to.psscss <- function(settings, ## Check for NA and duplicate spcds in PFTs bad <- length(pfts$spcd %in% c(NA, "0")) if (bad > 0) { - logger.warn(sprintf("There are %d entries with no SPCD (NA or 0). They have been removed.", bad)) + PEcAn.logger::logger.warn(sprintf("There are %d entries with no SPCD (NA or 0). They have been removed.", bad)) pfts <- pfts[!pfts$spcd %in% c(NA, 0), ] } @@ -115,7 +115,7 @@ fia.to.psscss <- function(settings, # grab the names where we have bad spcds in the symbol.table, exclude NAs name.list <- na.omit(symbol.table$symbol[symbol.table$spcd %in% bad]) - logger.severe(paste0("The following species are found in multiple PFTs: ", + PEcAn.logger::logger.severe(paste0("The following species are found in multiple PFTs: ", paste(name.list[1:min(10, length(name.list))], collapse = ", "), ". Please remove overlapping PFTs.")) } @@ -139,7 +139,7 @@ fia.to.psscss <- function(settings, pss <- db.query(query, con = fia.con) if (nrow(pss) == 0) { - logger.severe("No pss data found.") + PEcAn.logger::logger.severe("No pss data found.") } for (statecd in unique(pss$statecd)) { @@ -159,7 +159,7 @@ fia.to.psscss <- function(settings, pss <- pss[.select.unique.fia.plot.records(pss$patch, pss$prev_plt_cn, pss$time, year), ] if (nrow(pss) == 0) { - logger.severe("All pss data were invalid.") + PEcAn.logger::logger.severe("All pss data were invalid.") } pss$trk[which(is.na(pss$trk))] <- 1 @@ -181,7 +181,7 @@ fia.to.psscss <- function(settings, names(soil.dat) <- c("fsc", "stsc", "stsl", "ssc", "psc", "msn", "fsn") pss <- cbind(pss, soil.dat) - logger.debug(paste0("Found ", nrow(pss), " patches for site ", settings$run$site$id)) + PEcAn.logger::logger.debug(paste0("Found ", nrow(pss), " patches for site ", settings$run$site$id)) ################## ## ## @@ -198,17 +198,17 @@ fia.to.psscss <- function(settings, css <- db.query(query, con = fia.con) names(css) <- tolower(names(css)) if (nrow(css) == 0) { - logger.severe("No FIA data found.") + PEcAn.logger::logger.severe("No FIA data found.") } else { - logger.debug(paste0(nrow(css), " trees found initially")) + PEcAn.logger::logger.debug(paste0(nrow(css), " trees found initially")) } # Remove rows that don't map to any retained patch css <- css[which(css$patch %in% pss$patch), ] if (nrow(css) == 0) { - logger.severe("No trees map to previously selected patches.") + PEcAn.logger::logger.severe("No trees map to previously selected patches.") } else { - logger.debug(paste0(nrow(css), " trees that map to previously selected patches.")) + PEcAn.logger::logger.debug(paste0(nrow(css), " trees that map to previously selected patches.")) } @@ -218,9 +218,9 @@ fia.to.psscss <- function(settings, css <- css[-notree, ] } if (nrow(css) == 0) { - logger.severe("No trees remain after removing entries with no dbh, spcd, and/or n.") + PEcAn.logger::logger.severe("No trees remain after removing entries with no dbh, spcd, and/or n.") } else { - logger.debug(paste0(nrow(css), " trees remain after removing entries with no dbh, spcd, and/or n.")) + PEcAn.logger::logger.debug(paste0(nrow(css), " trees remain after removing entries with no dbh, spcd, and/or n.")) } # --- Consistency tests between PFTs and FIA @@ -236,7 +236,7 @@ fia.to.psscss <- function(settings, names(symbol.table) <- tolower(names(symbol.table)) } name.list <- na.omit(symbol.table$symbol[symbol.table$spcd %in% pft.only]) - logger.warn(paste0("The selected PFTs contain the following species for which the FIA database ", + PEcAn.logger::logger.warn(paste0("The selected PFTs contain the following species for which the FIA database ", "contains no data at ", lat, " and ", lon, ": ", paste(name.list[1:min(10, length(name.list))], collapse = ", "), ".")) } @@ -253,7 +253,7 @@ fia.to.psscss <- function(settings, name.list <- na.omit(symbol.table$symbol[symbol.table$spcd %in% fia.only]) name.list <- name.list[name.list != "DEAD"] if (length(name.list) > 0) { - logger.warn(paste0("The FIA database expects the following species at ", lat, " and ", lon, + PEcAn.logger::logger.warn(paste0("The FIA database expects the following species at ", lat, " and ", lon, " but they are not described by the selected PFTs: ", paste(name.list, collapse = ", "), ". You should select additional pfts if you want to include these. ")) @@ -262,11 +262,11 @@ fia.to.psscss <- function(settings, css <- css[!(css$spcd %in% fia.only), ] if (nrow(css) == 0) { - logger.severe(paste0("No trees remain for selected PFTs. ", + PEcAn.logger::logger.severe(paste0("No trees remain for selected PFTs. ", "Species that were in FIA data but didn't map to a selected PFT are: ", paste(name.list, collapse = ", "), ".")) } else { - logger.debug(paste0(nrow(css), " trees remain for selected PFTs.")) + PEcAn.logger::logger.debug(paste0(nrow(css), " trees remain for selected PFTs.")) } @@ -286,11 +286,11 @@ fia.to.psscss <- function(settings, pfts.represented <- sapply(settings$pfts, function(x) x$constants$num) %in% css$pft if (!all(pfts.represented)) - logger.warn(paste0( + PEcAn.logger::logger.warn(paste0( "The following PFTs listed in settings are not represented in the FIA data: ", paste(sapply(settings$pfts, function(x) x$name)[!pfts.represented], collapse = ", "))) - logger.debug(paste0("Found ", nrow(css), " cohorts for site ", settings$run$site$id)) + PEcAn.logger::logger.debug(paste0("Found ", nrow(css), " cohorts for site ", settings$run$site$id)) ################## ## ## @@ -404,7 +404,7 @@ get.ed.file.latlon.text <- function(lat, lon, site.style = FALSE, ed.res = 1) { # current code. But it could be useful for future updates. .select.unique.fia.plot.records <- function(plt_cn, prev_plt_cn, measyear, target.year) { if (length(plt_cn) != length(prev_plt_cn)) { - logger.error("Inputs must have same length!") + PEcAn.logger::logger.error("Inputs must have same length!") return(NULL) } diff --git a/modules/data.land/R/get.veg.module.R b/modules/data.land/R/get.veg.module.R index 741884cc176..2f325e58c81 100644 --- a/modules/data.land/R/get.veg.module.R +++ b/modules/data.land/R/get.veg.module.R @@ -54,7 +54,7 @@ if(!is.null(input_veg$source.id)){ source.id <- input_veg$source.id }else{ - logger.error("Must specify input source.id") + PEcAn.logger::logger.error("Must specify input source.id") } getveg.id <- convert.input(input.id = NA, diff --git a/modules/data.land/R/load_veg.R b/modules/data.land/R/load_veg.R index 8bc114d9a51..4f485a5ad77 100644 --- a/modules/data.land/R/load_veg.R +++ b/modules/data.land/R/load_veg.R @@ -38,10 +38,10 @@ load_veg <- function(new_site, start_date, end_date, code.col <- "latin_name" # might indicate a custom format, should be passed to function if(is.null(format_name)){ - logger.severe("Can't match code to species. Please provide 'match.format' via settings.") + PEcAn.logger::logger.severe("Can't match code to species. Please provide 'match.format' via settings.") } }else{ - logger.severe("Can't match code to species. No valid format found.") + PEcAn.logger::logger.severe("Can't match code to species. No valid format found.") } # match code to species ID diff --git a/modules/data.land/R/put.veg.module.R b/modules/data.land/R/put.veg.module.R index 0e47d32861e..779303fa5c6 100644 --- a/modules/data.land/R/put.veg.module.R +++ b/modules/data.land/R/put.veg.module.R @@ -22,7 +22,7 @@ " join formats as f on mf.format_id = f.id", " join mimetypes as mt on f.mimetype_id = mt.id", " where m.name = '", model, "' AND mf.tag='", input_veg$output,"'"), con) - logger.info("Begin Model Specific Conversion") + PEcAn.logger::logger.info("Begin Model Specific Conversion") formatname <- model_info[1] mimetype <- model_info[3] @@ -55,4 +55,4 @@ return(putveg.id) -} \ No newline at end of file +} diff --git a/modules/data.land/R/write_ic.R b/modules/data.land/R/write_ic.R index 6a20fdf2d9c..5cbfccc8659 100644 --- a/modules/data.land/R/write_ic.R +++ b/modules/data.land/R/write_ic.R @@ -33,7 +33,7 @@ write_ic <- function(in.path, in.name, start_date, end_date, do.call("library", list(pkg)) fcnx <- paste("veg2model.", model, sep = "") if (!exists(fcnx)) { - logger.severe(paste(fcnx, "does not exist.")) + PEcAn.logger::logger.severe(paste(fcnx, "does not exist.")) }else{ fcn <- match.fun(fcnx) } diff --git a/modules/data.land/tests/testthat.R b/modules/data.land/tests/testthat.R index 06e1f1c117c..b0c9f33bba9 100644 --- a/modules/data.land/tests/testthat.R +++ b/modules/data.land/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) test_check("PEcAn.data.land") diff --git a/modules/data.mining/DESCRIPTION b/modules/data.mining/DESCRIPTION index ce475137847..06b11eec36e 100644 --- a/modules/data.mining/DESCRIPTION +++ b/modules/data.mining/DESCRIPTION @@ -8,6 +8,8 @@ Author: Mike Dietze Maintainer: Mike Dietze Depends: dplR +Imports: + PEcAn.logger Suggests: PEcAn.utils, testthat (>= 1.0.2) diff --git a/modules/data.mining/tests/testthat.R b/modules/data.mining/tests/testthat.R index 39f3bbf2c92..dc6f0f472d7 100644 --- a/modules/data.mining/tests/testthat.R +++ b/modules/data.mining/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) # test_check("PEcAn.data.mining") diff --git a/modules/data.remote/DESCRIPTION b/modules/data.remote/DESCRIPTION index a3b5ea1fd2d..09f85ed5da1 100644 --- a/modules/data.remote/DESCRIPTION +++ b/modules/data.remote/DESCRIPTION @@ -7,6 +7,7 @@ Author: Mike Dietze Maintainer: Mike Dietze Description: PEcAn module for processing remote data Imports: + PEcAn.logger, stringr(>= 1.1.0) Suggests: testthat (>= 1.0.2) diff --git a/modules/emulator/DESCRIPTION b/modules/emulator/DESCRIPTION index cb30e1be695..01cd18fb590 100644 --- a/modules/emulator/DESCRIPTION +++ b/modules/emulator/DESCRIPTION @@ -10,6 +10,7 @@ Depends: mlegp, MCMCpack Imports: + PEcAn.logger, coda (>= 0.18), methods Description: Implementation of a Gaussian Process model (both likelihood and diff --git a/modules/meta.analysis/DESCRIPTION b/modules/meta.analysis/DESCRIPTION index fedc78da018..35d1c988b1f 100644 --- a/modules/meta.analysis/DESCRIPTION +++ b/modules/meta.analysis/DESCRIPTION @@ -19,6 +19,7 @@ Depends: PEcAn.utils, PEcAn.DB Imports: + PEcAn.logger, coda (>= 0.18) Suggests: rjags, diff --git a/modules/meta.analysis/R/jagify.R b/modules/meta.analysis/R/jagify.R index 8f4faa61d85..8f0b24a44fa 100644 --- a/modules/meta.analysis/R/jagify.R +++ b/modules/meta.analysis/R/jagify.R @@ -39,7 +39,7 @@ jagify <- function(result) { varswithbadstats <- unique(result$vname[which(r$stat <= 0)]) citationswithbadstats <- unique(r$citation_id[which(r$stat <= 0)]) - logger.warn("there are implausible values of SE: SE <= 0 \n", + PEcAn.logger::logger.warn("there are implausible values of SE: SE <= 0 \n", "for", varswithbadstats, "result from citation", citationswithbadstats, "\n", "SE <=0 set to NA \n") diff --git a/modules/meta.analysis/R/meta.analysis.summary.R b/modules/meta.analysis/R/meta.analysis.summary.R index 3ad3cb67d70..b69f9f5cd46 100644 --- a/modules/meta.analysis/R/meta.analysis.summary.R +++ b/modules/meta.analysis/R/meta.analysis.summary.R @@ -70,20 +70,20 @@ pecan.ma.summary <- function(mcmc.object, pft, outdir, threshold = 1.2, gg = FAL mpsrf <- round(gd$mpsrf, digits = 3) not.converged <- data.frame() if (mpsrf < threshold) { - logger.info(paste("JAGS model converged for", pft, trait, + PEcAn.logger::logger.info(paste("JAGS model converged for", pft, trait, "\nGD MPSRF = ", mpsrf, "\n")) } else { not.converged <- rbind(not.converged, data.frame(pft = pft, trait = trait, mpsrf = mpsrf)) - logger.info(paste("JAGS model did not converge for", pft, trait, + PEcAn.logger::logger.info(paste("JAGS model did not converge for", pft, trait, "\nGD MPSRF = ", mpsrf, "\n")) fail <- TRUE } } if (fail) { - logger.warn("JAGS model failed to converge for one or more pft.") + PEcAn.logger::logger.warn("JAGS model failed to converge for one or more pft.") for (i in seq_len(nrow(not.converged))) { - with(not.converged[i, ], logger.info(paste(pft, trait, "MPSRF = ", mpsrf))) + with(not.converged[i, ], PEcAn.logger::logger.info(paste(pft, trait, "MPSRF = ", mpsrf))) } } sink() diff --git a/modules/meta.analysis/R/run.meta.analysis.R b/modules/meta.analysis/R/run.meta.analysis.R index a2cd8929d5e..4c3b3c603aa 100644 --- a/modules/meta.analysis/R/run.meta.analysis.R +++ b/modules/meta.analysis/R/run.meta.analysis.R @@ -11,7 +11,7 @@ run.meta.analysis.pft <- function(pft, iterations, random = TRUE, threshold = 1. # check to see if get.trait was executed if (!file.exists(file.path(pft$outdir, "trait.data.Rdata")) || !file.exists(file.path(pft$outdir, "prior.distns.Rdata"))) { - logger.severe("Could not find output from get.trait for", pft$name) + PEcAn.logger::logger.severe("Could not find output from get.trait for", pft$name) return(NA) } @@ -19,29 +19,29 @@ run.meta.analysis.pft <- function(pft, iterations, random = TRUE, threshold = 1. if (file.exists(file.path(pft$outdir, "trait.mcmc.Rdata")) && file.exists(file.path(pft$outdir, "post.distns.Rdata")) && settings$meta.analysis$update != TRUE) { - logger.info("Assuming get.trait copied results already") + PEcAn.logger::logger.info("Assuming get.trait copied results already") return(pft) } # make sure there is a posteriorid if (is.null(pft$posteriorid)) { - logger.severe("Make sure to pass in pft list from get.trait. Missing posteriorid for", pft$name) + PEcAn.logger::logger.severe("Make sure to pass in pft list from get.trait. Missing posteriorid for", pft$name) return(NA) } # get list of existing files so they get ignored saving old.files <- list.files(path = pft$outdir) - logger.info("-------------------------------------------------------------------") - logger.info(" Running meta.analysis for PFT:", pft$name) - logger.info("-------------------------------------------------------------------") + PEcAn.logger::logger.info("-------------------------------------------------------------------") + PEcAn.logger::logger.info(" Running meta.analysis for PFT:", pft$name) + PEcAn.logger::logger.info("-------------------------------------------------------------------") ## Load trait data for PFT load(file.path(pft$outdir, "trait.data.Rdata")) load(file.path(pft$outdir, "prior.distns.Rdata")) if (length(trait.data) == 0) { - logger.info("no trait data for PFT", pft$name, "\n so no meta-analysis will be performed") + PEcAn.logger::logger.info("no trait data for PFT", pft$name, "\n so no meta-analysis will be performed") return(NA) } @@ -59,15 +59,15 @@ run.meta.analysis.pft <- function(pft, iterations, random = TRUE, threshold = 1. if (p.data <= 1 - perr & p.data >= perr) { if (p.data <= 1 - pwarn & p.data >= pwarn) { - logger.info("OK! ", trait, " ", msg_var, " and prior are consistent:") + PEcAn.logger::logger.info("OK! ", trait, " ", msg_var, " and prior are consistent:") } else { - logger.warn("CHECK THIS: ", trait, " ", msg_var, " and prior are inconsistent:") + PEcAn.logger::logger.warn("CHECK THIS: ", trait, " ", msg_var, " and prior are inconsistent:") } } else { - logger.debug("NOT OK! ", trait, " ", msg_var, " and prior are probably not the same:") + PEcAn.logger::logger.debug("NOT OK! ", trait, " ", msg_var, " and prior are probably not the same:") return(NA) } - logger.info(trait, "P[X 1.2) { - logger.warn("model did not converge; re-running with j.iter * 10") + PEcAn.logger::logger.warn("model did not converge; re-running with j.iter * 10") jags.out <- coda.samples(model = j.model, variable.names = vars, n.iter = j.iter * 10, diff --git a/modules/meta.analysis/tests/testthat.R b/modules/meta.analysis/tests/testthat.R index 789e11f4650..b8f45fe201f 100644 --- a/modules/meta.analysis/tests/testthat.R +++ b/modules/meta.analysis/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) test_check("PEcAn.MA") diff --git a/modules/photosynthesis/DESCRIPTION b/modules/photosynthesis/DESCRIPTION index 1a01cefab12..16c32cbe303 100644 --- a/modules/photosynthesis/DESCRIPTION +++ b/modules/photosynthesis/DESCRIPTION @@ -15,6 +15,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific Depends: rjags Imports: + PEcAn.logger, coda (>= 0.18) SystemRequirements: JAGS2.2.0 License: FreeBSD + file LICENSE diff --git a/modules/priors/DESCRIPTION b/modules/priors/DESCRIPTION index 21726539f6c..96256e89d47 100644 --- a/modules/priors/DESCRIPTION +++ b/modules/priors/DESCRIPTION @@ -12,6 +12,8 @@ LazyLoad: yes LazyData: FALSE Depends: PEcAn.utils +Imports: + PEcAn.logger Suggests: testthat RoxygenNote: 6.0.1 diff --git a/modules/priors/R/priors.R b/modules/priors/R/priors.R index 71cec84a0ae..6453e44b995 100644 --- a/modules/priors/R/priors.R +++ b/modules/priors/R/priors.R @@ -41,7 +41,7 @@ fit.dist <- function(trait.data, trait = colnames(trait.data), a[["f"]] <- suppressWarnings(fitdistr(trait.data, "f", start = list(df1 = 1, df2 = 2))) } else { - logger.severe(paste(trait, "not supported!")) + PEcAn.logger::logger.severe(paste(trait, "not supported!")) } } if ("beta" %in% dists) { @@ -102,7 +102,7 @@ prior.fn <- function(parms, x, alpha, distn, central.tendency = NULL, trait = NU } else if (central.tendency == "median") { ct <- qlnorm(0.5, parms[1], parms[2]) } else { - logger.severe(paste(central.tendency, "not supported!")) + PEcAn.logger::logger.severe(paste(central.tendency, "not supported!")) } x <- log(x) } diff --git a/modules/priors/tests/testthat.R b/modules/priors/tests/testthat.R index 54e05816078..309df175824 100644 --- a/modules/priors/tests/testthat.R +++ b/modules/priors/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) test_check("PEcAn.priors") diff --git a/modules/rtm/DESCRIPTION b/modules/rtm/DESCRIPTION index 908115e955b..dff5d97b6bd 100644 --- a/modules/rtm/DESCRIPTION +++ b/modules/rtm/DESCRIPTION @@ -10,6 +10,7 @@ Description: This package contains functions for performing forward runs and using maximum likelihood, or more complex hierarchical Bayesian methods. Underlying numerical analyses are optimized for speed using Fortran code. Imports: + PEcAn.logger, MASS, coda, lubridate (>= 1.6.0), diff --git a/modules/uncertainty/DESCRIPTION b/modules/uncertainty/DESCRIPTION index 1232f09d2a6..b24a7c25547 100644 --- a/modules/uncertainty/DESCRIPTION +++ b/modules/uncertainty/DESCRIPTION @@ -15,6 +15,7 @@ Description: The Predictive Ecosystem Carbon Analyzer models, and to improve the efficacy of scientific investigation. Depends: + PEcAn.logger, PEcAn.utils, PEcAn.priors, ggplot2, diff --git a/modules/uncertainty/R/run.ensemble.analysis.R b/modules/uncertainty/R/run.ensemble.analysis.R index 9afdeea1453..d7deb34425a 100644 --- a/modules/uncertainty/R/run.ensemble.analysis.R +++ b/modules/uncertainty/R/run.ensemble.analysis.R @@ -31,7 +31,7 @@ run.ensemble.analysis <- function(settings, plot.timeseries = NA, ensemble.id = ensemble.id <- max(ens.ids) } else { if (is.null(ensemble.id)) - logger.severe("Can't find a valid ensemble for ensemble analysis!") + PEcAn.logger::logger.severe("Can't find a valid ensemble for ensemble analysis!") } } @@ -42,7 +42,7 @@ run.ensemble.analysis <- function(settings, plot.timeseries = NA, ensemble.id = end.year <- settings$ensemble$end.year } if (is.null(start.year) | is.null(end.year)) { - logger.severe("No years given for ensemble analysis!") + PEcAn.logger::logger.severe("No years given for ensemble analysis!") } if (is.null(variable)) { @@ -54,13 +54,13 @@ run.ensemble.analysis <- function(settings, plot.timeseries = NA, ensemble.id = } } if (is.null(variable)) { - logger.severe("No variables for ensemble analysis!") + PEcAn.logger::logger.severe("No variables for ensemble analysis!") } # Only handling one variable at a time for now if (length(variable) > 1) { variable <- variable[1] - logger.warn(paste0("Currently performs ensemble analysis on only one variable at a time. Using first (", + PEcAn.logger::logger.warn(paste0("Currently performs ensemble analysis on only one variable at a time. Using first (", variable, ")")) } @@ -85,7 +85,7 @@ run.ensemble.analysis <- function(settings, plot.timeseries = NA, ensemble.id = my.dat = unlist(ensemble.output) if(is.null(my.dat)){ - logger.warn("no data in ensemble.output") + PEcAn.logger::logger.warn("no data in ensemble.output") return() } @@ -184,7 +184,7 @@ read.ensemble.ts <- function(settings, ensemble.id = NULL, variable = NULL, end.year <- settings$ensemble$end.year } if (is.null(start.year) | is.null(end.year)) { - logger.severe("No years given for ensemble analysis!") + PEcAn.logger::logger.severe("No years given for ensemble analysis!") } if (is.null(variable)) { @@ -196,13 +196,13 @@ read.ensemble.ts <- function(settings, ensemble.id = NULL, variable = NULL, } } if (is.null(variable)) { - logger.severe("No variables for ensemble analysis!") + PEcAn.logger::logger.severe("No variables for ensemble analysis!") } # Only handling one variable at a time for now if (length(variable) > 1) { variable <- variable[1] - logger.warn(paste0("Currently performs ensemble analysis on only one variable at a time. Using first (", + PEcAn.logger::logger.warn(paste0("Currently performs ensemble analysis on only one variable at a time. Using first (", variable, ")")) } @@ -230,7 +230,7 @@ read.ensemble.ts <- function(settings, ensemble.id = NULL, variable = NULL, fname <- file.path(settings$outdir, "samples.Rdata") } if (!file.exists(fname)) { - logger.severe("No ensemble samples file found!") + PEcAn.logger::logger.severe("No ensemble samples file found!") } load(fname) diff --git a/modules/uncertainty/R/run.sensitivity.analysis.R b/modules/uncertainty/R/run.sensitivity.analysis.R index 1369b014c77..e5f010813d0 100644 --- a/modules/uncertainty/R/run.sensitivity.analysis.R +++ b/modules/uncertainty/R/run.sensitivity.analysis.R @@ -31,26 +31,26 @@ run.sensitivity.analysis <- function(settings,plot=TRUE, ensemble.id=NULL, varia end.year <- settings$sensitivity.analysis$end.year } if(is.null(start.year) | is.null(end.year)) { - logger.severe("No years given for sensitivity analysis!") + PEcAn.logger::logger.severe("No years given for sensitivity analysis!") } if(is.null(variable)) { variable = settings$sensitivity.analysis$variable } if(is.null(variable)) { - logger.severe("No variables for ensemble analysis!") + PEcAn.logger::logger.severe("No variables for ensemble analysis!") } # Only handling one variable at a time for now if(length(variable) > 1) { variable <- variable[1] - logger.warn(paste0("Currently performs ensemble analysis on only one variable at a time. Using first (", variable, ")")) + PEcAn.logger::logger.warn(paste0("Currently performs ensemble analysis on only one variable at a time. Using first (", variable, ")")) } ### Load samples # Have to load samples.Rdata for the traits. But can overwrite the run ids if a sensitivity analysis ensemble id provided. samples.Rdata always has only the most recent ensembles for both ensemble and sensitivity runs. fname <- file.path(settings$outdir, 'samples.Rdata') - if(!file.exists(fname)) logger.severe("No samples.Rdata file found!") + if(!file.exists(fname)) PEcAn.logger::logger.severe("No samples.Rdata file found!") load(fname) # Can specify ensemble ids manually. If not, look in settings. If none there, will use the most recent, which was loaded with samples.Rdata diff --git a/modules/uncertainty/tests/testthat.R b/modules/uncertainty/tests/testthat.R index 284376523ad..09d9953c3c2 100644 --- a/modules/uncertainty/tests/testthat.R +++ b/modules/uncertainty/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) test_check("PEcAn.uncertainty") diff --git a/qaqc/DESCRIPTION b/qaqc/DESCRIPTION index 690c937c63a..c2d23d56b95 100644 --- a/qaqc/DESCRIPTION +++ b/qaqc/DESCRIPTION @@ -8,6 +8,8 @@ Maintainer: David LeBauer Description: PEcAn integration and model skill testing Depends: plotrix +Imports: + PEcAn.logger License: FreeBSD + file LICENSE Copyright: Authors LazyLoad: yes diff --git a/qaqc/tests/testthat.R b/qaqc/tests/testthat.R index 58bb91538dd..0ec2de56be0 100644 --- a/qaqc/tests/testthat.R +++ b/qaqc/tests/testthat.R @@ -9,5 +9,5 @@ library(testthat) library(PEcAn.utils) -logger.setQuitOnSevere(FALSE) +PEcAn.logger::logger.setQuitOnSevere(FALSE) #test_check("PEcAn.qaqc") diff --git a/scripts/workflow.bm.R b/scripts/workflow.bm.R index 044e664b17e..20cb5e0e3d2 100644 --- a/scripts/workflow.bm.R +++ b/scripts/workflow.bm.R @@ -46,7 +46,7 @@ status.check <- function(name) { } status.data[name, ] if (is.na(status.data[name, 3])) { - logger.warn("UNKNOWN STATUS FOR", name) + PEcAn.logger::logger.warn("UNKNOWN STATUS FOR", name) return(0) } if (status.data[name, 3] == "DONE") { diff --git a/shiny/global-sensitivity/load_ensemble.R b/shiny/global-sensitivity/load_ensemble.R index 5c82832a5bc..6501ed02d3b 100644 --- a/shiny/global-sensitivity/load_ensemble.R +++ b/shiny/global-sensitivity/load_ensemble.R @@ -27,7 +27,7 @@ load_ensemble <- function(workflow_dir, settings, variable){ ensemble.output.raw <- list() for (row in rownames(ens.run.ids)) { run.id <- ens.run.ids[row, "id"] - logger.info("reading ensemble output from run id: ", run.id) + PEcAn.logger::logger.info("reading ensemble output from run id: ", run.id) ensemble.output.raw[[row]] <- sapply(read.output(run.id, file.path(settings$modeloutdir, run.id), as.numeric(settings$ensemble$start.year), diff --git a/tests/interactive-workflow.R b/tests/interactive-workflow.R index 9691f3080c4..2315ed4c77e 100644 --- a/tests/interactive-workflow.R +++ b/tests/interactive-workflow.R @@ -76,13 +76,13 @@ saveXML(listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml if (!file.exists(file.path(settings$rundir, "runs.txt")) | settings$meta.analysis$update == "TRUE") { run.write.configs(settings, settings$database$bety$write) } else { - logger.info("Already wrote configuraiton files") + PEcAn.logger::logger.info("Already wrote configuraiton files") } # run model if (!file.exists(file.path(settings$rundir, "runs.txt"))) { - logger.severe("No ensemble or sensitivity analysis specified in pecan.xml, work is done.") + PEcAn.logger::logger.severe("No ensemble or sensitivity analysis specified in pecan.xml, work is done.") } else { start.model.runs(settings, settings$database$bety$write) } @@ -94,14 +94,14 @@ get.results(settings) if (!file.exists(file.path(settings$outdir,"ensemble.ts.pdf"))) { run.ensemble.analysis(settings,TRUE) } else { - logger.info("Already executed run.ensemble.analysis()") + PEcAn.logger::logger.info("Already executed run.ensemble.analysis()") } # sensitivity analysis if (!file.exists(file.path(settings$outdir, "sensitivity.results.Rdata"))) { run.sensitivity.analysis(settings) } else { - logger.info("Already executed run.sensitivity.analysis()") + PEcAn.logger::logger.info("Already executed run.sensitivity.analysis()") } # all done From b7a3fd923cc133e61dcec601b94e4edfc7ae42f7 Mon Sep 17 00:00:00 2001 From: annethomas Date: Fri, 18 Aug 2017 16:43:09 -0400 Subject: [PATCH 340/771] Add reallocation if leaf is too high --- modules/data.land/R/prepare_pools.R | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/modules/data.land/R/prepare_pools.R b/modules/data.land/R/prepare_pools.R index c6cec6d8efe..e09f45a18d1 100644 --- a/modules/data.land/R/prepare_pools.R +++ b/modules/data.land/R/prepare_pools.R @@ -88,8 +88,28 @@ prepare_pools <- function(nc.path, constants = NULL){ wood <- (TotLivBiom - leaf - fine.roots) if (wood >= 0){ IC.params[["wood"]] <- wood - }else{ - PEcAn.utils::logger.error(paste("TotLivBiom (", TotLivBiom, ") is less than sum of leaf (", leaf, ") and fine roots(",fine.roots,"); will use default for woody biomass.")) + }else if ((leaf + fine.roots) < (TotLivBiom * 1.25)){ + PEcAn.utils::logger.error(paste("prepare_pools: Sum of leaf (", leaf, ") and fine roots(", fine.roots, ") is greater than TotLivBiom (", TotLivBiom, "); will reappportion for woody biomass.")) + #estimate new woody biomass and reapportion + if(is.valid(coarse.roots)){ + #expand wood by coarse root to stem fraction (currently applied to both woody and non-woody) + root.wood.frac <- 0.2 #deciduous forest, White et al.2000 + stem.wood.frac <- 0.8 + wood <- coarse.roots + ((stem.wood.frac * coarse.roots) / root.wood.frac) #cross multiply for stem wood and add + + }else{ + wood <- 0 + } + #reapportion wood, leaf and fine roots within TotLivBiom + leaf.new <- (leaf / (leaf + wood + fine.roots)) * TotLivBiom + roots.new <- (fine.roots / (leaf + wood + fine.roots)) * TotLivBiom + wood.new <- (wood / (leaf + wood + fine.roots)) * TotLivBiom + IC.params[["wood"]] <- wood.new + IC.params[["leaf"]] <- leaf.new + IC.params[["fine.roots"]] <- roots.new + PEcAn.utils::logger.info(paste("prepare_pools: Using", wood.new, "for wood, ", leaf.new, "for leaf,", roots.new, " for fine roots.")) + } else{ + PEcAn.utils::logger.severe(paste("prepare_pools: Sum of leaf (", leaf, ") and fine roots(", fine.roots, ") is more than 25% greater than TotLivBiom (", TotLivBiom, "); please check IC inputs.")) } } else{ PEcAn.utils::logger.error("prepare_pools could not calculate woody biomass; will use defaults. Please provide AbvGrndWood and coarse_root_carbon OR leaf_carbon_content/LAI, fine_root_carbon_content, and TotLivBiom in netcdf.") From 40378db2eafe6bd8421be4d1e8d64abed494f145 Mon Sep 17 00:00:00 2001 From: annethomas Date: Fri, 18 Aug 2017 16:47:48 -0400 Subject: [PATCH 341/771] Change prepare_pools to prepare.pools --- models/dalec/R/write.configs.dalec.R | 2 +- models/sipnet/R/write.configs.SIPNET.R | 2 +- modules/data.land/R/prepare_pools.R | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index d4a667b4438..4c7bcc2df47 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -121,7 +121,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { sla <- default.param[which(default.param$cmdFlag == "SLA"),"val"] * 1000 #convert SLA to m2/kgC from m2/gC (dalec default) } - IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = sla)) + IC.pools <- PEcAn.data.land::prepare.pools(IC.path, constants = list(sla = sla)) if(!is.null(IC.pools)){ ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) diff --git a/models/sipnet/R/write.configs.SIPNET.R b/models/sipnet/R/write.configs.SIPNET.R index 7b7a6c98228..2d6b466754e 100644 --- a/models/sipnet/R/write.configs.SIPNET.R +++ b/models/sipnet/R/write.configs.SIPNET.R @@ -361,7 +361,7 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs } else if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path - IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = SLA)) + IC.pools <- PEcAn.data.land::prepare.pools(IC.path, constants = list(sla = SLA)) if(!is.null(IC.pools)){ IC.nc <- ncdf4::nc_open(IC.path) #for additional variables specific to SIPNET diff --git a/modules/data.land/R/prepare_pools.R b/modules/data.land/R/prepare_pools.R index e09f45a18d1..da6843498ec 100644 --- a/modules/data.land/R/prepare_pools.R +++ b/modules/data.land/R/prepare_pools.R @@ -1,5 +1,5 @@ -##' @name prepare_pools -##' @title prepare_pools +##' @name prepare.pools +##' @title prepare.pools ##' @description Calculates pools from given initial condition values, deriving complements where necessary/possible if given TotLivBiomass ##' @export ##' @@ -7,7 +7,7 @@ ##' @param constants list of constants; must include SLA in m2 / kg C if providing LAI for leaf carbon ##' @return list of pool values in kg C / m2 with generic names ##' @author Anne Thomas -prepare_pools <- function(nc.path, constants = NULL){ +prepare.pools <- function(nc.path, constants = NULL){ #function to check that var was loaded (numeric) and has a valid value (not NA or negative) is.valid <- function(var){ return(all(is.numeric(var) && !is.na(var) && var >= 0)) From bd732fc1067915a1895dda008989f7625757cb2e Mon Sep 17 00:00:00 2001 From: annethomas Date: Fri, 18 Aug 2017 16:55:44 -0400 Subject: [PATCH 342/771] Change partition_roots to partition.roots and fix namespace --- modules/data.land/NAMESPACE | 2 -- modules/data.land/R/partition_roots.R | 6 +++--- modules/data.land/R/prepare_pools.R | 2 +- 3 files changed, 4 insertions(+), 6 deletions(-) diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index e50c7e04bb2..e0c513ddbb8 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -27,11 +27,9 @@ export(match_pft) export(match_species_id) export(mpot2smoist) export(parse.MatrixNames) -export(partition_roots) export(plot2AGB) export(pool_ic_list2netcdf) export(pool_ic_netcdf2list) -export(prepare_pools) export(sclass) export(shp2kml) export(soil.units) diff --git a/modules/data.land/R/partition_roots.R b/modules/data.land/R/partition_roots.R index 2d610a76544..cb0fa29ba49 100644 --- a/modules/data.land/R/partition_roots.R +++ b/modules/data.land/R/partition_roots.R @@ -1,5 +1,5 @@ -##' @name partition_roots -##' @title partition_roots +##' @name partition.roots +##' @title partition.roots ##' @description Given a vector of root size thresholds (lower bound of each) and a vector of corresponding root carbon values, partition_roots checks if the input can be partitioned along the .002 m threshold between fine and coarse roots and returns a list containing the summed values for fine and coarse. If there are fewer than two thresholds or none within .0005 m of .002 m, returns NULL. Meant to be used in conjunction with standard variable root_carbon_content with rtsize dimension, extracted from netcdf. ##' @export ##' @@ -8,7 +8,7 @@ ##' @return list containing summed fine root and coarse root carbon (2 values) ##' @author Anne Thomas ##' -partition_roots <- function(roots, rtsize){ +partition.roots <- function(roots, rtsize){ if(length(rtsize) > 1 && length(rtsize) == length(roots)){ threshold <- .002 epsilon <- .0005 diff --git a/modules/data.land/R/prepare_pools.R b/modules/data.land/R/prepare_pools.R index da6843498ec..00f41aee291 100644 --- a/modules/data.land/R/prepare_pools.R +++ b/modules/data.land/R/prepare_pools.R @@ -38,7 +38,7 @@ prepare.pools <- function(nc.path, constants = NULL){ if("rtsize" %in% names(IC.list$dims)){ PEcAn.utils::logger.info("prepare_pools: Attempting to partition root_carbon_content") rtsize <- IC.list$dims$rtsize - part_roots <- PEcAn.data.land::partition_roots(roots, rtsize) + part_roots <- PEcAn.data.land::partition.roots(roots, rtsize) if(!is.null(part_roots)){ fine.roots <- part_roots$fine.roots coarse.roots <- part_roots$coarse.roots From eb8374f4bfe4b14facd067d23d1eef3026a65e6e Mon Sep 17 00:00:00 2001 From: annethomas Date: Fri, 18 Aug 2017 17:18:22 -0400 Subject: [PATCH 343/771] Fix typo --- modules/data.land/NAMESPACE | 2 ++ modules/data.land/R/prepare_pools.R | 2 +- modules/data.land/man/partition_roots.Rd | 22 ---------------------- modules/data.land/man/prepare_pools.Rd | 22 ---------------------- 4 files changed, 3 insertions(+), 45 deletions(-) delete mode 100644 modules/data.land/man/partition_roots.Rd delete mode 100644 modules/data.land/man/prepare_pools.Rd diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index e0c513ddbb8..d41a94efeee 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -27,9 +27,11 @@ export(match_pft) export(match_species_id) export(mpot2smoist) export(parse.MatrixNames) +export(partition.roots) export(plot2AGB) export(pool_ic_list2netcdf) export(pool_ic_netcdf2list) +export(prepare.pools) export(sclass) export(shp2kml) export(soil.units) diff --git a/modules/data.land/R/prepare_pools.R b/modules/data.land/R/prepare_pools.R index 00f41aee291..1b228564dd8 100644 --- a/modules/data.land/R/prepare_pools.R +++ b/modules/data.land/R/prepare_pools.R @@ -89,7 +89,7 @@ prepare.pools <- function(nc.path, constants = NULL){ if (wood >= 0){ IC.params[["wood"]] <- wood }else if ((leaf + fine.roots) < (TotLivBiom * 1.25)){ - PEcAn.utils::logger.error(paste("prepare_pools: Sum of leaf (", leaf, ") and fine roots(", fine.roots, ") is greater than TotLivBiom (", TotLivBiom, "); will reappportion for woody biomass.")) + PEcAn.utils::logger.error(paste("prepare_pools: Sum of leaf (", leaf, ") and fine roots(", fine.roots, ") is greater than TotLivBiom (", TotLivBiom, "); will reapportion with woody biomass.")) #estimate new woody biomass and reapportion if(is.valid(coarse.roots)){ #expand wood by coarse root to stem fraction (currently applied to both woody and non-woody) diff --git a/modules/data.land/man/partition_roots.Rd b/modules/data.land/man/partition_roots.Rd deleted file mode 100644 index 40b0d9b96e2..00000000000 --- a/modules/data.land/man/partition_roots.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/partition_roots.R -\name{partition_roots} -\alias{partition_roots} -\title{partition_roots} -\usage{ -partition_roots(roots, rtsize) -} -\arguments{ -\item{roots}{vector of root carbon values in kg C m-2} - -\item{rtsize}{vector of lower bounds of root size class thresholds in m, length greater than one and equal to roots. Must contain threshold within .0005 m of .002 m} -} -\value{ -list containing summed fine root and coarse root carbon (2 values) -} -\description{ -Given a vector of root size thresholds (lower bound of each) and a vector of corresponding root carbon values, partition_roots checks if the input can be partitioned along the .002 m threshold between fine and coarse roots and returns a list containing the summed values for fine and coarse. If there are fewer than two thresholds or none within .0005 m of .002 m, returns NULL. Meant to be used in conjunction with standard variable root_carbon_content with rtsize dimension, extracted from netcdf. -} -\author{ -Anne Thomas -} diff --git a/modules/data.land/man/prepare_pools.Rd b/modules/data.land/man/prepare_pools.Rd deleted file mode 100644 index 3fbdf7c0ac1..00000000000 --- a/modules/data.land/man/prepare_pools.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prepare_pools.R -\name{prepare_pools} -\alias{prepare_pools} -\title{prepare_pools} -\usage{ -prepare_pools(nc.path, constants = NULL) -} -\arguments{ -\item{nc.path}{path to netcdf file containing standard dimensions and variables; currently supports these variables: TotLivBiom, leaf_carbon_content, LAI, AbvGrndWood, root_carbon_content, fine_root_carbon_content, coarse_root_carbon_content, litter_carbon_content, soil_organic_carbon_content, soil_carbon_content, wood_debris_carbon_content} - -\item{constants}{list of constants; must include SLA in m2 / kg C if providing LAI for leaf carbon} -} -\value{ -list of pool values in kg C / m2 with generic names -} -\description{ -Calculates pools from given initial condition values, deriving complements where necessary/possible if given TotLivBiomass -} -\author{ -Anne Thomas -} From 145431974f04b4c3c589e914bdd4384b3c93eaae Mon Sep 17 00:00:00 2001 From: annethomas Date: Fri, 18 Aug 2017 17:19:42 -0400 Subject: [PATCH 344/771] new .Rd files --- modules/data.land/man/partition.roots.Rd | 22 ++++++++++++++++++++++ modules/data.land/man/prepare.pools.Rd | 22 ++++++++++++++++++++++ 2 files changed, 44 insertions(+) create mode 100644 modules/data.land/man/partition.roots.Rd create mode 100644 modules/data.land/man/prepare.pools.Rd diff --git a/modules/data.land/man/partition.roots.Rd b/modules/data.land/man/partition.roots.Rd new file mode 100644 index 00000000000..f7c9046d1cf --- /dev/null +++ b/modules/data.land/man/partition.roots.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/partition_roots.R +\name{partition.roots} +\alias{partition.roots} +\title{partition.roots} +\usage{ +partition.roots(roots, rtsize) +} +\arguments{ +\item{roots}{vector of root carbon values in kg C m-2} + +\item{rtsize}{vector of lower bounds of root size class thresholds in m, length greater than one and equal to roots. Must contain threshold within .0005 m of .002 m} +} +\value{ +list containing summed fine root and coarse root carbon (2 values) +} +\description{ +Given a vector of root size thresholds (lower bound of each) and a vector of corresponding root carbon values, partition_roots checks if the input can be partitioned along the .002 m threshold between fine and coarse roots and returns a list containing the summed values for fine and coarse. If there are fewer than two thresholds or none within .0005 m of .002 m, returns NULL. Meant to be used in conjunction with standard variable root_carbon_content with rtsize dimension, extracted from netcdf. +} +\author{ +Anne Thomas +} diff --git a/modules/data.land/man/prepare.pools.Rd b/modules/data.land/man/prepare.pools.Rd new file mode 100644 index 00000000000..212490678b7 --- /dev/null +++ b/modules/data.land/man/prepare.pools.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prepare_pools.R +\name{prepare.pools} +\alias{prepare.pools} +\title{prepare.pools} +\usage{ +prepare.pools(nc.path, constants = NULL) +} +\arguments{ +\item{nc.path}{path to netcdf file containing standard dimensions and variables; currently supports these variables: TotLivBiom, leaf_carbon_content, LAI, AbvGrndWood, root_carbon_content, fine_root_carbon_content, coarse_root_carbon_content, litter_carbon_content, soil_organic_carbon_content, soil_carbon_content, wood_debris_carbon_content} + +\item{constants}{list of constants; must include SLA in m2 / kg C if providing LAI for leaf carbon} +} +\value{ +list of pool values in kg C / m2 with generic names +} +\description{ +Calculates pools from given initial condition values, deriving complements where necessary/possible if given TotLivBiomass +} +\author{ +Anne Thomas +} From ba57ce5ea88102ffc0d0d134068818dcb1522cfc Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Sun, 20 Aug 2017 17:44:45 -0400 Subject: [PATCH 345/771] Created import.data webpage --- web/import.data.php | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 web/import.data.php diff --git a/web/import.data.php b/web/import.data.php new file mode 100644 index 00000000000..e69de29bb2d From 020eb4713441bcc25c33765093ca7e76c949f7a2 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Sun, 20 Aug 2017 17:59:43 -0400 Subject: [PATCH 346/771] added min upload level to changelog --- CHANGELOG.md | 1 + web/import.data.php | 23 +++++++++++++++++++++++ 2 files changed, 24 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 12408d52582..6946e44f72a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,7 @@ section for the next release. For more information about this file see also [Keep a Changelog](http://keepachangelog.com/) . ## [Unreleased] +- Defined Min_upload_level=3 ## [1.5.10] - Prerelease ### Added diff --git a/web/import.data.php b/web/import.data.php index e69de29bb2d..fe85338e2ba 100644 --- a/web/import.data.php +++ b/web/import.data.php @@ -0,0 +1,23 @@ + $min_upload_level) { + header( "Location: index.php"); + close_database(); + exit; +} From 391879c90f1cb14043dee03b5d67a601985579da Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Sun, 20 Aug 2017 18:07:13 -0400 Subject: [PATCH 347/771] html skeleton --- web/import.data.php | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/web/import.data.php b/web/import.data.php index fe85338e2ba..ba1df552e1d 100644 --- a/web/import.data.php +++ b/web/import.data.php @@ -1,4 +1,18 @@ - + + + Import Data + + + +

    Import Data

    +

    Either download data from DataONE or drag and drop locally stored files

    + + + + + + \ No newline at end of file From 0edcf8bbbe6e174cc745991e7fc34e6f63505583 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Mon, 21 Aug 2017 11:14:50 -0400 Subject: [PATCH 348/771] More cleanup to satisfy make check --- Makefile | 34 +++++++++---------- base/logger/DESCRIPTION | 3 +- base/utils/NAMESPACE | 2 -- base/utils/R/logger.R | 7 ---- models/jules/R/write.config.JULES.R | 4 ++- models/jules/man/write.config.JULES.Rd | 4 ++- modules/benchmark/DESCRIPTION | 1 + .../data.atmosphere/R/merge.met.variable.R | 2 +- modules/data.atmosphere/R/split_wind.R | 4 +-- .../data.atmosphere/man/merge_met_variable.Rd | 2 +- modules/data.atmosphere/man/split_wind.Rd | 2 +- modules/data.land/R/dataone_download.R | 1 - modules/data.land/R/extract_soil_nc.R | 2 +- modules/data.land/man/dataone_download.Rd | 3 -- modules/data.land/man/extract_soil_nc.Rd | 2 +- modules/data.remote/R/call_MODIS.R | 2 +- modules/data.remote/man/call_MODIS.Rd | 2 +- 17 files changed, 35 insertions(+), 42 deletions(-) diff --git a/Makefile b/Makefile index ca7c4991855..a1496e8eeb0 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ NCPUS ?= 1 -BASE := utils db settings visualization +BASE := logger utils db settings visualization MODELS := biocro clm45 dalec ed fates gday jules linkages \ lpjguess maat maespa preles sipnet @@ -45,25 +45,25 @@ check: .check/base/all test: .test/base/all ### Dependencies -.doc/all: $(ALL_PKGS_D) -.install/all: $(ALL_PKGS_I) -.check/all: $(ALL_PKGS_C) -.test/all: $(ALL_PKGS_T) +.doc/base/all: $(ALL_PKGS_D) +.install/base/all: $(ALL_PKGS_I) +.check/base/all: $(ALL_PKGS_C) +.test/base/all: $(ALL_PKGS_T) depends = .check/$(1) .test/$(1) -$(call depends,base/db): .install/utils -$(call depends,base/settings): .install/utils .install/db -$(call depends,base/visualization): .install/db -$(call depends,modules/data.atmosphere): .install/utils -$(call depends,modules/data.land): .install/db .install/utils -$(call depends,modules/meta.analysis): .install/utils .install/db -$(call depends,modules/priors): .install/utils -$(call depends,modules/assim.batch): .install/utils .install/db .install/modules/meta.analysis -$(call depends,modules/rtm): .install/modules/assim.batch -$(call depends,modules/uncertainty): .install/utils .install/modules/priors -$(call depends,models/template): .install/utils -$(call depends,models/biocro): .install/utils .install/settings .install/db .install/modules/data.atmosphere .install/modules/data.land +$(call depends,base/db): .install/base/logger .install/base/utils +$(call depends,base/settings): .install/base/logger .install/base/utils .install/base/db +$(call depends,base/visualization): .install/base/logger .install/base/db +$(call depends,modules/data.atmosphere): .install/base/logger .install/base/utils +$(call depends,modules/data.land): .install/base/logger .install/base/db .install/base/utils +$(call depends,modules/meta.analysis): .install/base/logger .install/base/utils .install/base/db +$(call depends,modules/priors): .install/base/logger .install/base/utils +$(call depends,modules/assim.batch): .install/base/logger .install/base/utils .install/base/db .install/modules/meta.analysis +$(call depends,modules/rtm): .install/base/logger .install/modules/assim.batch +$(call depends,modules/uncertainty): .install/base/logger .install/base/utils .install/modules/priors +$(call depends,models/template): .install/base/logger .install/base/utils +$(call depends,models/biocro): .install/base/logger .install/base/utils .install/base/settings .install/base/db .install/modules/data.atmosphere .install/modules/data.land $(MODELS_I): .install/models/template diff --git a/base/logger/DESCRIPTION b/base/logger/DESCRIPTION index e942d4e44d1..ba6d884daec 100644 --- a/base/logger/DESCRIPTION +++ b/base/logger/DESCRIPTION @@ -1,7 +1,8 @@ Package: PEcAn.logger Title: Logger functions for PEcAn Version: 0.0.0.9000 -Authors: Rob Kooper, Alexey Shiklomanov +Author: Rob Kooper, Alexey Shiklomanov +Maintainer: Alexey Shiklomanov Description: Special logger functions for tracking execution status and the environment. Depends: R (>= 3.4.1) License: FreeBSD + file LICENSE diff --git a/base/utils/NAMESPACE b/base/utils/NAMESPACE index 3636c8756f3..0a9ea2e36b0 100644 --- a/base/utils/NAMESPACE +++ b/base/utils/NAMESPACE @@ -41,7 +41,6 @@ export(load.modelpkg) export(logger.debug) export(logger.error) export(logger.getLevel) -export(logger.getLevelNumber) export(logger.info) export(logger.setLevel) export(logger.setOutputFile) @@ -96,7 +95,6 @@ import(randtoolbox) importFrom(PEcAn.logger,logger.debug) importFrom(PEcAn.logger,logger.error) importFrom(PEcAn.logger,logger.getLevel) -importFrom(PEcAn.logger,logger.getLevelNumber) importFrom(PEcAn.logger,logger.info) importFrom(PEcAn.logger,logger.setLevel) importFrom(PEcAn.logger,logger.setOutputFile) diff --git a/base/utils/R/logger.R b/base/utils/R/logger.R index 3247db03003..b4da35028b7 100644 --- a/base/utils/R/logger.R +++ b/base/utils/R/logger.R @@ -47,13 +47,6 @@ logger.setLevel <- function(...) { PEcAn.logger::logger.setLevel(...) } -#' @importFrom PEcAn.logger logger.getLevelNumber -#' @export -logger.getLevelNumber <- function(...) { - logger_deprecated() - PEcAn.logger::logger.getLevelNumber(...) -} - #' @importFrom PEcAn.logger logger.getLevel #' @export logger.getLevel <- function(...) { diff --git a/models/jules/R/write.config.JULES.R b/models/jules/R/write.config.JULES.R index 7d2a42e0ca3..e6520d53077 100644 --- a/models/jules/R/write.config.JULES.R +++ b/models/jules/R/write.config.JULES.R @@ -24,7 +24,9 @@ ##' ##' @export ##' @examples -##' write.config.JULES(defaults, trait.values, settings, run.id) +##' \dontrun{ +##' write.config.JULES(defaults, trait.values, settings, run.id) +##' } ##-------------------------------------------------------------------------------------------------# write.config.JULES <- function(defaults, trait.values, settings, run.id) { # constants diff --git a/models/jules/man/write.config.JULES.Rd b/models/jules/man/write.config.JULES.Rd index 6e3c9f8deec..57668954e59 100644 --- a/models/jules/man/write.config.JULES.Rd +++ b/models/jules/man/write.config.JULES.Rd @@ -26,7 +26,9 @@ Requires a pft xml object, a list of trait values for a single model run, and the name of the file to create } \examples{ -write.config.JULES(defaults, trait.values, settings, run.id) +\dontrun{ + write.config.JULES(defaults, trait.values, settings, run.id) +} } \author{ Mike Dietze, Rob Kooper diff --git a/modules/benchmark/DESCRIPTION b/modules/benchmark/DESCRIPTION index 2fb3fdbe588..b3503fc2738 100644 --- a/modules/benchmark/DESCRIPTION +++ b/modules/benchmark/DESCRIPTION @@ -17,6 +17,7 @@ Imports: udunits2 (>= 0.11), XML (>= 3.98-1.4), dplyr, + ggplot2, dbplyr Suggests: testthat (>= 1.0.2) diff --git a/modules/data.atmosphere/R/merge.met.variable.R b/modules/data.atmosphere/R/merge.met.variable.R index 0fe41833cb8..abcd05c821d 100644 --- a/modules/data.atmosphere/R/merge.met.variable.R +++ b/modules/data.atmosphere/R/merge.met.variable.R @@ -18,6 +18,7 @@ #' New variable only has time dimension and thus MIGHT break downstream code.... #' #' @examples +#' \dontrun{ #' in.path <- "~/paleon/PalEONregional_CF_site_1-24047/" #' in.prefix <- "" #' outfolder <- "~/paleon/metTest/" @@ -27,7 +28,6 @@ #' overwrite <- FALSE #' verbose <- TRUE #' -#' \dontrun{ #' merge_met_variable(in.path,in.prefix,start_date,end_date,merge.file,overwrite,verbose) #' PEcAn.DALEC::met2model.DALEC(in.path,in.prefix,outfolder,start_date,end_date) #' } diff --git a/modules/data.atmosphere/R/split_wind.R b/modules/data.atmosphere/R/split_wind.R index 2f4f1d102c9..b6cca061f83 100644 --- a/modules/data.atmosphere/R/split_wind.R +++ b/modules/data.atmosphere/R/split_wind.R @@ -14,6 +14,7 @@ #' @details Currently modifies the files IN PLACE rather than creating a new copy of the files an a new DB record. #' #' @examples +#' \dontrun{ #' in.path <- "~/paleon/PalEONregional_CF_site_1-24047/" #' in.prefix <- "" #' outfolder <- "~/paleon/metTest/" @@ -22,7 +23,6 @@ #' overwrite <- FALSE #' verbose <- TRUE #' -#' \notrun{ #' split_wind(in.path, in.prefix, start_date, end_date, merge.file, overwrite, verbose) #' } split_wind <- function(in.path, in.prefix, start_date, end_date, @@ -98,4 +98,4 @@ split_wind <- function(in.path, in.prefix, start_date, end_date, } ## end loop over year -} \ No newline at end of file +} diff --git a/modules/data.atmosphere/man/merge_met_variable.Rd b/modules/data.atmosphere/man/merge_met_variable.Rd index 3fffd9775a3..cd885bc341b 100644 --- a/modules/data.atmosphere/man/merge_met_variable.Rd +++ b/modules/data.atmosphere/man/merge_met_variable.Rd @@ -34,6 +34,7 @@ Currently does not yet support merge data that has lat/lon New variable only has time dimension and thus MIGHT break downstream code.... } \examples{ +\dontrun{ in.path <- "~/paleon/PalEONregional_CF_site_1-24047/" in.prefix <- "" outfolder <- "~/paleon/metTest/" @@ -43,7 +44,6 @@ end_date <- "2010-12-31" overwrite <- FALSE verbose <- TRUE -\dontrun{ merge_met_variable(in.path,in.prefix,start_date,end_date,merge.file,overwrite,verbose) PEcAn.DALEC::met2model.DALEC(in.path,in.prefix,outfolder,start_date,end_date) } diff --git a/modules/data.atmosphere/man/split_wind.Rd b/modules/data.atmosphere/man/split_wind.Rd index 0f043a5be7c..f48dcc93cb4 100644 --- a/modules/data.atmosphere/man/split_wind.Rd +++ b/modules/data.atmosphere/man/split_wind.Rd @@ -29,6 +29,7 @@ Split wind_speed into eastward_wind and northward_wind Currently modifies the files IN PLACE rather than creating a new copy of the files an a new DB record. } \examples{ +\dontrun{ in.path <- "~/paleon/PalEONregional_CF_site_1-24047/" in.prefix <- "" outfolder <- "~/paleon/metTest/" @@ -37,7 +38,6 @@ end_date <- "2010-12-31" overwrite <- FALSE verbose <- TRUE -\\notrun{ split_wind(in.path, in.prefix, start_date, end_date, merge.file, overwrite, verbose) } } diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index a80dd9e9c59..c054066e6a8 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -11,7 +11,6 @@ #' #' @export #' -#' @examples doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", username = "Guest") dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNode = "PROD", lazyLoad = FALSE, quiet = F){ ### automatically retrieve mnId diff --git a/modules/data.land/R/extract_soil_nc.R b/modules/data.land/R/extract_soil_nc.R index f215f36a5ce..9de6e8ff004 100644 --- a/modules/data.land/R/extract_soil_nc.R +++ b/modules/data.land/R/extract_soil_nc.R @@ -13,7 +13,7 @@ #' outdir <- "~/paleon/envTest" #' lat <- 40 #' lon <- -80 -#' \donotrun{ +#' \dontrun{ #' PEcAn.data.land::extract_soil_nc(in.file,outdir,lat,lon) #' } extract_soil_nc <- function(in.file,outdir,lat,lon){ diff --git a/modules/data.land/man/dataone_download.Rd b/modules/data.land/man/dataone_download.Rd index f7e93350d4d..35d68f3b021 100644 --- a/modules/data.land/man/dataone_download.Rd +++ b/modules/data.land/man/dataone_download.Rd @@ -21,9 +21,6 @@ dataone_download(id, filepath = "/fs/data1/pecan.data/dbfiles/", \description{ Adapts the dataone::getDataPackage workflow to allow users to download data from the DataONE federation by simply entering the doi or associated package id } -\examples{ -doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", username = "Guest") -} \author{ Liam P Burke, \email{lpburke@bu.edu} } diff --git a/modules/data.land/man/extract_soil_nc.Rd b/modules/data.land/man/extract_soil_nc.Rd index 0758758b527..f3ab4ff5752 100644 --- a/modules/data.land/man/extract_soil_nc.Rd +++ b/modules/data.land/man/extract_soil_nc.Rd @@ -23,7 +23,7 @@ in.file <- "~/paleon/env_paleon/soil/paleon_soil.nc" outdir <- "~/paleon/envTest" lat <- 40 lon <- -80 -\\donotrun{ +\dontrun{ PEcAn.data.land::extract_soil_nc(in.file,outdir,lat,lon) } } diff --git a/modules/data.remote/R/call_MODIS.R b/modules/data.remote/R/call_MODIS.R index 41a2302ce13..796512640ca 100644 --- a/modules/data.remote/R/call_MODIS.R +++ b/modules/data.remote/R/call_MODIS.R @@ -11,7 +11,7 @@ ##' depends on a number of Python libraries. sudo -H pip install numpy suds netCDF4 ##' ##' @examples -##' \donotrun{ +##' \dontrun{ ##' test <- call_MODIS(start="2001001",end="2016366",lat=44.0646,lon=-71.28808,size=3,qc_band = "FparLai_QC",sd_band = "LaiStdDev_1km") ##' } ##' diff --git a/modules/data.remote/man/call_MODIS.Rd b/modules/data.remote/man/call_MODIS.Rd index a0eb6b734ca..cc736c40cd6 100644 --- a/modules/data.remote/man/call_MODIS.Rd +++ b/modules/data.remote/man/call_MODIS.Rd @@ -23,7 +23,7 @@ depends on a number of Python libraries. sudo -H pip install numpy suds netCDF4} Get MODIS data by date and location } \examples{ -\\donotrun{ +\dontrun{ test <- call_MODIS(start="2001001",end="2016366",lat=44.0646,lon=-71.28808,size=3,qc_band = "FparLai_QC",sd_band = "LaiStdDev_1km") } From 68e8f05eec4c44d94905b7fd6394c62838da60b1 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Mon, 21 Aug 2017 11:26:31 -0400 Subject: [PATCH 349/771] Revert write.configs.dalec changes Not sure how those got in there. --- models/dalec/R/write.configs.dalec.R | 151 ++++++--------------------- 1 file changed, 31 insertions(+), 120 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 83409ebdd3f..05e44598a26 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -15,7 +15,7 @@ PREFIX_XML <- "\n" convert.samples.DALEC <- function(trait.samples) { DEFAULT.LEAF.C <- 0.48 - ## convert SLA from m2 / kg leaf to m2 / g C + ## convert SLA from PEcAn m2 / kg leaf to m2 / g C if ("SLA" %in% names(trait.samples)) { trait.samples[["SLA"]] <- trait.samples[["SLA"]]/DEFAULT.LEAF.C/1000 @@ -108,142 +108,53 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } ### INITIAL CONDITIONS - - #function to check that ncvar was loaded (numeric) and has a valid value (not NA or negative) - is.valid <- function(var){ - return(all(is.numeric(var) && !is.na(var) && var >= 0)) - } - - default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC"), header = TRUE) IC.params <- list() - if (!is.null(settings$run$inputs$poolinitcond$path)) { + if(!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path - IC.nc <- try(ncdf4::nc_open(IC.path)) - if(class(IC.nc) != "try-error"){ - #check/load biomass netcdf variables - TotLivBiom <- try(ncdf4::ncvar_get(IC.nc,"TotLivBiom"),silent = TRUE) - leaf <- try(ncdf4::ncvar_get(IC.nc,"leaf_carbon_content"),silent = TRUE) - LAI <- try(ncdf4::ncvar_get(IC.nc,"LAI"),silent = TRUE) - AbvGrndWood <- try(ncdf4::ncvar_get(IC.nc,"AbvGrndWood"),silent = TRUE) - roots <- try(ncdf4::ncvar_get(IC.nc,"root_carbon_content"),silent = TRUE) - fine.roots <- try(ncdf4::ncvar_get(IC.nc,"fine_root_carbon_content"),silent = TRUE) - coarse.roots <- try(ncdf4::ncvar_get(IC.nc,"coarse_root_carbon_content"),silent = TRUE) - - if(!all(sapply(c(TotLivBiom,leaf,LAI,AbvGrndWood,roots,fine.roots,coarse.roots),is.numeric))){ - PEcAn.logger::logger.info("DALEC IC: Any missing vars will be calculated from those provided or replaced by DALEC's defaults") - } - - #check if total roots are partitionable - #note: if roots are patritionable, they will override fine_ and/or coarse_root_carbon_content if loaded - if(is.valid(roots)){ - if("rtsize" %in% names(IC.nc$dim)){ - PEcAn.logger::logger.info("DALEC IC: Attempting to partition root_carbon_content") - rtsize <- IC.nc$dim$rtsize$vals - part_roots <- PEcAn.data.land::partition_roots(roots, rtsize) - if(!is.null(part_roots)){ - fine.roots <- part_roots$fine.roots - coarse.roots <- part_roots$coarse.roots - } else{ - PEcAn.logger::logger.error("DALEC IC: could not partition roots; please provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") - } - } else{ - PEcAn.logger::logger.error("DALEC IC: Please provide rtsize dimension with root_carbon_content to allow partitioning or provide fine_root_carbon_content and coarse_root_carbon_content in netcdf.") - } - } else{ - #proceed without error message - } - - - ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) + sla <- NULL + if("SLA" %in% names(params)){ + sla <- params[1,"SLA"] * 1000 #convert SLA to m2/kgC from m2/gC (convert.samples) + } else{ + default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC"), header = TRUE) + sla <- default.param[which(default.param$cmdFlag == "SLA"),"val"] * 1000 #convert SLA to m2/kgC from m2/gC (dalec default) + } + + IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = sla)) + + if(!is.null(IC.pools)){ + ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) # cf0 initial canopy foliar carbon (g/m2) - if (is.valid(leaf)) { - IC.params[["cf0"]] <- leaf * 1000 #from standard kg C m-2 - } else if(is.valid(LAI)){ - if("SLA" %in% names(params)){ - SLA <- 1/params[1,"SLA"] #SLA converted to m2/gC in convert.samples - leaf <- LAI * SLA - IC.params[["cf0"]] <- leaf - } else{ - SLA <- default.param[which(default.param$cmdFlag == "SLA"),"val"] - leaf <- LAI * 1/SLA #check that leaf isn't higher than total biomass if given? - IC.params[["cf0"]] <- leaf - } - } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && - is.valid(fine.roots) && is.valid(coarse.roots)){ - leaf <- (TotLivBiom - AbvGrndWood - fine.roots - coarse.roots) * 1000 #from standard kg C m-2 - if(leaf >= 0){ - IC.params[["cf0"]] <- leaf - } else{ - PEcAn.logger::logger.error("TotLivBiom is less than sum of AbvGrndWood and roots; using default for leaf biomass") - } - } + if ("leaf" %in% names(IC.pools)) { + IC.params[["cf0"]] <- IC.pools$leaf * 1000 #from PEcAn standard kg C m-2 + } # cw0 initial pool of woody carbon (g/m2) - if (is.valid(AbvGrndWood)) { - if(is.valid(coarse.roots)){ - IC.params[["cw0"]] <- (AbvGrndWood + coarse.roots) * 1000 #from standard kg C m-2 - } else{ - PEcAn.logger::logger.error("write.configs.DALEC IC can't calculate total woody biomass with only AbvGrndWood; checking for total biomass.") - } - } else if (is.valid(TotLivBiom) && is.valid(leaf) && is.valid(fine.roots)){ - if(is.valid(LAI)){ - wood <- (1000*(TotLivBiom - fine.roots)) - leaf #convert TotLivBiom and fine.roots to g C m-2 from standard kg C m-2; leaf already converted via SLA - } - else{ - wood <- (TotLivBiom - leaf - fine.roots) * 1000 #from standard kg C m-2 - } - if (wood >= 0){ - IC.params[["cw0"]] <- wood - }else{ - PEcAn.logger::logger.error(paste("TotLivBiom (", TotLivBiom, ") is less than sum of leaf (", leaf, ") and fine roots(",fine.roots,"); using default for woody biomass.")) - } - } else{ - PEcAn.logger::logger.error("write.configs.DALEC IC could not calculate woody biomass; using defaults. Please provide AbvGrndWood and coarse_root_carbon OR leaf_carbon_content/LAI, fine_root_carbon_content, and TotLivBiom in netcdf.") - } + if ("wood" %in% names(IC.pools)) { + IC.params[["cw0"]] <- IC.pools$wood * 1000 #from PEcAn standard kg C m-2 + } # cr0 initial pool of fine root carbon (g/m2) - if (is.valid(fine.roots)) { - IC.params[["cr0"]] <- fine.roots * 1000 #from standard kg C m-2 - } else if(is.valid(TotLivBiom) && is.valid(AbvGrndWood) && - is.valid(leaf) && is.valid(coarse.roots)){ - if(is.valid(LAI)){ - fine.roots <- ((TotLivBiom - AbvGrndWood - coarse.roots) * 1000) - leaf #from standard kg C m-2; leaf already converted - }else{ - fine.roots <- (TotLivBiom - AbvGrndWood - leaf - coarse.roots) * 1000 #from standard kg C m-2 - } - if(fine.roots >= 0){ - IC.params[["cr0"]] <- fine.roots - } else{ - PEcAn.logger::logger.error("TotLivBiom is less than sum of AbvGrndWood, coarse roots, and leaf; using default for fine.roots biomass") - } - } + if ("fine.roots" %in% names(IC.pools)) { + IC.params[["cr0"]] <- IC.pools$fine.roots * 1000 #from PEcAn standard kg C m-2 + } ###non-living variables # cl0 initial pool of litter carbon (g/m2) - litter <- try(ncdf4::ncvar_get(IC.nc,"litter_carbon_content"),silent = TRUE) - if (is.valid(litter)) { - IC.params[["cl0"]] <- litter * 1000 #from standard kg C m-2 + if ("litter" %in% names(IC.pools)) { + IC.params[["cl0"]] <- IC.pools$litter * 1000 #from PEcAn standard kg C m-2 } # cs0 initial pool of soil organic matter and woody debris carbon (g/m2) - soil <- try(ncdf4::ncvar_get(IC.nc,"soil_organic_carbon_content"),silent = TRUE) - wood.debris <- try(ncdf4::ncvar_get(IC.nc,"wood_debris_carbon_content"),silent = TRUE) - - if(is.valid(soil) && is.valid(wood.debris)){ - IC.params[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #from standard kg C m-2 - } else if(!is.valid(soil) && is.valid(wood.debris)){ - soil <- try(ncdf4::ncvar_get(IC.nc,"soil_carbon_content"),silent = TRUE) - if(is.valid(soil)){ - IC.params[["cs0"]] <- (soil + sum(wood.debris)) * 1000 #from standard kg C m-2 - } else{ - PEcAn.logger::logger.error("write.configs.DALEC IC can't calculate soil matter pool without soil carbon; using default. Please provide soil_organic_carbon_content in netcdf.") + if("soil" %in% names(IC.pools)){ + if("wood.debris" %in% names(IC.pools)){ + IC.params[["cs0"]] <- (IC.pools$soil + sum(IC.pools$wood.debris)) * 1000 #from PEcAn standard kg C m-2 + } else { + IC.params[["cs0"]] <- IC.pools$soil * 1000 #from PEcAn standard kg C m-2 + PEcAn.logger::logger.warn("write.configs.DALEC IC: Loading soil carbon pool without woody debris.") } - } else if(is.valid(soil) && !is.valid(wood.debris)){ - IC.params[["cs0"]] <- soil * 1000 #from standard kg C m-2 - PEcAn.logger::logger.warn("write.configs.DALEC IC: Loading soil carbon pool without woody debris.") } ###Write to command line file From 26c87a583472dad8e948d0e320d37131c2d8146f Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Mon, 21 Aug 2017 11:28:25 -0400 Subject: [PATCH 350/771] Revert changes to write.configs.sipnet --- models/sipnet/R/write.configs.SIPNET.R | 38 ++++++++++---------------- 1 file changed, 14 insertions(+), 24 deletions(-) diff --git a/models/sipnet/R/write.configs.SIPNET.R b/models/sipnet/R/write.configs.SIPNET.R index 8e607acd963..4ad40cd7493 100644 --- a/models/sipnet/R/write.configs.SIPNET.R +++ b/models/sipnet/R/write.configs.SIPNET.R @@ -361,18 +361,13 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs } else if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path - IC.nc <- try(ncdf4::nc_open(IC.path)) - if(class(IC.nc) != "try-error"){ - ## plantWoodInit gC/m2 - AbvGrndWood <- try(ncdf4::ncvar_get(IC.nc,"AbvGrndWood"),silent = TRUE) - if (!is.na(AbvGrndWood) && is.numeric(AbvGrndWood)) { - fineRootFrac <- param[which(param[, 1] == "fineRootFrac"), 2] - coarseRootFrac <- param[which(param[, 1] == "coarseRootFrac"), 2] - plantWood <- AbvGrndWood/(1-(fineRootFrac+coarseRootFrac)) #inflate plantWood to include belowground - param[which(param[, 1] == "plantWoodInit"), 2] <- plantWood * 1000 #PEcAn standard AbvGrndWood kgC/m2 - } - else{ - #try back-calculate from LAI,sla, and total biomass? where is total biomass? + IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = SLA)) + + if(!is.null(IC.pools)){ + IC.nc <- ncdf4::nc_open(IC.path) #for additional variables specific to SIPNET + ## plantWoodInit gC/m2 + if ("wood" %in% names(IC.pools)) { + param[which(param[, 1] == "plantWoodInit"), 2] <- IC.pools$wood * 1000 #from PEcAn standard AbvGrndWood kgC/m2 } ## laiInit m2/m2 lai <- try(ncdf4::ncvar_get(IC.nc,"LAI"),silent = TRUE) @@ -380,14 +375,12 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs param[which(param[, 1] == "laiInit"), 2] <- lai } ## litterInit gC/m2 - litter <- try(ncdf4::ncvar_get(IC.nc,"litter_carbon_content"),silent = TRUE) - if (!is.na(litter) && is.numeric(litter)) { - param[which(param[, 1] == "litterInit"), 2] <- litter * 1000 #PEcAn standard litter_carbon_content kg/m2 + if ("litter" %in% names(IC.pools)) { + param[which(param[, 1] == "litterInit"), 2] <- IC.pools$litter * 1000 #from PEcAn standard litter_carbon_content kg/m2 } ## soilInit gC/m2 - soil <- try(ncdf4::ncvar_get(IC.nc,"soil_carbon_content"),silent = TRUE) - if (!is.na(soil) && is.numeric(soil)) { - param[which(param[, 1] == "soilInit"), 2] <- sum(soil) * 1000 #PEcAn standard TotSoilCarb kg C/m2 + if ("soil" %in% names(IC.pools)) { + param[which(param[, 1] == "soilInit"), 2] <- sum(IC.pools$soil) * 1000 #from PEcAn standard TotSoilCarb kg C/m2 } ## soilWFracInit fraction soilWFrac <- try(ncdf4::ncvar_get(IC.nc,"SoilMoistFrac"),silent = TRUE) @@ -400,19 +393,16 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs ## snowInit cm water equivalent snow = try(ncdf4::ncvar_get(IC.nc,"SWE"),silent = TRUE) if (!is.na(snow) && is.numeric(snow)) { - param[which(param[, 1] == "snowInit"), 2] <- snow*0.1 #PEcAn standard SWE kg/m2 (1kg = 1mm) + param[which(param[, 1] == "snowInit"), 2] <- snow*0.1 #from PEcAn standard SWE kg/m2 (1kg = 1mm) } ## microbeInit mgC/g soil microbe <- try(ncdf4::ncvar_get(IC.nc,"Microbial Biomass C"),silent = TRUE) if (!is.na(microbe) && is.numeric(microbe)) { param[which(param[, 1] == "microbeInit"), 2] <- microbe * .001 #BETY Microbial Biomass C mg C kg-1 soil } - - #close file ncdf4::nc_close(IC.nc) - } - else{ - PEcAn.logger::logger.error("Bad initial conditions filepath; kept defaults") + }else{ + PEcAn.logger::logger.error("Bad initial conditions filepath; keeping defaults") } }else{ #some stuff about IC file that we can give in lieu of actual ICs From 6a3c4b33462d05fa7e033db882671153d62ef7be Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 21 Aug 2017 11:52:25 -0400 Subject: [PATCH 351/771] Change functions back to _ --- models/dalec/R/write.configs.dalec.R | 2 +- models/sipnet/R/write.configs.SIPNET.R | 2 +- modules/data.land/NAMESPACE | 2 -- modules/data.land/R/partition_roots.R | 2 +- modules/data.land/R/prepare_pools.R | 4 ++-- 5 files changed, 5 insertions(+), 7 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 4c7bcc2df47..d4a667b4438 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -121,7 +121,7 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { sla <- default.param[which(default.param$cmdFlag == "SLA"),"val"] * 1000 #convert SLA to m2/kgC from m2/gC (dalec default) } - IC.pools <- PEcAn.data.land::prepare.pools(IC.path, constants = list(sla = sla)) + IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = sla)) if(!is.null(IC.pools)){ ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) diff --git a/models/sipnet/R/write.configs.SIPNET.R b/models/sipnet/R/write.configs.SIPNET.R index 2d6b466754e..7b7a6c98228 100644 --- a/models/sipnet/R/write.configs.SIPNET.R +++ b/models/sipnet/R/write.configs.SIPNET.R @@ -361,7 +361,7 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs } else if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path - IC.pools <- PEcAn.data.land::prepare.pools(IC.path, constants = list(sla = SLA)) + IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = SLA)) if(!is.null(IC.pools)){ IC.nc <- ncdf4::nc_open(IC.path) #for additional variables specific to SIPNET diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index d41a94efeee..e0c513ddbb8 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -27,11 +27,9 @@ export(match_pft) export(match_species_id) export(mpot2smoist) export(parse.MatrixNames) -export(partition.roots) export(plot2AGB) export(pool_ic_list2netcdf) export(pool_ic_netcdf2list) -export(prepare.pools) export(sclass) export(shp2kml) export(soil.units) diff --git a/modules/data.land/R/partition_roots.R b/modules/data.land/R/partition_roots.R index cb0fa29ba49..c7a140d5ca3 100644 --- a/modules/data.land/R/partition_roots.R +++ b/modules/data.land/R/partition_roots.R @@ -8,7 +8,7 @@ ##' @return list containing summed fine root and coarse root carbon (2 values) ##' @author Anne Thomas ##' -partition.roots <- function(roots, rtsize){ +partition_roots <- function(roots, rtsize){ if(length(rtsize) > 1 && length(rtsize) == length(roots)){ threshold <- .002 epsilon <- .0005 diff --git a/modules/data.land/R/prepare_pools.R b/modules/data.land/R/prepare_pools.R index 1b228564dd8..75f79b9497f 100644 --- a/modules/data.land/R/prepare_pools.R +++ b/modules/data.land/R/prepare_pools.R @@ -7,7 +7,7 @@ ##' @param constants list of constants; must include SLA in m2 / kg C if providing LAI for leaf carbon ##' @return list of pool values in kg C / m2 with generic names ##' @author Anne Thomas -prepare.pools <- function(nc.path, constants = NULL){ +prepare_pools <- function(nc.path, constants = NULL){ #function to check that var was loaded (numeric) and has a valid value (not NA or negative) is.valid <- function(var){ return(all(is.numeric(var) && !is.na(var) && var >= 0)) @@ -38,7 +38,7 @@ prepare.pools <- function(nc.path, constants = NULL){ if("rtsize" %in% names(IC.list$dims)){ PEcAn.utils::logger.info("prepare_pools: Attempting to partition root_carbon_content") rtsize <- IC.list$dims$rtsize - part_roots <- PEcAn.data.land::partition.roots(roots, rtsize) + part_roots <- PEcAn.data.land::partition_roots(roots, rtsize) if(!is.null(part_roots)){ fine.roots <- part_roots$fine.roots coarse.roots <- part_roots$coarse.roots From e4a9edc04328cb8839cb26160f60cffb9b33ec69 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 21 Aug 2017 12:03:22 -0400 Subject: [PATCH 352/771] Still fixing function names --- modules/data.land/NAMESPACE | 2 ++ modules/data.land/R/partition_roots.R | 4 ++-- modules/data.land/R/prepare_pools.R | 4 ++-- modules/data.land/man/partition.roots.Rd | 22 ---------------------- modules/data.land/man/prepare.pools.Rd | 22 ---------------------- 5 files changed, 6 insertions(+), 48 deletions(-) delete mode 100644 modules/data.land/man/partition.roots.Rd delete mode 100644 modules/data.land/man/prepare.pools.Rd diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index e0c513ddbb8..e50c7e04bb2 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -27,9 +27,11 @@ export(match_pft) export(match_species_id) export(mpot2smoist) export(parse.MatrixNames) +export(partition_roots) export(plot2AGB) export(pool_ic_list2netcdf) export(pool_ic_netcdf2list) +export(prepare_pools) export(sclass) export(shp2kml) export(soil.units) diff --git a/modules/data.land/R/partition_roots.R b/modules/data.land/R/partition_roots.R index c7a140d5ca3..2d610a76544 100644 --- a/modules/data.land/R/partition_roots.R +++ b/modules/data.land/R/partition_roots.R @@ -1,5 +1,5 @@ -##' @name partition.roots -##' @title partition.roots +##' @name partition_roots +##' @title partition_roots ##' @description Given a vector of root size thresholds (lower bound of each) and a vector of corresponding root carbon values, partition_roots checks if the input can be partitioned along the .002 m threshold between fine and coarse roots and returns a list containing the summed values for fine and coarse. If there are fewer than two thresholds or none within .0005 m of .002 m, returns NULL. Meant to be used in conjunction with standard variable root_carbon_content with rtsize dimension, extracted from netcdf. ##' @export ##' diff --git a/modules/data.land/R/prepare_pools.R b/modules/data.land/R/prepare_pools.R index 75f79b9497f..8444b82d48e 100644 --- a/modules/data.land/R/prepare_pools.R +++ b/modules/data.land/R/prepare_pools.R @@ -1,5 +1,5 @@ -##' @name prepare.pools -##' @title prepare.pools +##' @name prepare_pools +##' @title prepare_pools ##' @description Calculates pools from given initial condition values, deriving complements where necessary/possible if given TotLivBiomass ##' @export ##' diff --git a/modules/data.land/man/partition.roots.Rd b/modules/data.land/man/partition.roots.Rd deleted file mode 100644 index f7c9046d1cf..00000000000 --- a/modules/data.land/man/partition.roots.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/partition_roots.R -\name{partition.roots} -\alias{partition.roots} -\title{partition.roots} -\usage{ -partition.roots(roots, rtsize) -} -\arguments{ -\item{roots}{vector of root carbon values in kg C m-2} - -\item{rtsize}{vector of lower bounds of root size class thresholds in m, length greater than one and equal to roots. Must contain threshold within .0005 m of .002 m} -} -\value{ -list containing summed fine root and coarse root carbon (2 values) -} -\description{ -Given a vector of root size thresholds (lower bound of each) and a vector of corresponding root carbon values, partition_roots checks if the input can be partitioned along the .002 m threshold between fine and coarse roots and returns a list containing the summed values for fine and coarse. If there are fewer than two thresholds or none within .0005 m of .002 m, returns NULL. Meant to be used in conjunction with standard variable root_carbon_content with rtsize dimension, extracted from netcdf. -} -\author{ -Anne Thomas -} diff --git a/modules/data.land/man/prepare.pools.Rd b/modules/data.land/man/prepare.pools.Rd deleted file mode 100644 index 212490678b7..00000000000 --- a/modules/data.land/man/prepare.pools.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prepare_pools.R -\name{prepare.pools} -\alias{prepare.pools} -\title{prepare.pools} -\usage{ -prepare.pools(nc.path, constants = NULL) -} -\arguments{ -\item{nc.path}{path to netcdf file containing standard dimensions and variables; currently supports these variables: TotLivBiom, leaf_carbon_content, LAI, AbvGrndWood, root_carbon_content, fine_root_carbon_content, coarse_root_carbon_content, litter_carbon_content, soil_organic_carbon_content, soil_carbon_content, wood_debris_carbon_content} - -\item{constants}{list of constants; must include SLA in m2 / kg C if providing LAI for leaf carbon} -} -\value{ -list of pool values in kg C / m2 with generic names -} -\description{ -Calculates pools from given initial condition values, deriving complements where necessary/possible if given TotLivBiomass -} -\author{ -Anne Thomas -} From b3b7f161e67ec792291411e759a45e7a559ed389 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Mon, 21 Aug 2017 12:04:46 -0400 Subject: [PATCH 353/771] Add PEcAn.utils:: prefix to listToXml --- base/settings/R/clean.settings.R | 2 +- base/settings/R/write.settings.R | 2 +- base/settings/tests/testthat/test.MultiSettings.class.R | 2 +- base/utils/R/do_conversions.R | 2 +- models/biocro/R/write.configs.BIOCRO.R | 8 ++++---- models/maat/R/met2model.MAAT.R | 2 +- models/maat/inst/simple_workflow.R | 2 +- modules/assim.batch/R/pda.mcmc.R | 2 +- modules/assim.batch/R/pda.mcmc.bs.R | 2 +- modules/assim.batch/R/pda.postprocess.R | 2 +- scripts/workflow.bm.R | 6 +++--- scripts/workflow.pda.R | 8 ++++---- tests/interactive-workflow.R | 4 ++-- 13 files changed, 22 insertions(+), 22 deletions(-) diff --git a/base/settings/R/clean.settings.R b/base/settings/R/clean.settings.R index fba28a4b7bf..f1d555d7e72 100644 --- a/base/settings/R/clean.settings.R +++ b/base/settings/R/clean.settings.R @@ -58,7 +58,7 @@ clean.settings <- function(inputfile = "pecan.xml", outputfile = "pecan.xml", wr settings$workflow <- NULL # save and done - if(write) XML::saveXML(listToXml(settings, "pecan"), file = outputfile) + if(write) XML::saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = outputfile) ## Return settings file as a list return(invisible(settings)) diff --git a/base/settings/R/write.settings.R b/base/settings/R/write.settings.R index 0bf22b6000f..488d1c282f5 100644 --- a/base/settings/R/write.settings.R +++ b/base/settings/R/write.settings.R @@ -14,5 +14,5 @@ write.settings <- function(settings, outputfile, outputdir=settings$outdir){ if (file.exists(pecanfile)) { PEcAn.logger::logger.warn(paste("File already exists [", pecanfile, "] file will be overwritten")) } - saveXML(listToXml(settings, "pecan"), file=pecanfile) + saveXML(PEcAn.utils::listToXml(settings, "pecan"), file=pecanfile) } diff --git a/base/settings/tests/testthat/test.MultiSettings.class.R b/base/settings/tests/testthat/test.MultiSettings.class.R index 09689d42062..6c15a1ee7cf 100644 --- a/base/settings/tests/testthat/test.MultiSettings.class.R +++ b/base/settings/tests/testthat/test.MultiSettings.class.R @@ -289,7 +289,7 @@ are.equal.possiblyNumericToCharacter <- function(o1, o2) { test_that("multiSettings write to and read from xml as expcted (i.e., with collapsing/expanding global settings)", { msOrig <- multiSettingsTemplate - msXML <- listToXml(msOrig, "pecan.multi") + msXML <- PEcAn.utils::listToXml(msOrig, "pecan.multi") listNew <- XML::xmlToList(msXML) msNew <- expandMultiSettings(listNew) diff --git a/base/utils/R/do_conversions.R b/base/utils/R/do_conversions.R index 69009d54658..25e25d11561 100644 --- a/base/utils/R/do_conversions.R +++ b/base/utils/R/do_conversions.R @@ -91,4 +91,4 @@ do_conversions <- function(settings, overwrite.met = FALSE, overwrite.fia = FALS settings <- PEcAn.settings::read.settings(file.path(settings$outdir, "pecan.METProcess.xml")) } return(settings) -} \ No newline at end of file +} diff --git a/models/biocro/R/write.configs.BIOCRO.R b/models/biocro/R/write.configs.BIOCRO.R index ba142212dcc..d5bd43a20f6 100644 --- a/models/biocro/R/write.configs.BIOCRO.R +++ b/models/biocro/R/write.configs.BIOCRO.R @@ -167,18 +167,18 @@ write.config.BIOCRO <- function(defaults = NULL, trait.values, settings, run.id) ## this is where soil parms can be set defaults$soilControl$FieldC <- ### Put defaults and other parts of config file together - parms.xml <- listToXml(defaults, "pft") - location.xml <- listToXml(list(latitude = settings$run$site$lat, + parms.xml <- PEcAn.utils::listToXml(defaults, "pft") + location.xml <- PEcAn.utils::listToXml(list(latitude = settings$run$site$lat, longitude = settings$run$site$lon), "location") - run.xml <- listToXml(list(start.date = settings$run$start.date, + run.xml <- PEcAn.utils::listToXml(list(start.date = settings$run$start.date, end.date = settings$run$end.date, met.path = settings$run$inputs$met$path, soil.file = settings$run$inputs$soil$path), "run") slashdate <- function(x) substr(gsub("-", "/", x), 1, 10) - simulationPeriod.xml <- listToXml(list(dateofplanting = slashdate(settings$run$start.date), + simulationPeriod.xml <- PEcAn.utils::listToXml(list(dateofplanting = slashdate(settings$run$start.date), dateofharvest = slashdate(settings$run$end.date)), "simulationPeriod") diff --git a/models/maat/R/met2model.MAAT.R b/models/maat/R/met2model.MAAT.R index d3b959917b8..935fe28bc0e 100644 --- a/models/maat/R/met2model.MAAT.R +++ b/models/maat/R/met2model.MAAT.R @@ -217,7 +217,7 @@ met2model.MAAT <- function(in.path, in.prefix, outfolder, start_date, end_date, # TODO: make this dynamic with names above! # TODO: add the additional met variables, make dynamic leaf_user_met_list <- list(leaf = list(env = list(time = "'Time'", temp = "'Tair_degC'", par = "'PAR_umols_m2_s'"))) - leaf_user_met_xml <- listToXml(leaf_user_met_list, "met_data_translator") + leaf_user_met_xml <- PEcAn.utils::listToXml(leaf_user_met_list, "met_data_translator") # output XML file saveXML(leaf_user_met_xml, diff --git a/models/maat/inst/simple_workflow.R b/models/maat/inst/simple_workflow.R index 2ec86558a16..81bce360d8f 100644 --- a/models/maat/inst/simple_workflow.R +++ b/models/maat/inst/simple_workflow.R @@ -23,7 +23,7 @@ settings <- read.settings(system.file("pecan.maat.xml",package = "PEcAn.MAAT")) # get traits of pfts settings$pfts <- get.trait.data(settings$pfts, settings$model$type, settings$database$dbfiles, settings$database$bety, settings$meta.analysis$update) -saveXML(listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) +saveXML(PEcAn.utils::listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) #--------------------------------------------------------------------------------------------------# diff --git a/modules/assim.batch/R/pda.mcmc.R b/modules/assim.batch/R/pda.mcmc.R index 58999036e47..7384e181d98 100644 --- a/modules/assim.batch/R/pda.mcmc.R +++ b/modules/assim.batch/R/pda.mcmc.R @@ -150,7 +150,7 @@ pda.mcmc <- function(settings, params.id = NULL, param.names = NULL, prior.id = } ## save updated settings XML. Will be overwritten at end, but useful in case of crash - saveXML(listToXml(settings, "pecan"), + saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, paste0("pecan.pda", settings$assim.batch$ensemble.id, diff --git a/modules/assim.batch/R/pda.mcmc.bs.R b/modules/assim.batch/R/pda.mcmc.bs.R index 3ea2c59e2cc..5b5d2ca52d8 100644 --- a/modules/assim.batch/R/pda.mcmc.bs.R +++ b/modules/assim.batch/R/pda.mcmc.bs.R @@ -169,7 +169,7 @@ pda.mcmc.bs <- function(settings, params.id = NULL, param.names = NULL, prior.id # Save updated settings XML. Will be overwritten at end, but useful in case of crash settings$assim.batch$jump$jvar <- as.list(diag(jcov)) names(settings$assim.batch$jump$jvar) <- rep("jvar", n.param) - saveXML(listToXml(settings, "pecan"), + saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, paste0("pecan.pda", settings$assim.batch$ensemble.id, ".xml"))) diff --git a/modules/assim.batch/R/pda.postprocess.R b/modules/assim.batch/R/pda.postprocess.R index 57eec881377..64f36061fd7 100644 --- a/modules/assim.batch/R/pda.postprocess.R +++ b/modules/assim.batch/R/pda.postprocess.R @@ -103,7 +103,7 @@ pda.postprocess <- function(settings, con, mcmc.param.list, pname, prior, prior. } #end of loop over PFTs ## save updated settings XML - saveXML(listToXml(settings, "pecan"), file = file.path(settings$outdir, paste0("pecan.pda", settings$assim.batch$ensemble.id, + saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, paste0("pecan.pda", settings$assim.batch$ensemble.id, ".xml"))) return(settings) diff --git a/scripts/workflow.bm.R b/scripts/workflow.bm.R index 20cb5e0e3d2..790e3748458 100644 --- a/scripts/workflow.bm.R +++ b/scripts/workflow.bm.R @@ -132,7 +132,7 @@ for (i in seq_along(settings$run$inputs)) { } } if (needsave) { - saveXML(listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.METProcess.xml")) + saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.METProcess.xml")) } else if (file.exists(file.path(settings$outdir, "pecan.METProcess.xml"))) { settings <- read.settings(file.path(settings$outdir, "pecan.METProcess.xml")) } @@ -141,7 +141,7 @@ if (needsave) { if (status.check("TRAIT") == 0) { status.start("TRAIT") settings$pfts <- get.trait.data(settings$pfts, settings$model$type, settings$run$dbfiles, settings$database$bety, settings$meta.analysis$update) - saveXML(listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.TRAIT.xml")) + saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.TRAIT.xml")) status.end() } else if (file.exists(file.path(settings$outdir, "pecan.TRAIT.xml"))) { settings <- read.settings(file.path(settings$outdir, "pecan.TRAIT.xml")) @@ -167,7 +167,7 @@ if (status.check("CONFIG") == 0) { settings <- run.write.configs(settings, write = settings$database$bety$write, ens.sample.method = settings$ensemble$method) - saveXML(listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.CONFIGS.xml")) + saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.CONFIGS.xml")) status.end() } else if (file.exists(file.path(settings$outdir, "pecan.CONFIGS.xml"))) { settings <- read.settings(file.path(settings$outdir, "pecan.CONFIGS.xml")) diff --git a/scripts/workflow.pda.R b/scripts/workflow.pda.R index d23ff149be6..abc3af6c2bf 100755 --- a/scripts/workflow.pda.R +++ b/scripts/workflow.pda.R @@ -95,7 +95,7 @@ if (length(which(commandArgs() == "--continue")) == 0) { } } } - saveXML(listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.METProcess.xml")) + saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.METProcess.xml")) # Check status to avoid repeating work check.status <- function(check.name) { @@ -126,7 +126,7 @@ if (length(which(commandArgs() == "--continue")) == 0) { settings$database$dbfiles, settings$database$bety, settings$meta.analysis$update) - saveXML(listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.TRAIT.xml")) + saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.TRAIT.xml")) status.end() } @@ -147,7 +147,7 @@ if (length(which(commandArgs() == "--continue")) == 0) { if (check.status("CONFIG") == 0) { status.start("CONFIG") settings <- run.write.configs(settings, write = settings$database$bety$write, ens.sample.method = "halton") - saveXML(listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.CONFIGS.xml")) + saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.CONFIGS.xml")) status.end() } @@ -211,7 +211,7 @@ if (!is.null(settings$assim.batch)) { # Calls model specific write.configs e.g. write.config.ed.R status.start("PDA.CONFIG") settings <- run.write.configs(settings, write = settings$database$bety$write, ens.sample.method = "halton") - saveXML(listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.PDA.CONFIGS.xml")) + saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.PDA.CONFIGS.xml")) status.end() # Start ecosystem model runs diff --git a/tests/interactive-workflow.R b/tests/interactive-workflow.R index 2315ed4c77e..8026efa69b3 100644 --- a/tests/interactive-workflow.R +++ b/tests/interactive-workflow.R @@ -23,7 +23,7 @@ settings <- read.settings(settings.file) # get traits of pfts settings$pfts <- get.trait.data(settings$pfts, settings$model$type, settings$database$dbfiles, settings$database$bety, settings$meta.analysis$update) -saveXML(listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) +saveXML(PEcAn.utils::listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) # run meta-analysis @@ -69,7 +69,7 @@ for(i in 1:length(settings$run$inputs)) { # narr download } -saveXML(listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) +saveXML(PEcAn.utils::listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) # write configurations From 7429079bfbaf6467f0d56f87d9d38acec4932e71 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 21 Aug 2017 12:05:07 -0400 Subject: [PATCH 354/771] .Rd files --- modules/data.land/man/partition_roots.Rd | 22 ++++++++++++++++++++++ modules/data.land/man/prepare_pools.Rd | 22 ++++++++++++++++++++++ 2 files changed, 44 insertions(+) create mode 100644 modules/data.land/man/partition_roots.Rd create mode 100644 modules/data.land/man/prepare_pools.Rd diff --git a/modules/data.land/man/partition_roots.Rd b/modules/data.land/man/partition_roots.Rd new file mode 100644 index 00000000000..40b0d9b96e2 --- /dev/null +++ b/modules/data.land/man/partition_roots.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/partition_roots.R +\name{partition_roots} +\alias{partition_roots} +\title{partition_roots} +\usage{ +partition_roots(roots, rtsize) +} +\arguments{ +\item{roots}{vector of root carbon values in kg C m-2} + +\item{rtsize}{vector of lower bounds of root size class thresholds in m, length greater than one and equal to roots. Must contain threshold within .0005 m of .002 m} +} +\value{ +list containing summed fine root and coarse root carbon (2 values) +} +\description{ +Given a vector of root size thresholds (lower bound of each) and a vector of corresponding root carbon values, partition_roots checks if the input can be partitioned along the .002 m threshold between fine and coarse roots and returns a list containing the summed values for fine and coarse. If there are fewer than two thresholds or none within .0005 m of .002 m, returns NULL. Meant to be used in conjunction with standard variable root_carbon_content with rtsize dimension, extracted from netcdf. +} +\author{ +Anne Thomas +} diff --git a/modules/data.land/man/prepare_pools.Rd b/modules/data.land/man/prepare_pools.Rd new file mode 100644 index 00000000000..3fbdf7c0ac1 --- /dev/null +++ b/modules/data.land/man/prepare_pools.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prepare_pools.R +\name{prepare_pools} +\alias{prepare_pools} +\title{prepare_pools} +\usage{ +prepare_pools(nc.path, constants = NULL) +} +\arguments{ +\item{nc.path}{path to netcdf file containing standard dimensions and variables; currently supports these variables: TotLivBiom, leaf_carbon_content, LAI, AbvGrndWood, root_carbon_content, fine_root_carbon_content, coarse_root_carbon_content, litter_carbon_content, soil_organic_carbon_content, soil_carbon_content, wood_debris_carbon_content} + +\item{constants}{list of constants; must include SLA in m2 / kg C if providing LAI for leaf carbon} +} +\value{ +list of pool values in kg C / m2 with generic names +} +\description{ +Calculates pools from given initial condition values, deriving complements where necessary/possible if given TotLivBiomass +} +\author{ +Anne Thomas +} From b7ae06770deedc842c7aea40a940457bf644235d Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Mon, 21 Aug 2017 13:58:03 -0400 Subject: [PATCH 355/771] RTM: Add max iterations option to `invert_bt`. Also, minor bugfixes and cleanup. --- modules/rtm/R/bayestools.R | 92 ++++++++++++------- modules/rtm/man/invert_bt.Rd | 4 + .../tests/testthat/test.invert_bayestools.R | 7 +- 3 files changed, 68 insertions(+), 35 deletions(-) diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R index 005ac6b0545..c530ba84868 100644 --- a/modules/rtm/R/bayestools.R +++ b/modules/rtm/R/bayestools.R @@ -41,8 +41,8 @@ bt_check_convergence <- function(samples, threshold = 1.1, use_CI = TRUE, use_mp } } -#' Quick BayesianTools prior creator for PROSPECT model -#' +#' Quick BayesianTools prior creator for PROSPECT model +#' #' @param custom_prior List containing `param_name`, `distn`, `parama`, `paramb`, and `lower` #' @inheritParams prospect #' @export @@ -55,7 +55,7 @@ prospect_bt_prior <- function(version, custom_prior = list()) { Cw = list('Cw', 'lnorm', log(0.01), 1, 0), Cm = list('Cm', 'lnorm', log(0.009), 1, 0), residual = list('residual', 'lnorm', log(0.001), 2.5, 0) - ) + ) prior_list <- modifyList(prior_default_list, custom_prior) prior_df_all <- do.call(rbind.data.frame, prior_list) colnames(prior_df_all) <- col_names @@ -67,53 +67,60 @@ prospect_bt_prior <- function(version, custom_prior = list()) { } #' Perform Bayesian inversion using BayesianTools package -#' -#' Use samplers from the BayesianTools package to fit models to data. Like -#' `invert.auto`, this will continue to run until convergence is achieved -#' (based on Gelman diagnostic) _and_ the result has enough samples (as +#' +#' Use samplers from the BayesianTools package to fit models to data. Like +#' `invert.auto`, this will continue to run until convergence is achieved +#' (based on Gelman diagnostic) _and_ the result has enough samples (as #' specified by the user; see Details). -#' +#' #' @details `custom_settings` is a list of lists, containing the following: #' * `common` -- BayesianTools settings common to both the initial and subsequent samples. -#' * `init` -- BayesianTools settings for just the first round of sampling. -#' This is most common for the initial number of iterations, which is the +#' * `init` -- BayesianTools settings for just the first round of sampling. +#' This is most common for the initial number of iterations, which is the #' minimum expected for convergence. -#' * `loop` -- BayesianTools settings for iterations inside the convergence -#' checking `while` loop. This is most commonly for setting a smaller +#' * `loop` -- BayesianTools settings for iterations inside the convergence +#' checking `while` loop. This is most commonly for setting a smaller #' iteration count than in `init`. #' * `other` -- Miscellaneous (non-BayesianTools) settings, including: #' - `sampler` -- String describing which sampler to use. Default is `DEzs` -#' - `use_mpsrf` -- Use the multivariate PSRF to check convergence. -#' Default is `FALSE` because it may be an excessively conservative +#' - `use_mpsrf` -- Use the multivariate PSRF to check convergence. +#' Default is `FALSE` because it may be an excessively conservative #' diagnostic. #' - `min_samp` -- Minimum number of samples after burnin before stopping. -#' +#' Default is 1000. +#' - `max_iter` -- Maximum total number of iterations. Default is 1e6. +#' - `lag.max` -- Maximum lag to use for autocorrelation normalization. +#' Default is `10 * log10(n)` (same as `stats::acf` function). +#' #' See the BayesianTools sampler documentation for what can go in the `BayesianTools` settings lists. #' @param observed Vector of observations -#' @param model Function called by log-likelihood. Must be `function(params)` +#' @param model Function called by log-likelihood. Must be `function(params)` #' and return a vector equal to `length(observed)` or `nrow(observed)`. #' @param prior BayesianTools prior object. #' @param custom_settings Nested settings list. See Details. #' @export invert_bt <- function(observed, model, prior, custom_settings = list()) { - default_settings <- list(common = list(), + default_settings <- list(common = list(), init = list(iterations = 10000), loop = list(iterations = 2000), - other = list(sampler = 'DEzs', + other = list(sampler = 'DEzs', use_mpsrf = FALSE, - min_samp = 1000)) + min_samp = 1000, + max_iter = 1e6, + lag.max = NULL)) if (length(custom_settings) > 0) { + settings <- list() for (s in seq_along(default_settings)) { s_name <- names(default_settings)[s] if (s_name %in% names(custom_settings)) { - settings[[s_name]] <- modifyList(default_settings[[s_name]], + settings[[s_name]] <- modifyList(default_settings[[s_name]], custom_settings[[s_name]]) } else { settings[[s_name]] <- default_settings[[s_name]] } - } + } } else { settings <- default_settings } @@ -121,36 +128,55 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { use_mpsrf <- settings[['other']][['use_mpsrf']] min_samp <- settings[['other']][['min_samp']] lag.max <- settings[['other']][['lag.max']] + max_iter <- settings[['other']][['max_iter']] stopifnot('prior' %in% class(prior)) test_samp <- prior$sampler() param_names <- names(test_samp) nparams <- length(test_samp[param_names != 'residual']) - loglike <- rtm_loglike(nparams = nparams, - model = model, - observed = observed, + loglike <- rtm_loglike(nparams = nparams, + model = model, + observed = observed, lag.max = lag.max) - setup <- BayesianTools::createBayesianSetup(likelihood = loglike, - prior = prior, + setup <- BayesianTools::createBayesianSetup(likelihood = loglike, + prior = prior, names = param_names) init_settings <- modifyList(settings[['common']], settings[['init']]) - samples <- BayesianTools::runMCMC(bayesianSetup = setup, - sampler = settings[['other']][['sampler']], + stop_iter <- init_settings[["iterations"]] + if (is.null(stop_iter)) { + stop_iter <- 10000 + warning('init_settings$iterations is not set. Using ', stop_iter, '.') + } + message('Running initial ', stop_iter, ' iterations.') + samples <- BayesianTools::runMCMC(bayesianSetup = setup, + sampler = settings[['other']][['sampler']], settings = init_settings) converged <- bt_check_convergence(samples = samples, use_mpsrf = settings[['other']][['use_mpsrf']]) loop_settings <- modifyList(settings[['common']], settings[['loop']]) - last_iter <- 1 - current_iter <- + next_iter <- loop_settings[['iterations']] + if (is.null(next_iter)) { + next_iter <- 2000 + warning('loop_settings$iterations is not set. Using ', next_iter, '.') + } - while(!(converged && enough_samples)) { + while (!(converged && enough_samples)) { + start_iter <- stop_iter + 1 + stop_iter <- stop_iter + next_iter + if (start_iter > max_iter) { + warning('Next start iteration (', start_iter, ') greater than maximum iteration count (', max_iter, ') ', + 'but convergence has not been achieved. ', + 'Terminating sampling and returning results as is.') + break + } + message('Running ', next_iter, ' more iterations (', start_iter, ' to ', stop_iter, ').') samples <- BayesianTools::runMCMC(samples, sampler = sampler, settings = loop_settings) - converged <- bt_check_convergence(samples = samples, use_mpsrf = settings[['other']][['use_mpsrf']]) + converged <- bt_check_convergence(samples = samples, use_mpsrf = use_mpsrf) if (converged) { coda_samples <- BayesianTools::getSample(samples, coda = TRUE) burned_samples <- PEcAn.assim.batch::autoburnin(coda_samples, return.burnin = TRUE, method = 'gelman.plot') @@ -158,7 +184,7 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { n_samples <- coda::niter(burned_samples$samples) enough_samples <- n_samples > min_samp if (!enough_samples) { - message(n_samples, ' samples after burnin is less than target ', min_samp, + message(n_samples, ' samples after burnin is less than target ', min_samp, '. Resuming sampling.') } } diff --git a/modules/rtm/man/invert_bt.Rd b/modules/rtm/man/invert_bt.Rd index c3faa685c3d..dafdb42af95 100644 --- a/modules/rtm/man/invert_bt.Rd +++ b/modules/rtm/man/invert_bt.Rd @@ -39,6 +39,10 @@ iteration count than in \code{init}. Default is \code{FALSE} because it may be an excessively conservative diagnostic. \item \code{min_samp} -- Minimum number of samples after burnin before stopping. +Default is 1000. +\item \code{max_iter} -- Maximum total number of iterations. Default is 1e6. +\item \code{lag.max} -- Maximum lag to use for autocorrelation normalization. +Default is \code{10 * log10(n)} (same as \code{stats::acf} function). } } diff --git a/modules/rtm/tests/testthat/test.invert_bayestools.R b/modules/rtm/tests/testthat/test.invert_bayestools.R index 384831efeb7..2b4f5eb0657 100644 --- a/modules/rtm/tests/testthat/test.invert_bayestools.R +++ b/modules/rtm/tests/testthat/test.invert_bayestools.R @@ -6,17 +6,20 @@ context('Inversion using BayesianTools') if (Sys.getenv('CI') == 'true') { message('Skipping inversion tests on CI system') } else { + set.seed(12345678) true_params <- defparam('prospect_5') model <- function(x) prospect(x, 5)[,1] observed <- model(true_params) + generate.noise() prior <- prospect_bt_prior(5) custom_settings <- list() samples <- invert_bt(observed = observed, model = model, prior = prior, - custom_settings = list()) + custom_settings = list(init = list(iterations = 2000), + loop = list(iterations = 1000), + other = list(max_iter = 20000))) samples_burned <- PEcAn.assim.batch::autoburnin(BayesianTools::getSample(samples, coda = TRUE), method = 'gelman.plot') mean_estimates <- do.call(cbind, summary(samples_burned)[c('statistics', 'quantiles')]) - test_that('Mean estimates are within 10% of true values', + test_that('Mean estimates are within 10% of true values', expect_equal(true_params, mean_estimates[seq_along(true_params),'Mean'], tol = 0.1)) } From c89c530afc7c08913a9af2e1acd5e80e8d1e6bb2 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Mon, 21 Aug 2017 14:32:32 -0400 Subject: [PATCH 356/771] Merge with upstream:develop --- models/ed/R/write.configs.ed.R | 78 +++++++++++++++++----------------- 1 file changed, 39 insertions(+), 39 deletions(-) diff --git a/models/ed/R/write.configs.ed.R b/models/ed/R/write.configs.ed.R index 1582f61fd55..1f28e4fd843 100644 --- a/models/ed/R/write.configs.ed.R +++ b/models/ed/R/write.configs.ed.R @@ -329,25 +329,25 @@ remove.config.ED2 <- function(main.outdir = settings$outdir, settings) { #' @return R XML object containing full ED2 XML file #' @author David LeBauer, Shawn Serbin, Carl Davidson, Alexey Shiklomanov write.config.xml.ED2 <- function(settings, trait.values, defaults = settings$constants) { - + ## Find history file TODO this should come from the database histfile <- paste0("data/history.r", settings$model$revision, ".csv") if (file.exists(system.file(histfile, package = "PEcAn.ED2"))) { - PEcAn.logger::logger.info(paste0("--- Using ED2 History File: ", "data/history.r", settings$model$revision, ".csv")) - edhistory <- read.csv2(system.file(histfile, package = "PEcAn.ED2"), sep = ";", + PEcAn.logger::logger.debug(paste0("--- Using ED2 History File: ", "data/history.r", settings$model$revision, ".csv")) + edhistory <- read.csv2(system.file(histfile, package = "PEcAn.ED2"), sep = ";", stringsAsFactors = FALSE, dec = ".") } else { - PEcAn.logger::logger.info("--- Using Generic ED2 History File: data/history.csv") - edhistory <- read.csv2(system.file("data/history.csv", package = "PEcAn.ED2"), sep = ";", + PEcAn.logger::logger.debug("--- Using Generic ED2 History File: data/history.csv") + edhistory <- read.csv2(system.file("data/history.csv", package = "PEcAn.ED2"), sep = ";", stringsAsFactors = FALSE, dec = ".") } - + edtraits <- names(edhistory) data(pftmapping, package = 'PEcAn.ED2') - + ## Get ED2 specific model settings and put into output config xml file xml <- PEcAn.utils::listToXml(settings$model$config.header, "config") - + ## Process the names in defaults. Runs only if names(defaults) are null or have at least one ## instance of name attribute 'pft'. Otherwise, AS assumes that names in defaults are already set ## to the corresponding PFT names. @@ -357,13 +357,13 @@ write.config.xml.ED2 <- function(settings, trait.values, defaults = settings$con newnames.notnull <- which(!sapply(newnames, is.null)) names(defaults)[newnames.notnull] <- newnames[newnames.notnull] } - + for (i in seq_along(trait.values)) { group <- names(trait.values)[i] if (group == "env") { - + ## set defaults from config.header - + } else { # Make this agnostic to the way PFT names are defined in `trait.values` -- either directly as # list names or as object 'name' within each sublist is fine @@ -372,7 +372,7 @@ write.config.xml.ED2 <- function(settings, trait.values, defaults = settings$con } else { pft <- group } - + # RyK: Changed this so that pftmapping is required. pft$constants$num is the number that will be # written to config.xml, and it's used by fia.to.ed when mapping spp to a PFT #. But if you're # overriding an existing ED2 pft, then you might not want that PFT number to be used to look up @@ -383,15 +383,15 @@ write.config.xml.ED2 <- function(settings, trait.values, defaults = settings$con # happen is for there to be two settings for each PFT: the 'num' to use to represent the PFT to # ED, and the 'defaults.PFT' (name or number) to use for pulling default parameter values. pft.number <- pftmapping$ED[which(pftmapping == pft)] - + if(pft=="soil"){ data(soil, package = "PEcAn.ED2") vals <- as.list(soil) names(vals) <- colnames(soil) - + converted.trait.values <- convert.samples.ED(trait.values[[i]]) vals <- modifyList(vals, converted.trait.values) - + decompositon.xml <- PEcAn.utils::listToXml(vals, "decomposition") xml <- XML::append.xmlNode(xml, decompositon.xml) } else if(length(pft.number) == 0) { @@ -399,24 +399,24 @@ write.config.xml.ED2 <- function(settings, trait.values, defaults = settings$con stop("Unable to set PFT number") }else{ # TODO: Also modify web app to not default to 1 - + ## Get default trait values from ED history vals <- as.list(edhistory[edhistory$num == pft.number, ]) - + ## Convert trait values to ED units converted.trait.values <- convert.samples.ED(trait.values[[i]]) - + ## Selectively replace defaults with trait values vals <- modifyList(vals, converted.trait.values) - + ## Convert settings constants to ED units converted.defaults <- convert.samples.ED(defaults[[pft]]$constants) - + ## Selectively replace defaults and trait values with constants from settings if (!is.null(converted.defaults)){ vals <- modifyList(vals, converted.defaults) - } - + } + pft.xml <- PEcAn.utils::listToXml(vals, "pft") xml <- XML::append.xmlNode(xml, pft.xml) } @@ -432,10 +432,10 @@ write.config.xml.ED2 <- function(settings, trait.values, defaults = settings$con #' @description Function for writing job.sh file for ED2 runs #' @details Refactored by Alexey Shiklomanov to allow use in PEcAn RTM module. #' @export -#' @param settings PEcAn settings list. For this function, need the following: -#' run$host$rundir, run$host$outdir, run$host$scratchdir, -#' run$host$clearscratch, model$jobtemplate, model$job.sh, run$host$job.sh, -#' run$site$lat, run$site$lon, run$inputs$met$path, run$start.date, +#' @param settings PEcAn settings list. For this function, need the following: +#' run$host$rundir, run$host$outdir, run$host$scratchdir, +#' run$host$clearscratch, model$jobtemplate, model$job.sh, run$host$job.sh, +#' run$site$lat, run$site$lon, run$inputs$met$path, run$start.date, #' run$end.date, model$binary #' @param run.id PEcAn run ID #' @return Character vector containing job.sh file @@ -444,7 +444,7 @@ write.config.jobsh.ED2 <- function(settings, run.id) { # find out where to write run/ouput rundir <- file.path(settings$host$rundir, run.id) outdir <- file.path(settings$host$outdir, run.id) - + # command if scratch is used if (is.null(settings$host$scratchdir)) { modeloutdir <- outdir @@ -454,10 +454,10 @@ write.config.jobsh.ED2 <- function(settings, run.id) { } else { modeloutdir <- file.path(settings$host$scratchdir, settings$workflow$id, run.id) mkdirscratch <- paste("mkdir -p", modeloutdir) - copyscratch <- paste("rsync", "-a", - paste0("\"", file.path(modeloutdir, ""), "\""), + copyscratch <- paste("rsync", "-a", + paste0("\"", file.path(modeloutdir, ""), "\""), paste0("\"", file.path(outdir, ""), "\"")) - if (is.null(settings$host$clearscratch) || is.na(as.logical(settings$host$clearscratch)) || + if (is.null(settings$host$clearscratch) || is.na(as.logical(settings$host$clearscratch)) || as.logical(settings$host$clearscratch)) { clearscratch <- paste("rm", "-rf", paste0("\"", modeloutdir, "\"")) } else { @@ -470,7 +470,7 @@ write.config.jobsh.ED2 <- function(settings, run.id) { } else { jobsh <- readLines(con = system.file("template.job", package = "PEcAn.ED2"), n = -1) } - + # create host specific setttings hostsetup <- "" if (!is.null(settings$model$prerun)) { @@ -479,7 +479,7 @@ write.config.jobsh.ED2 <- function(settings, run.id) { if (!is.null(settings$host$prerun)) { hostsetup <- paste(hostsetup, sep = "\n", paste(settings$host$prerun, collapse = "\n")) } - + hostteardown <- "" if (!is.null(settings$model$postrun)) { hostteardown <- paste(hostteardown, sep = "\n", paste(settings$model$postrun, collapse = "\n")) @@ -487,26 +487,26 @@ write.config.jobsh.ED2 <- function(settings, run.id) { if (!is.null(settings$host$postrun)) { hostteardown <- paste(hostteardown, sep = "\n", paste(settings$host$postrun, collapse = "\n")) } - + # create job.sh jobsh <- gsub("@HOST_SETUP@", hostsetup, jobsh) jobsh <- gsub("@HOST_TEARDOWN@", hostteardown, jobsh) - + jobsh <- gsub("@SITE_LAT@", settings$run$site$lat, jobsh) jobsh <- gsub("@SITE_LON@", settings$run$site$lon, jobsh) jobsh <- gsub("@SITE_MET@", settings$run$inputs$met$path, jobsh) - + jobsh <- gsub("@SCRATCH_MKDIR@", mkdirscratch, jobsh) jobsh <- gsub("@SCRATCH_COPY@", copyscratch, jobsh) jobsh <- gsub("@SCRATCH_CLEAR@", clearscratch, jobsh) - + jobsh <- gsub("@START_DATE@", settings$run$start.date, jobsh) jobsh <- gsub("@END_DATE@", settings$run$end.date, jobsh) - + jobsh <- gsub("@OUTDIR@", outdir, jobsh) jobsh <- gsub("@RUNDIR@", rundir, jobsh) - + jobsh <- gsub("@BINARY@", settings$model$binary, jobsh) - + return(jobsh) } # write.config.jobsh.ED2 From 962100634985c460553017589849f90b03c20a9e Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Mon, 21 Aug 2017 14:35:43 -0400 Subject: [PATCH 357/771] RTM: Check for errors in Gelman diag calc --- modules/rtm/R/bayestools.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R index c530ba84868..92787420707 100644 --- a/modules/rtm/R/bayestools.R +++ b/modules/rtm/R/bayestools.R @@ -23,7 +23,11 @@ rtm_loglike <- function(nparams, model, observed, lag.max = 0.01, ...) { #' Check convergence of BayesianTools output bt_check_convergence <- function(samples, threshold = 1.1, use_CI = TRUE, use_mpsrf = TRUE) { i <- ifelse(use_CI, 2, 1) - gelman <- BayesianTools::gelmanDiagnostics(samples) + gelman <- try(BayesianTools::gelmanDiagnostics(samples)) + if (class(gelman) == 'try-error') { + message('Error trying to calculate gelman diagnostic. Assuming no convergence') + return(FALSE) + } if (use_mpsrf) { gelman_vec <- c(gelman$psrf[,i], mpsrf = gelman$mpsrf) } else { From 5974faf4aacd0c300216f3503f734c95f457686b Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Tue, 22 Aug 2017 08:12:11 -0400 Subject: [PATCH 358/771] migrating PEcAn.qaqc into base folder --- {qaqc => base/qaqc}/DESCRIPTION | 0 {qaqc => base/qaqc}/LICENSE | 0 {qaqc => base/qaqc}/NAMESPACE | 0 {qaqc => base/qaqc}/R/taylor.plot.R | 0 {qaqc => base/qaqc}/inst/extdata/data.csv | 0 {qaqc => base/qaqc}/inst/extdata/ebifarm/ed2in-template-pavi | 0 {qaqc => base/qaqc}/inst/extdata/ebifarm/fast/misi.xml | 0 {qaqc => base/qaqc}/inst/extdata/ebifarm/fast/pavi.xml | 0 {qaqc => base/qaqc}/inst/extdata/ebifarm/post/pavi.xml | 0 {qaqc => base/qaqc}/inst/extdata/ebifarm/prior/pavi.xml | 0 {qaqc => base/qaqc}/inst/extdata/extdata.R | 0 {qaqc => base/qaqc}/inst/extdata/testdata1.csv | 0 {qaqc => base/qaqc}/man/new.taylor.Rd | 0 {qaqc => base/qaqc}/tests/testthat.R | 0 {qaqc => base/qaqc}/tests/testthat/test.taylor.plot.R | 0 {qaqc => base/qaqc}/vignettes/compare ED2.Rmd | 0 {qaqc => base/qaqc}/vignettes/function_relationships.Rmd | 0 {qaqc => base/qaqc}/vignettes/lebauer2013ffb.Rmd | 0 {qaqc => base/qaqc}/vignettes/module_output.Rmd | 0 19 files changed, 0 insertions(+), 0 deletions(-) rename {qaqc => base/qaqc}/DESCRIPTION (100%) rename {qaqc => base/qaqc}/LICENSE (100%) rename {qaqc => base/qaqc}/NAMESPACE (100%) rename {qaqc => base/qaqc}/R/taylor.plot.R (100%) rename {qaqc => base/qaqc}/inst/extdata/data.csv (100%) rename {qaqc => base/qaqc}/inst/extdata/ebifarm/ed2in-template-pavi (100%) rename {qaqc => base/qaqc}/inst/extdata/ebifarm/fast/misi.xml (100%) rename {qaqc => base/qaqc}/inst/extdata/ebifarm/fast/pavi.xml (100%) rename {qaqc => base/qaqc}/inst/extdata/ebifarm/post/pavi.xml (100%) rename {qaqc => base/qaqc}/inst/extdata/ebifarm/prior/pavi.xml (100%) rename {qaqc => base/qaqc}/inst/extdata/extdata.R (100%) rename {qaqc => base/qaqc}/inst/extdata/testdata1.csv (100%) rename {qaqc => base/qaqc}/man/new.taylor.Rd (100%) rename {qaqc => base/qaqc}/tests/testthat.R (100%) rename {qaqc => base/qaqc}/tests/testthat/test.taylor.plot.R (100%) rename {qaqc => base/qaqc}/vignettes/compare ED2.Rmd (100%) rename {qaqc => base/qaqc}/vignettes/function_relationships.Rmd (100%) rename {qaqc => base/qaqc}/vignettes/lebauer2013ffb.Rmd (100%) rename {qaqc => base/qaqc}/vignettes/module_output.Rmd (100%) diff --git a/qaqc/DESCRIPTION b/base/qaqc/DESCRIPTION similarity index 100% rename from qaqc/DESCRIPTION rename to base/qaqc/DESCRIPTION diff --git a/qaqc/LICENSE b/base/qaqc/LICENSE similarity index 100% rename from qaqc/LICENSE rename to base/qaqc/LICENSE diff --git a/qaqc/NAMESPACE b/base/qaqc/NAMESPACE similarity index 100% rename from qaqc/NAMESPACE rename to base/qaqc/NAMESPACE diff --git a/qaqc/R/taylor.plot.R b/base/qaqc/R/taylor.plot.R similarity index 100% rename from qaqc/R/taylor.plot.R rename to base/qaqc/R/taylor.plot.R diff --git a/qaqc/inst/extdata/data.csv b/base/qaqc/inst/extdata/data.csv similarity index 100% rename from qaqc/inst/extdata/data.csv rename to base/qaqc/inst/extdata/data.csv diff --git a/qaqc/inst/extdata/ebifarm/ed2in-template-pavi b/base/qaqc/inst/extdata/ebifarm/ed2in-template-pavi similarity index 100% rename from qaqc/inst/extdata/ebifarm/ed2in-template-pavi rename to base/qaqc/inst/extdata/ebifarm/ed2in-template-pavi diff --git a/qaqc/inst/extdata/ebifarm/fast/misi.xml b/base/qaqc/inst/extdata/ebifarm/fast/misi.xml similarity index 100% rename from qaqc/inst/extdata/ebifarm/fast/misi.xml rename to base/qaqc/inst/extdata/ebifarm/fast/misi.xml diff --git a/qaqc/inst/extdata/ebifarm/fast/pavi.xml b/base/qaqc/inst/extdata/ebifarm/fast/pavi.xml similarity index 100% rename from qaqc/inst/extdata/ebifarm/fast/pavi.xml rename to base/qaqc/inst/extdata/ebifarm/fast/pavi.xml diff --git a/qaqc/inst/extdata/ebifarm/post/pavi.xml b/base/qaqc/inst/extdata/ebifarm/post/pavi.xml similarity index 100% rename from qaqc/inst/extdata/ebifarm/post/pavi.xml rename to base/qaqc/inst/extdata/ebifarm/post/pavi.xml diff --git a/qaqc/inst/extdata/ebifarm/prior/pavi.xml b/base/qaqc/inst/extdata/ebifarm/prior/pavi.xml similarity index 100% rename from qaqc/inst/extdata/ebifarm/prior/pavi.xml rename to base/qaqc/inst/extdata/ebifarm/prior/pavi.xml diff --git a/qaqc/inst/extdata/extdata.R b/base/qaqc/inst/extdata/extdata.R similarity index 100% rename from qaqc/inst/extdata/extdata.R rename to base/qaqc/inst/extdata/extdata.R diff --git a/qaqc/inst/extdata/testdata1.csv b/base/qaqc/inst/extdata/testdata1.csv similarity index 100% rename from qaqc/inst/extdata/testdata1.csv rename to base/qaqc/inst/extdata/testdata1.csv diff --git a/qaqc/man/new.taylor.Rd b/base/qaqc/man/new.taylor.Rd similarity index 100% rename from qaqc/man/new.taylor.Rd rename to base/qaqc/man/new.taylor.Rd diff --git a/qaqc/tests/testthat.R b/base/qaqc/tests/testthat.R similarity index 100% rename from qaqc/tests/testthat.R rename to base/qaqc/tests/testthat.R diff --git a/qaqc/tests/testthat/test.taylor.plot.R b/base/qaqc/tests/testthat/test.taylor.plot.R similarity index 100% rename from qaqc/tests/testthat/test.taylor.plot.R rename to base/qaqc/tests/testthat/test.taylor.plot.R diff --git a/qaqc/vignettes/compare ED2.Rmd b/base/qaqc/vignettes/compare ED2.Rmd similarity index 100% rename from qaqc/vignettes/compare ED2.Rmd rename to base/qaqc/vignettes/compare ED2.Rmd diff --git a/qaqc/vignettes/function_relationships.Rmd b/base/qaqc/vignettes/function_relationships.Rmd similarity index 100% rename from qaqc/vignettes/function_relationships.Rmd rename to base/qaqc/vignettes/function_relationships.Rmd diff --git a/qaqc/vignettes/lebauer2013ffb.Rmd b/base/qaqc/vignettes/lebauer2013ffb.Rmd similarity index 100% rename from qaqc/vignettes/lebauer2013ffb.Rmd rename to base/qaqc/vignettes/lebauer2013ffb.Rmd diff --git a/qaqc/vignettes/module_output.Rmd b/base/qaqc/vignettes/module_output.Rmd similarity index 100% rename from qaqc/vignettes/module_output.Rmd rename to base/qaqc/vignettes/module_output.Rmd From fcafd90f2f8d00af99da1d0afada1468f1a54c3c Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Tue, 22 Aug 2017 08:14:45 -0400 Subject: [PATCH 359/771] R version depends --- base/logger/DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/logger/DESCRIPTION b/base/logger/DESCRIPTION index ba6d884daec..fe684282038 100644 --- a/base/logger/DESCRIPTION +++ b/base/logger/DESCRIPTION @@ -4,7 +4,7 @@ Version: 0.0.0.9000 Author: Rob Kooper, Alexey Shiklomanov Maintainer: Alexey Shiklomanov Description: Special logger functions for tracking execution status and the environment. -Depends: R (>= 3.4.1) +Depends: R License: FreeBSD + file LICENSE Encoding: UTF-8 LazyData: true From 8469be07bd990f172e2c9b255843d753a023678e Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Tue, 22 Aug 2017 08:21:37 -0400 Subject: [PATCH 360/771] migrating mcmc.list2init --- base/utils/R/mcmc.list2init.R | 78 ++++++++++++++++++++++++++++++++ base/utils/man/mcmc.list2init.Rd | 20 ++++++++ 2 files changed, 98 insertions(+) create mode 100644 base/utils/R/mcmc.list2init.R create mode 100644 base/utils/man/mcmc.list2init.Rd diff --git a/base/utils/R/mcmc.list2init.R b/base/utils/R/mcmc.list2init.R new file mode 100644 index 00000000000..965c52215fb --- /dev/null +++ b/base/utils/R/mcmc.list2init.R @@ -0,0 +1,78 @@ +#' Convert mcmc.list to initial condition list +#' +#' Used for restarting MCMC code based on last parameters sampled (e.g. in JAGS) +#' +#' @author Mike Dietze +#' +#' @param dat mcmc.list object +#' +#' @return list +#' @export +#' +#' @examples +mcmc.list2init <- function(dat) { + + ## get unique variable names + allname <- strsplit(colnames(dat[[1]]),"[",fixed = TRUE) + firstname <- sapply(allname,function(x){x[1]}) + dims <- lapply(allname,function(x){ + y <- sub(pattern = "]",replacement = "",x[2]) + y <- as.numeric(strsplit(y,",",fixed=TRUE)[[1]]) + return(y) + }) + ind <- t(sapply(dims,function(x){ + if(length(x)==2){ + return(x) + } else { return(c(NA,NA))} + })) + + uname <- unique(firstname) + + ## define variables + ic <- list() + n <- nrow(dat[[1]]) + nc <- nchain(dat) + for(c in seq_len(nc)) ic[[c]] <- list() + + for(v in seq_along(uname)){ + + ## detect variable type (scalar, vector, matrix) + cols <- which(firstname == uname[v]) + + if(length(cols) == 1){ + ## SCALAR + for(c in seq_len(nc)){ + ic[[c]][[v]] <- dat[[c]][nr,cols] + names(ic[[c]])[v] <- uname[v] + } + + } else { + + dim <- length(dims[[cols[1]]]) + + if(dim == 1){ + ## VECTOR + for(c in seq_len(nc)){ + ic[[c]][[v]] <- dat[[c]][nr,cols] + names(ic[[c]])[v] <- uname[v] + } + + } else if (dim == 2){ + ## MATRIX + for(c in seq_len(nc)){ + ic[[c]][[v]] <- matrix(seq_along(cols),max(ind[cols,1]),max(ind[cols,2])) ## set up matrix for storage + ic[[c]][[v]][ind[cols]] <- dat[[c]][nr,cols] + names(ic[[c]])[v] <- uname[v] + } + + } else { + PEcAn.utils::logger.severe("dimension not supported",dim,uname[v]) + } + + } ## end else VECTOR or MATRIX + + } ## end loop over v + + return(ic) + +} ## end mcmc.list2init \ No newline at end of file diff --git a/base/utils/man/mcmc.list2init.Rd b/base/utils/man/mcmc.list2init.Rd new file mode 100644 index 00000000000..c91a11718f8 --- /dev/null +++ b/base/utils/man/mcmc.list2init.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mcmc.list2init.R +\name{mcmc.list2init} +\alias{mcmc.list2init} +\title{Convert mcmc.list to initial condition list} +\usage{ +mcmc.list2init(dat) +} +\arguments{ +\item{dat}{mcmc.list object} +} +\value{ +list +} +\description{ +Used for restarting MCMC code based on last parameters sampled (e.g. in JAGS) +} +\author{ +Mike Dietze +} From b593b0f5312e9acaf030a9a04e88eaae846a347f Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 22 Aug 2017 09:15:43 -0400 Subject: [PATCH 361/771] ED2: Update documentation. --- models/ed/man/write.config.jobsh.ED2.Rd | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/models/ed/man/write.config.jobsh.ED2.Rd b/models/ed/man/write.config.jobsh.ED2.Rd index 6e3481c7730..4046bb2385c 100644 --- a/models/ed/man/write.config.jobsh.ED2.Rd +++ b/models/ed/man/write.config.jobsh.ED2.Rd @@ -7,10 +7,10 @@ write.config.jobsh.ED2(settings, run.id) } \arguments{ -\item{settings}{PEcAn settings list. For this function, need the following: -run$host$rundir, run$host$outdir, run$host$scratchdir, -run$host$clearscratch, model$jobtemplate, model$job.sh, run$host$job.sh, -run$site$lat, run$site$lon, run$inputs$met$path, run$start.date, +\item{settings}{PEcAn settings list. For this function, need the following: +run$host$rundir, run$host$outdir, run$host$scratchdir, +run$host$clearscratch, model$jobtemplate, model$job.sh, run$host$job.sh, +run$site$lat, run$site$lon, run$inputs$met$path, run$start.date, run$end.date, model$binary} \item{run.id}{PEcAn run ID} From 9f032bd77563f7d0bc222e42a340c124e51fa469 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 22 Aug 2017 09:29:24 -0400 Subject: [PATCH 362/771] RTM: Add `save_progress` option to `invert_bt` --- modules/rtm/R/bayestools.R | 18 ++++++++++++++++-- modules/rtm/man/invert_bt.Rd | 2 ++ 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R index 92787420707..067a14b8d28 100644 --- a/modules/rtm/R/bayestools.R +++ b/modules/rtm/R/bayestools.R @@ -95,6 +95,8 @@ prospect_bt_prior <- function(version, custom_prior = list()) { #' - `max_iter` -- Maximum total number of iterations. Default is 1e6. #' - `lag.max` -- Maximum lag to use for autocorrelation normalization. #' Default is `10 * log10(n)` (same as `stats::acf` function). +#' - `save_progress` -- File name for saving samples between loop +#' iterations. If `NULL` (default), do not save progress samples. #' #' See the BayesianTools sampler documentation for what can go in the `BayesianTools` settings lists. #' @param observed Vector of observations @@ -112,7 +114,8 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { use_mpsrf = FALSE, min_samp = 1000, max_iter = 1e6, - lag.max = NULL)) + lag.max = NULL, + save_progress = NULL)) if (length(custom_settings) > 0) { settings <- list() @@ -133,7 +136,12 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { min_samp <- settings[['other']][['min_samp']] lag.max <- settings[['other']][['lag.max']] max_iter <- settings[['other']][['max_iter']] + save_progress <- settings[['other']][['save_progress']] + if (!is.null(save_progress)) { + # `file.create` returns FALSE if target directory doesn't exist. + stopifnot(file.create(save_progress)) + } stopifnot('prior' %in% class(prior)) test_samp <- prior$sampler() param_names <- names(test_samp) @@ -159,7 +167,10 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { samples <- BayesianTools::runMCMC(bayesianSetup = setup, sampler = settings[['other']][['sampler']], settings = init_settings) - converged <- bt_check_convergence(samples = samples, use_mpsrf = settings[['other']][['use_mpsrf']]) + if (!is.null(save_progress)) { + saveRDS(object = samples, file = save_progress) + } + converged <- bt_check_convergence(samples = samples, use_mpsrf = use_mpsrf) loop_settings <- modifyList(settings[['common']], settings[['loop']]) @@ -180,6 +191,9 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { } message('Running ', next_iter, ' more iterations (', start_iter, ' to ', stop_iter, ').') samples <- BayesianTools::runMCMC(samples, sampler = sampler, settings = loop_settings) + if (!is.null(save_progress)) { + saveRDS(object = samples, file = save_progress) + } converged <- bt_check_convergence(samples = samples, use_mpsrf = use_mpsrf) if (converged) { coda_samples <- BayesianTools::getSample(samples, coda = TRUE) diff --git a/modules/rtm/man/invert_bt.Rd b/modules/rtm/man/invert_bt.Rd index dafdb42af95..560d7120f38 100644 --- a/modules/rtm/man/invert_bt.Rd +++ b/modules/rtm/man/invert_bt.Rd @@ -43,6 +43,8 @@ Default is 1000. \item \code{max_iter} -- Maximum total number of iterations. Default is 1e6. \item \code{lag.max} -- Maximum lag to use for autocorrelation normalization. Default is \code{10 * log10(n)} (same as \code{stats::acf} function). +\item \code{save_progress} -- File name for saving samples between loop +iterations. If \code{NULL} (default), do not save progress samples. } } From cbed1ca7e431549ba3b6397bb14567e9d8e362d8 Mon Sep 17 00:00:00 2001 From: "Alexey Shiklomanov (scc)" Date: Tue, 22 Aug 2017 09:43:35 -0400 Subject: [PATCH 363/771] Merge with upstream --- Makefile | 66 +++++++++++++++++++++++--------------------------------- 1 file changed, 27 insertions(+), 39 deletions(-) diff --git a/Makefile b/Makefile index a1496e8eeb0..ef779565fd6 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ NCPUS ?= 1 -BASE := logger utils db settings visualization +BASE := utils db settings visualization MODELS := biocro clm45 dalec ed fates gday jules linkages \ lpjguess maat maespa preles sipnet @@ -10,7 +10,6 @@ MODULES := allometry assim.batch assim.sequential benchmark \ data.mining data.remote emulator meta.analysis \ photosynthesis priors rtm uncertainty -BASE := $(BASE:%=base/%) MODELS := $(MODELS:%=models/%) MODULES := $(MODULES:%=modules/%) ALL_PKGS := $(BASE) $(MODELS) $(MODULES) models/template @@ -30,46 +29,39 @@ MODELS_T := $(MODELS:%=.test/%) MODULES_T := $(MODULES:%=.test/%) ALL_PKGS_T := $(BASE_T) $(MODELS_T) $(MODULES_T) .test/models/template -BASE_D := $(BASE:%=.doc/%) -MODELS_D := $(MODELS:%=.doc/%) -MODULES_D := $(MODULES:%=.doc/%) -ALL_PKGS_D := $(BASE_D) $(MODELS_D) $(MODULES_D) .doc/models/template +.PHONY: all install check test -.PHONY: all install check test document +all: install -all: install document - -document: .doc/base/all -install: .install/base/all -check: .check/base/all -test: .test/base/all +install: .install/all +check: .check/all +test: .test/all ### Dependencies -.doc/base/all: $(ALL_PKGS_D) -.install/base/all: $(ALL_PKGS_I) -.check/base/all: $(ALL_PKGS_C) -.test/base/all: $(ALL_PKGS_T) - -depends = .check/$(1) .test/$(1) - -$(call depends,base/db): .install/base/logger .install/base/utils -$(call depends,base/settings): .install/base/logger .install/base/utils .install/base/db -$(call depends,base/visualization): .install/base/logger .install/base/db -$(call depends,modules/data.atmosphere): .install/base/logger .install/base/utils -$(call depends,modules/data.land): .install/base/logger .install/base/db .install/base/utils -$(call depends,modules/meta.analysis): .install/base/logger .install/base/utils .install/base/db -$(call depends,modules/priors): .install/base/logger .install/base/utils -$(call depends,modules/assim.batch): .install/base/logger .install/base/utils .install/base/db .install/modules/meta.analysis -$(call depends,modules/rtm): .install/base/logger .install/modules/assim.batch -$(call depends,modules/uncertainty): .install/base/logger .install/base/utils .install/modules/priors -$(call depends,models/template): .install/base/logger .install/base/utils -$(call depends,models/biocro): .install/base/logger .install/base/utils .install/base/settings .install/base/db .install/modules/data.atmosphere .install/modules/data.land +.install/all: $(ALL_PKGS_I) +.check/all: $(ALL_PKGS_C) +.test/all: $(ALL_PKGS_T) + +depends = .install/$(1) .check/$(1) .test/$(1) + +$(call depends,db): .install/utils +$(call depends,settings): .install/utils .install/db +$(call depends,visualization): .install/db +$(call depends,modules/data.atmosphere): .install/utils +$(call depends,modules/data.land): .install/db .install/utils +$(call depends,modules/meta.analysis): .install/utils .install/db +$(call depends,modules/priors): .install/utils +$(call depends,modules/assim.batch): .install/utils .install/db .install/modules/meta.analysis +$(call depends,modules/rtm): .install/modules/assim.batch +$(call depends,modules/uncertainty): .install/utils .install/modules/priors +$(call depends,models/template): .install/utils +$(call depends,models/biocro): .install/utils .install/settings .install/db .install/modules/data.atmosphere .install/modules/data.land $(MODELS_I): .install/models/template clean: - rm -rf .install .check .test .doc + rm -rf .install .check .test find modules/rtm/src \( -name \*.mod -o -name \*.o -o -name \*.so \) -delete .install/devtools: @@ -93,16 +85,12 @@ check_R_pkg = Rscript scripts/check_with_errors.R $(strip $(1)) test_R_pkg = Rscript -e "devtools::test('"$(strip $(1))"', reporter = 'stop')" doc_R_pkg = Rscript -e "devtools::document('"$(strip $(1))"')" -$(ALL_PKGS_I) $(ALL_PKGS_C) $(ALL_PKGS_T) $(ALL_PKGS_D): .install/devtools .install/roxygen2 .install/testthat +$(ALL_PKGS_I) $(ALL_PKGS_C) $(ALL_PKGS_T): .install/devtools .install/roxygen2 .install/testthat .SECONDEXPANSION: -.doc/%: $$(wildcard %/**/*) $$(wildcard %/*) +.install/%: $$(wildcard %/**/*) $$(wildcard %/*) $(call depends_R_pkg, $(subst .doc/,,$@)) $(call doc_R_pkg, $(subst .doc/,,$@)) - mkdir -p $(@D) - echo `date` > $@ - -.install/%: $$(wildcard %/**/*) $$(wildcard %/*) $(call install_R_pkg, $(subst .install/,,$@)) mkdir -p $(@D) echo `date` > $@ From 908f375a1f42045de7b6e1244b553f1b1f641c49 Mon Sep 17 00:00:00 2001 From: "Alexey Shiklomanov (scc)" Date: Tue, 22 Aug 2017 10:15:04 -0400 Subject: [PATCH 364/771] Make: Improve make logic to operate on packages Installation of each package depends on its documentation being compiled. This means that it's now much harder to install a package with outdated documentation, _and_ that completep package installation now proceeds one package at a time (i.e. `document package1, install package1, document package2, install package2`) rather than doing all the `document` and `install` steps at once, as before (i.e. `document package1, document package2, install package1, install package2`). This should make installation on new machines much more robust. --- Makefile | 66 +++++++++++++++++++++++++++++++++----------------------- 1 file changed, 39 insertions(+), 27 deletions(-) diff --git a/Makefile b/Makefile index ef779565fd6..9181b0ebe74 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ NCPUS ?= 1 -BASE := utils db settings visualization +BASE := logger utils db settings visualization MODELS := biocro clm45 dalec ed fates gday jules linkages \ lpjguess maat maespa preles sipnet @@ -10,6 +10,7 @@ MODULES := allometry assim.batch assim.sequential benchmark \ data.mining data.remote emulator meta.analysis \ photosynthesis priors rtm uncertainty +BASE := $(BASE:%=base/%) MODELS := $(MODELS:%=models/%) MODULES := $(MODULES:%=modules/%) ALL_PKGS := $(BASE) $(MODELS) $(MODULES) models/template @@ -29,39 +30,46 @@ MODELS_T := $(MODELS:%=.test/%) MODULES_T := $(MODULES:%=.test/%) ALL_PKGS_T := $(BASE_T) $(MODELS_T) $(MODULES_T) .test/models/template -.PHONY: all install check test +BASE_D := $(BASE:%=.doc/%) +MODELS_D := $(MODELS:%=.doc/%) +MODULES_D := $(MODULES:%=.doc/%) +ALL_PKGS_D := $(BASE_D) $(MODELS_D) $(MODULES_D) .doc/models/template -all: install +.PHONY: all install check test document -install: .install/all -check: .check/all -test: .test/all +all: install document + +document: $(ALL_PKGS_D) .doc/base/all +install: $(ALL_PKGS_I) .install/base/all +check: $(ALL_PKGS_C) .check/base/all +test: $(ALL_PKGS_T) .test/base/all ### Dependencies -.install/all: $(ALL_PKGS_I) -.check/all: $(ALL_PKGS_C) -.test/all: $(ALL_PKGS_T) - -depends = .install/$(1) .check/$(1) .test/$(1) - -$(call depends,db): .install/utils -$(call depends,settings): .install/utils .install/db -$(call depends,visualization): .install/db -$(call depends,modules/data.atmosphere): .install/utils -$(call depends,modules/data.land): .install/db .install/utils -$(call depends,modules/meta.analysis): .install/utils .install/db -$(call depends,modules/priors): .install/utils -$(call depends,modules/assim.batch): .install/utils .install/db .install/modules/meta.analysis -$(call depends,modules/rtm): .install/modules/assim.batch -$(call depends,modules/uncertainty): .install/utils .install/modules/priors -$(call depends,models/template): .install/utils -$(call depends,models/biocro): .install/utils .install/settings .install/db .install/modules/data.atmosphere .install/modules/data.land +.doc/base/all: $(ALL_PKGS_D) +.install/base/all: $(ALL_PKGS_I) +.check/base/all: $(ALL_PKGS_C) +.test/base/all: $(ALL_PKGS_T) + +depends = .check/$(1) .test/$(1) + +$(call depends,base/db): .install/base/logger .install/base/utils +$(call depends,base/settings): .install/base/logger .install/base/utils .install/base/db +$(call depends,base/visualization): .install/base/logger .install/base/db +$(call depends,modules/data.atmosphere): .install/base/logger .install/base/utils +$(call depends,modules/data.land): .install/base/logger .install/base/db .install/base/utils +$(call depends,modules/meta.analysis): .install/base/logger .install/base/utils .install/base/db +$(call depends,modules/priors): .install/base/logger .install/base/utils +$(call depends,modules/assim.batch): .install/base/logger .install/base/utils .install/base/db .install/modules/meta.analysis +$(call depends,modules/rtm): .install/base/logger .install/modules/assim.batch +$(call depends,modules/uncertainty): .install/base/logger .install/base/utils .install/modules/priors +$(call depends,models/template): .install/base/logger .install/base/utils +$(call depends,models/biocro): .install/base/logger .install/base/utils .install/base/settings .install/base/db .install/modules/data.atmosphere .install/modules/data.land $(MODELS_I): .install/models/template clean: - rm -rf .install .check .test + rm -rf .install .check .test .doc find modules/rtm/src \( -name \*.mod -o -name \*.o -o -name \*.so \) -delete .install/devtools: @@ -85,12 +93,16 @@ check_R_pkg = Rscript scripts/check_with_errors.R $(strip $(1)) test_R_pkg = Rscript -e "devtools::test('"$(strip $(1))"', reporter = 'stop')" doc_R_pkg = Rscript -e "devtools::document('"$(strip $(1))"')" -$(ALL_PKGS_I) $(ALL_PKGS_C) $(ALL_PKGS_T): .install/devtools .install/roxygen2 .install/testthat +$(ALL_PKGS_I) $(ALL_PKGS_C) $(ALL_PKGS_T) $(ALL_PKGS_D): .install/devtools .install/roxygen2 .install/testthat .SECONDEXPANSION: -.install/%: $$(wildcard %/**/*) $$(wildcard %/*) +.doc/%: $$(wildcard %/**/*) $$(wildcard %/*) $(call depends_R_pkg, $(subst .doc/,,$@)) $(call doc_R_pkg, $(subst .doc/,,$@)) + mkdir -p $(@D) + echo `date` > $@ + +.install/%: $$(wildcard %/**/*) $$(wildcard %/*) .doc/% $(call install_R_pkg, $(subst .install/,,$@)) mkdir -p $(@D) echo `date` > $@ From dfe85522798b3add367cc6e7d8fe2dd86763f782 Mon Sep 17 00:00:00 2001 From: "Alexey Shiklomanov (scc)" Date: Tue, 22 Aug 2017 10:22:40 -0400 Subject: [PATCH 365/771] Update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 522c047f3c2..88e043ad076 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha ## [Unreleased] ### Fixes +- Improved make install logic (#1558) - Fixed remote code execution #1545 - Added check for NA end/start year in read.output - Fixed jagify bug for raw field data From 1f478857cd900e93d974c1c0bdc0297e505a8718 Mon Sep 17 00:00:00 2001 From: araiho Date: Tue, 22 Aug 2017 14:04:55 -0400 Subject: [PATCH 366/771] adding diagnostic figures for ensemble adjustment. need to work to reduce dimensionality of figures. --- modules/assim.sequential/R/sda.enkf.R | 47 +++++++++++++++++++++++---- 1 file changed, 41 insertions(+), 6 deletions(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index 25c6f2aa5a7..f7159240091 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -219,7 +219,6 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { # at some point add a lot of error checking # read time from data if data is missing you still need # to have NAs or NULL with date name vector to read the correct netcdfs by read_restart - sum.list <- matrix(NA,nens,nt) obs.times <- names(obs.mean) obs.times.POSIX <- ymd_hms(obs.times) @@ -787,11 +786,6 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { X_a[i,] <- V_a %*%diag(sqrt(L_a))%*%Z[i,] + mu.a } - - for(i in seq_len(nens)){ - sum.list[i,t]<-sum(V_a %*%diag(sqrt(L_a))%*%Z[i,] - mu.a) - } - # par(mfrow=c(1,1)) # plot(X_a) # ## check if ensemble mean is correct @@ -965,6 +959,47 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { } else { print("climate diagnostics under development") } + ###-------------------------------------------------------------------### + ### ensemble adjustment ### + ###-------------------------------------------------------------------### + + #Calculate the likelihood of the ensemble members given mu.a and Pa + wt.mat <- matrix(NA,nrow=nens,ncol=nt) + + for(t in seq_len(nt)){ + for(i in seq_len(nens)){ + wt.mat[i,t]<-dmnorm_chol(FORECAST[[t]][i,],enkf.params[[t]]$mu.a,enkf.params[[t]]$Pa) + } + } + + wt.props <- t(prop.table(wt.mat,2)) + + pdf(file.path(settings$outdir,'ensemble.weights.time-series.pdf')) + matplot(wt.props,xlab='Time',ylab='Weights') + dev.off() + + param.hist <- unlist(lapply(lapply(params,'[[','Quercus.Rubra_Northern.Red.Oak'),'[[','FROST')) + weighted.hist(x = param.hist, w = wt.props[nt,],freq = FALSE,col = 'lightgrey') + hist(param.hist,freq = FALSE,col = 'lightgrey') + + ## weighted quantile + wtd.quantile <- function(x,wt,q){ + ord <- order(x) + wstar <- cumsum(wt[ord])/sum(wt) + qi <- findInterval(q,wstar); qi[qi<1]=1;qi[qi>length(x)]=length(x) + return(x[ord[qi]]) + } + + param.quant <- matrix(NA, 3, nt) + + for(t in seq_len(nt)){ + param.quant[,t] <- wtd.quantile(x = param.hist, wt=wt.props[t,],q=c(.025,.5,.975)) + } + + plot(param.quant[2,], ylim = range(param.quant,na.rm = TRUE)) + ciEnvelope(x = 1:nt, ylo = param.quant[1,1:nt], yhi = param.quant[3,1:nt], col = 'lightblue') + points(param.quant[2,], pch = 19, cex = 1) + ###-------------------------------------------------------------------### From daa4cd000f0890da89a22571d61636da5c93b53b Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 22 Aug 2017 15:20:36 -0400 Subject: [PATCH 367/771] Creating the data ingest app with shiny --- shiny/Data-Ingest/app.R | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 shiny/Data-Ingest/app.R diff --git a/shiny/Data-Ingest/app.R b/shiny/Data-Ingest/app.R new file mode 100644 index 00000000000..676b294bd56 --- /dev/null +++ b/shiny/Data-Ingest/app.R @@ -0,0 +1,37 @@ +# +# This is a Shiny web application. You can run the application by clicking +# the 'Run App' button above. +# +# Find out more about building applications with Shiny here: +# +# http://shiny.rstudio.com/ +# + +library(shiny) +library(PEcAn.data.land) +library(shinyDND) +# source("dataone_download.R", local = FALSE) + + +# Define UI for application +ui <- fluidPage( + + # Application title + titlePanel("Data Ingest"), + + textInput(inputId = "id", label = "Import From DataONE", value = "doi or identifier"), + textOutput(outputId = "identifier") + + +) + +# Define server logic +server <- function(input, output) { + + output$identifier <- renderText({ PEcAn.data.land::dataone_download(input$id) }) + +} + +# Run the application +shinyApp(ui = ui, server = server) + From a471c6abcb1053cdc6848c1d4088001f909c4ff2 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 22 Aug 2017 17:05:31 -0400 Subject: [PATCH 368/771] Filter start/end dates --- models/sipnet/R/met2model.SIPNET.R | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index 01e67940b6d..bfe8d432b00 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -211,6 +211,21 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date tmp[hr.na, 4] <- tmp[hr.na - 1, 4] + dt/86400 * 24 } + ##filter out days not included in start or end date + if(year == start_year){ + extra.days <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date + if (extra.days > 1){ + start.row <- ((extra.days - 1) * 86400 / dt) + 1 #subtract to include start.date, add to exclude last half hour of day before + tmp <- tmp[start.row:nrow(tmp),] + } + } else if (year == end_year){ + extra.days <- length(as.Date(end_date):as.Date(paste0(end_year, "-12-31"))) #extra days length includes the end date + if (extra.days > 1){ + end.row <- nrow(tmp) - ((extra.days - 1) * 86400 / dt) #subtract to include end.date + tmp <- tmp[1:end.row,] + } + } + if (is.null(out)) { out <- tmp } else { From 8f3818c466bcb994ed91430f2f3c825d8cb4b21e Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 22 Aug 2017 17:12:35 -0400 Subject: [PATCH 369/771] update to PEcAn.DB namespace --- modules/data.atmosphere/R/met2model.module.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.atmosphere/R/met2model.module.R b/modules/data.atmosphere/R/met2model.module.R index 147d4b2f202..13a211b24fb 100644 --- a/modules/data.atmosphere/R/met2model.module.R +++ b/modules/data.atmosphere/R/met2model.module.R @@ -3,7 +3,7 @@ browndog, new.site, overwrite = FALSE, exact.dates,spin) { # Determine output format name and mimetype - model_info <- PEcAn.db::db.query(paste0("SELECT f.name, f.id, mt.type_string from modeltypes as m", " join modeltypes_formats as mf on m.id = mf.modeltype_id", + model_info <- PEcAn.DB::db.query(paste0("SELECT f.name, f.id, mt.type_string 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", " join mimetypes as mt on f.mimetype_id = mt.id", " where m.name = '", model, "' AND mf.tag='met'"), con) From 3715384084771ae68e2c672b96a971a37e552665 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 22 Aug 2017 17:23:04 -0400 Subject: [PATCH 370/771] update to PEcAn.DB namespace 2 --- modules/data.atmosphere/R/met2cf.module.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.atmosphere/R/met2cf.module.R b/modules/data.atmosphere/R/met2cf.module.R index e296701fa43..eedfa23f021 100644 --- a/modules/data.atmosphere/R/met2cf.module.R +++ b/modules/data.atmosphere/R/met2cf.module.R @@ -75,7 +75,7 @@ exact.dates = FALSE) } else if (exists(fcn2)) { fcn <- fcn2 - format <- PEcAn.db::query.format.vars(input.id = input.id, bety = bety) + format <- PEcAn.DB::query.format.vars(input.id = input.id, bety = bety) cf.id <- PEcAn.utils::convert.input(input.id = input.id, outfolder = outfolder, formatname = formatname, From cb105e2ad3e73efd251b675083c35e56326eafc2 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 22 Aug 2017 18:19:18 -0400 Subject: [PATCH 371/771] Namespace for fqdn --- modules/data.atmosphere/R/met2CF.csv.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.atmosphere/R/met2CF.csv.R b/modules/data.atmosphere/R/met2CF.csv.R index 20b8dc03568..c8c69ada5d6 100644 --- a/modules/data.atmosphere/R/met2CF.csv.R +++ b/modules/data.atmosphere/R/met2CF.csv.R @@ -96,7 +96,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form ".nc") results$file <- all_files - results$host <- fqdn() + results$host <- PEcAn.utils::fqdn() # The For below loop updates the start/end date once file is read in results$startdate <- paste0(all_years, "-01-01 00:00:00") From b52bcca71847737268d7cf9bcab7da711fb7f909 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 22 Aug 2017 19:22:57 -0400 Subject: [PATCH 372/771] Fix all fqdn() namespaces --- base/db/R/query.file.path.R | 2 +- base/utils/R/convert.input.R | 8 ++++---- base/utils/R/remote.R | 8 ++++---- models/biocro/R/met2model.BIOCRO.R | 2 +- models/dalec/R/met2model.DALEC.R | 2 +- models/ed/R/met2model.ED2.R | 2 +- models/fates/R/met2model.FATES.R | 2 +- models/linkages/R/met2model.LINKAGES.R | 2 +- models/lpjguess/R/met2model.LPJGUESS.R | 2 +- models/maat/R/met2model.MAAT.R | 2 +- models/maespa/R/met2model.MAESPA.R | 2 +- models/sipnet/R/met2model.SIPNET.R | 2 +- modules/benchmark/R/create_BRR.R | 6 +++--- modules/data.atmosphere/R/download.Ameriflux.R | 2 +- modules/data.atmosphere/R/download.FACE.R | 2 +- modules/data.atmosphere/R/download.GLDAS.R | 2 +- modules/data.atmosphere/R/download.Geostreams.R | 2 +- modules/data.atmosphere/R/download.MACA.R | 2 +- modules/data.atmosphere/R/download.MsTMIP_NARR.R | 2 +- modules/data.atmosphere/R/download.NLDAS.R | 2 +- modules/data.atmosphere/R/download.PalEON.R | 2 +- modules/data.atmosphere/R/download.PalEON_ENS.R | 2 +- modules/data.atmosphere/R/extract.nc.R | 2 +- modules/data.atmosphere/R/met.process.R | 10 +++++----- modules/data.atmosphere/R/met2CF.ALMA.R | 6 +++--- modules/data.atmosphere/R/met2CF.Ameriflux.R | 2 +- modules/data.atmosphere/inst/scripts/met2CF.R | 4 ++-- modules/data.land/R/ic_process.R | 2 +- modules/data.land/R/write_ic.R | 2 +- modules/data.remote/R/NLCD.R | 10 +++++----- 30 files changed, 49 insertions(+), 49 deletions(-) diff --git a/base/db/R/query.file.path.R b/base/db/R/query.file.path.R index 69cd066d794..b9819881a45 100644 --- a/base/db/R/query.file.path.R +++ b/base/db/R/query.file.path.R @@ -7,7 +7,7 @@ ##' ##' @author Betsy Cowdery query.file.path <- function(input.id, host_name, con){ - machine.host <- ifelse(host_name == "localhost",fqdn(),host_name) + machine.host <- ifelse(host_name == "localhost",PEcAn.utils::fqdn(),host_name) machine = db.query(paste0("SELECT * from machines where hostname = '",machine.host,"'"),con) dbfile = db.query(paste("SELECT file_name,file_path from dbfiles where container_id =",input.id," and container_type = 'Input' and machine_id =",machine$id),con) path <- file.path(dbfile$file_path,dbfile$file_name) diff --git a/base/utils/R/convert.input.R b/base/utils/R/convert.input.R index 2ca00dd2316..e4b8b62333c 100644 --- a/base/utils/R/convert.input.R +++ b/base/utils/R/convert.input.R @@ -107,7 +107,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st existing.dbfile$machine_id, "'"), con) #Grab machine info of host machine - machine.host <- ifelse(host$name == "localhost", fqdn(), host$name) + machine.host <- ifelse(host$name == "localhost", PEcAn.utils::fqdn(), host$name) machine <- db.query(paste0("SELECT * from machines where hostname = '", machine.host, "'"), con) @@ -205,7 +205,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st existing.dbfile$machine_id, "'"), con) #Grab machine info of - machine.host <- ifelse(host$name == "localhost", fqdn(), host$name) + machine.host <- ifelse(host$name == "localhost", PEcAn.utils::fqdn(), host$name) machine <- db.query(paste0("SELECT * from machines where hostname = '", machine.host, "'"), con) @@ -250,7 +250,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st #---------------------------------------------------------------------------------------------------------------# # Get machine information - machine.host <- ifelse(host$name == "localhost", fqdn(), host$name) + machine.host <- ifelse(host$name == "localhost", PEcAn.utils::fqdn(), host$name) machine <- db.query(paste0("SELECT * from machines where hostname = '", machine.host, "'"), con) @@ -377,7 +377,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st # create array with results result$file[i] <- new.file - result$host[i] <- fqdn() + result$host[i] <- PEcAn.utils::fqdn() result$startdate[i] <- paste(input$start_date, "00:00:00") result$enddate[i] <- paste(input$end_date, "23:59:59") result$mimetype[i] <- mimetype diff --git a/base/utils/R/remote.R b/base/utils/R/remote.R index caacebc481c..6b17bc3a048 100644 --- a/base/utils/R/remote.R +++ b/base/utils/R/remote.R @@ -38,7 +38,7 @@ remote.execute.cmd <- function(host, cmd, args = character(), stderr = FALSE) { host <- list(name = host) } - if ((host$name == "localhost") || (host$name == fqdn())) { + if ((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) { PEcAn.logger::logger.debug(paste(cmd, args)) system2(cmd, args, stdout = TRUE, stderr = as.logical(stderr)) } else { @@ -171,9 +171,9 @@ remote.copy.to <- function(host, src, dst, delete = FALSE, stderr = FALSE) { #' is.localhost(fqdn()) is.localhost <- function(host) { if (is.character(host)) { - return((host == "localhost") || (host == fqdn())) + return((host == "localhost") || (host == PEcAn.utils::fqdn())) } else if (is.list(host)) { - return((host$name == "localhost") || (host$name == fqdn())) + return((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) } else { return(FALSE) } @@ -218,7 +218,7 @@ remote.execute.R <- function(script, host = "localhost", user = NA, verbose = FA paste0("ign <- serialize(remoteout, fp)"), "close(fp)") verbose <- ifelse(as.logical(verbose), "", FALSE) - if ((host$name == "localhost") || (host$name == fqdn())) { + if ((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) { if (R == "R") { Rbinary <- file.path(Sys.getenv("R_HOME"), "bin", "R") if (file.exists(Rbinary)) { diff --git a/models/biocro/R/met2model.BIOCRO.R b/models/biocro/R/met2model.BIOCRO.R index 2165e0245b8..47d6b97be71 100644 --- a/models/biocro/R/met2model.BIOCRO.R +++ b/models/biocro/R/met2model.BIOCRO.R @@ -83,7 +83,7 @@ met2model.BIOCRO <- function(in.path, in.prefix, outfolder, overwrite = FALSE, res[[as.character(year)]] <- data.frame( file = csvfile, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/csv", formatname = "biocromet", startdate = yrstart, diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index d346b651db8..952901c41a5 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -65,7 +65,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, out.file.full <- file.path(outfolder, out.file) results <- data.frame(file = c(out.file.full), - host = c(fqdn()), + host = c(PEcAn.utils::fqdn()), mimetype = c("text/plain"), formatname = c("DALEC meteorology"), startdate = c(start_date), diff --git a/models/ed/R/met2model.ED2.R b/models/ed/R/met2model.ED2.R index 97dbe2cb787..e5b0a2f7920 100644 --- a/models/ed/R/met2model.ED2.R +++ b/models/ed/R/met2model.ED2.R @@ -46,7 +46,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l met_header <- file.path(met_folder, "ED_MET_DRIVER_HEADER") results <- data.frame(file = c(met_header), - host = c(fqdn()), + host = c(PEcAn.utils::fqdn()), mimetype = c("text/plain"), formatname = c("ed.met_driver_header files format"), startdate = c(start_date), diff --git a/models/fates/R/met2model.FATES.R b/models/fates/R/met2model.FATES.R index b3b71dc1129..592cb169647 100644 --- a/models/fates/R/met2model.FATES.R +++ b/models/fates/R/met2model.FATES.R @@ -154,7 +154,7 @@ met2model.FATES <- function(in.path, in.prefix, outfolder, start_date, end_date, PEcAn.logger::logger.info("Done with met2model.FATES") return(data.frame(file = paste0(outfolder, "/"), - host = c(fqdn()), + host = c(PEcAn.utils::fqdn()), mimetype = c("application/x-netcdf"), formatname = c("CLM met"), startdate = c(start_date), diff --git a/models/linkages/R/met2model.LINKAGES.R b/models/linkages/R/met2model.LINKAGES.R index e421459ea89..11aa102bf54 100644 --- a/models/linkages/R/met2model.LINKAGES.R +++ b/models/linkages/R/met2model.LINKAGES.R @@ -31,7 +31,7 @@ met2model.LINKAGES <- function(in.path, in.prefix, outfolder, start_date, end_da # strptime(end_date, '%Y-%m-%d'), 'dat', sep='.')) results <- data.frame(file = c(out.file), - host = c(fqdn()), + host = c(PEcAn.utils::fqdn()), mimetype = c("text/plain"), formatname = c("LINKAGES meteorology"), startdate = c(start_date), diff --git a/models/lpjguess/R/met2model.LPJGUESS.R b/models/lpjguess/R/met2model.LPJGUESS.R index bfbbf68c3d9..6d7e7d021a9 100644 --- a/models/lpjguess/R/met2model.LPJGUESS.R +++ b/models/lpjguess/R/met2model.LPJGUESS.R @@ -56,7 +56,7 @@ met2model.LPJGUESS <- function(in.path, in.prefix, outfolder, start_date, end_da } results <- data.frame(file = unlist(out.files.full), - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "application/x-netcdf", formatname = "lpj-guess.metfile", startdate = start_date, diff --git a/models/maat/R/met2model.MAAT.R b/models/maat/R/met2model.MAAT.R index 935fe28bc0e..6f283579558 100644 --- a/models/maat/R/met2model.MAAT.R +++ b/models/maat/R/met2model.MAAT.R @@ -52,7 +52,7 @@ met2model.MAAT <- function(in.path, in.prefix, outfolder, start_date, end_date, out.file.full <- file.path(outfolder, out.file) results <- data.frame(file = out.file.full, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/csv", formatname = "MAAT meteorology", startdate = start_date, diff --git a/models/maespa/R/met2model.MAESPA.R b/models/maespa/R/met2model.MAESPA.R index 0b05aae4881..71151215247 100755 --- a/models/maespa/R/met2model.MAESPA.R +++ b/models/maespa/R/met2model.MAESPA.R @@ -45,7 +45,7 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date out.file.full <- file.path(outfolder, out.file) results <- data.frame(file = out.file.full, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/plain", formatname = "maespa.met", startdate = start_date, diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index bfe8d432b00..76a32aa84e6 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -39,7 +39,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date out.file.full <- file.path(outfolder, out.file) results <- data.frame(file = out.file.full, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/csv", formatname = "Sipnet.climna", startdate = start_date, diff --git a/modules/benchmark/R/create_BRR.R b/modules/benchmark/R/create_BRR.R index 1084362b6dc..1c336c1c9d1 100644 --- a/modules/benchmark/R/create_BRR.R +++ b/modules/benchmark/R/create_BRR.R @@ -11,9 +11,9 @@ create_BRR <- function(ens_wf, con, user_id = ""){ - cnd1 <- ens_wf$hostname == fqdn() - cnd2 <- ens_wf$hostname == 'test-pecan.bu.edu' & fqdn() == 'pecan2.bu.edu' - cnd3 <- ens_wf$hostname == 'pecan2.bu.edu' & fqdn() == 'test-pecan.bu.edu' + cnd1 <- ens_wf$hostname == PEcAn.utils::fqdn() + cnd2 <- ens_wf$hostname == 'test-pecan.bu.edu' & PEcAn.utils::fqdn() == 'pecan2.bu.edu' + cnd3 <- ens_wf$hostname == 'pecan2.bu.edu' & PEcAn.utils::fqdn() == 'test-pecan.bu.edu' db.query <- PEcAn.DB::db.query # if(cnd1|cnd2|cnd3){ # If the ensemble run was done on localhost, turn into a BRR diff --git a/modules/data.atmosphere/R/download.Ameriflux.R b/modules/data.atmosphere/R/download.Ameriflux.R index 5b27591a9ba..95198793c01 100644 --- a/modules/data.atmosphere/R/download.Ameriflux.R +++ b/modules/data.atmosphere/R/download.Ameriflux.R @@ -71,7 +71,7 @@ download.Ameriflux <- function(sitename, outfolder, start_date, end_date, # create array with results row <- year - start_year + 1 results$file[row] <- outputfile - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/download.FACE.R b/modules/data.atmosphere/R/download.FACE.R index a72513ab311..934c2130132 100644 --- a/modules/data.atmosphere/R/download.FACE.R +++ b/modules/data.atmosphere/R/download.FACE.R @@ -38,7 +38,7 @@ download.FACE <- function(sitename, outfolder, start_date, end_date, overwrite = # return file info return(invisible(data.frame(file = out.file, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "application/x-netcdf", formatname = "FACE", startdate = start_date, diff --git a/modules/data.atmosphere/R/download.GLDAS.R b/modules/data.atmosphere/R/download.GLDAS.R index 7c0aaf7cbfc..ff9bf40ebbf 100644 --- a/modules/data.atmosphere/R/download.GLDAS.R +++ b/modules/data.atmosphere/R/download.GLDAS.R @@ -165,7 +165,7 @@ download.GLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon ncdf4::nc_close(loc) results$file[i] <- loc.file - results$host[i] <- fqdn() + results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year, "-01-01 00:00:00") results$enddate[i] <- paste0(year, "-12-31 23:59:59") results$mimetype[i] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/download.Geostreams.R b/modules/data.atmosphere/R/download.Geostreams.R index 21c893d8d71..73a60279234 100644 --- a/modules/data.atmosphere/R/download.Geostreams.R +++ b/modules/data.atmosphere/R/download.Geostreams.R @@ -80,7 +80,7 @@ download.Geostreams <- function(outfolder, sitename, } return(data.frame(file = result_files, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "application/json", formatname = "Geostreams met", startdate = start_date, diff --git a/modules/data.atmosphere/R/download.MACA.R b/modules/data.atmosphere/R/download.MACA.R index 61f62a97ce7..d65aaf276ee 100644 --- a/modules/data.atmosphere/R/download.MACA.R +++ b/modules/data.atmosphere/R/download.MACA.R @@ -142,7 +142,7 @@ download.MACA <- function(outfolder, start_date, end_date, site_id, lat.in, lon. ncdf4::nc_close(loc) results$file[i] <- loc.file - results$host[i] <- fqdn() + results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year,"-01-01 00:00:00") results$enddate[i] <- paste0(year,"-12-31 23:59:59") results$mimetype[i] <- 'application/x-netcdf' diff --git a/modules/data.atmosphere/R/download.MsTMIP_NARR.R b/modules/data.atmosphere/R/download.MsTMIP_NARR.R index d43adee3f97..aa9d770e2a3 100644 --- a/modules/data.atmosphere/R/download.MsTMIP_NARR.R +++ b/modules/data.atmosphere/R/download.MsTMIP_NARR.R @@ -98,7 +98,7 @@ download.MsTMIP_NARR <- function(outfolder, start_date, end_date, site_id, lat.i ncdf4::nc_close(loc) results$file[i] <- loc.file - results$host[i] <- fqdn() + results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year, "-01-01 00:00:00") results$enddate[i] <- paste0(year, "-12-31 23:59:59") results$mimetype[i] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/download.NLDAS.R b/modules/data.atmosphere/R/download.NLDAS.R index daac94caba8..34531161e4b 100644 --- a/modules/data.atmosphere/R/download.NLDAS.R +++ b/modules/data.atmosphere/R/download.NLDAS.R @@ -166,7 +166,7 @@ download.NLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon ncdf4::nc_close(loc) results$file[i] <- loc.file - results$host[i] <- fqdn() + results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year, "-01-01 00:00:00") results$enddate[i] <- paste0(year, "-12-31 23:59:59") results$mimetype[i] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/download.PalEON.R b/modules/data.atmosphere/R/download.PalEON.R index 1c7e6deb411..11796a6e262 100644 --- a/modules/data.atmosphere/R/download.PalEON.R +++ b/modules/data.atmosphere/R/download.PalEON.R @@ -72,7 +72,7 @@ download.PalEON <- function(sitename, outfolder, start_date, end_date, overwrite row <- (which(vlist == v) - 1) * Y * M + (which(ylist == y) - 1) * M + m # print(row) results$file[row] <- dirname(file) - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(y, "-01-01 00:00:00") results$enddate[row] <- paste0(y, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/download.PalEON_ENS.R b/modules/data.atmosphere/R/download.PalEON_ENS.R index fe7aa2f6341..9bb1276f706 100644 --- a/modules/data.atmosphere/R/download.PalEON_ENS.R +++ b/modules/data.atmosphere/R/download.PalEON_ENS.R @@ -43,7 +43,7 @@ download.PalEON_ENS <- function(sitename, outfolder, start_date, end_date, overw }) results[[i]] <- data.frame(file = ens_files, - host = rep(fqdn(),rows), + host = rep(PEcAn.utils::fqdn(),rows), mimetype = rep("application/x-netcdf",rows), formatname = rep("ALMA",rows), ## would really like to switch to CF startdate = paste0(ens_years, "-01-01 00:00:00"), diff --git a/modules/data.atmosphere/R/extract.nc.R b/modules/data.atmosphere/R/extract.nc.R index 22bb0caf01a..9ceabc24cc8 100644 --- a/modules/data.atmosphere/R/extract.nc.R +++ b/modules/data.atmosphere/R/extract.nc.R @@ -53,7 +53,7 @@ extract.nc <- function(in.path, in.prefix, outfolder, start_date, end_date, slat # create array with results row <- year - start_year + 1 results$file[row] <- outfile - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/met.process.R b/modules/data.atmosphere/R/met.process.R index e99e4f9cd06..76ff7bd9d97 100644 --- a/modules/data.atmosphere/R/met.process.R +++ b/modules/data.atmosphere/R/met.process.R @@ -88,7 +88,7 @@ met.process <- function(site, input_met, start_date, end_date, model, con <- bety$con on.exit(db.close(con)) username <- ifelse(is.null(input_met$username), "pecan", input_met$username) - machine.host <- ifelse(host == "localhost" || host$name == "localhost", fqdn(), host$name) + machine.host <- ifelse(host == "localhost" || host$name == "localhost", PEcAn.utils::fqdn(), host$name) machine <- db.query(paste0("SELECT * from machines where hostname = '", machine.host, "'"), con) # special case Brown Dog @@ -335,7 +335,7 @@ browndog.met <- function(browndog, source, site, start_date, end_date, model, di formatname <- "clim" outputfile <- file.path(folder, "sipnet.clim") results <- data.frame(file = outputfile, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/csv", formatname = "Sipnet.climna", startdate = start_date, enddate = end_date, @@ -345,7 +345,7 @@ browndog.met <- function(browndog, source, site, start_date, end_date, model, di formatname <- "ed.zip" outputfile <- file.path(folder, "ed.zip") results <- data.frame(file = file.path(folder, "ED_MET_DRIVER_HEADER"), - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/plain", formatname = "ed.met_driver_header files format", startdate = start_date, enddate = end_date, @@ -355,7 +355,7 @@ browndog.met <- function(browndog, source, site, start_date, end_date, model, di formatname <- "dalec" outputfile <- file.path(folder, "dalec.dat") results <- data.frame(file = outputfile, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/plain", formatname = "DALEC meteorology", startdate = start_date, enddate = end_date, @@ -365,7 +365,7 @@ browndog.met <- function(browndog, source, site, start_date, end_date, model, di formatname <- "linkages" outputfile <- file.path(folder, "climate.txt") results <- data.frame(file = outputfile, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/plain", formatname = "LINKAGES meteorology", startdate = start_date, enddate = end_date, diff --git a/modules/data.atmosphere/R/met2CF.ALMA.R b/modules/data.atmosphere/R/met2CF.ALMA.R index dc275b376bf..6a889846521 100644 --- a/modules/data.atmosphere/R/met2CF.ALMA.R +++ b/modules/data.atmosphere/R/met2CF.ALMA.R @@ -58,7 +58,7 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end row <- year - start_year + 1 results$file[row] <- new.file - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" @@ -224,7 +224,7 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l row <- year - start_year + 1 results$file[row] <- new.file - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" @@ -397,7 +397,7 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove row <- year - start_year + 1 results$file[row] <- new.file - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/met2CF.Ameriflux.R b/modules/data.atmosphere/R/met2CF.Ameriflux.R index be65af3e5ca..3e15983e62e 100644 --- a/modules/data.atmosphere/R/met2CF.Ameriflux.R +++ b/modules/data.atmosphere/R/met2CF.Ameriflux.R @@ -113,7 +113,7 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date # create array with results row <- year - start_year + 1 results$file[row] <- new.file - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/inst/scripts/met2CF.R b/modules/data.atmosphere/inst/scripts/met2CF.R index 350e0df03fd..9d83fd73bfa 100644 --- a/modules/data.atmosphere/inst/scripts/met2CF.R +++ b/modules/data.atmosphere/inst/scripts/met2CF.R @@ -28,7 +28,7 @@ query.base.con <- function(settings,...){ # required steps: # 1) query database using dbfile.input.check # check to see if file exists as an input in dbfile -dbfile.input.check(siteid, startdate, enddate, mimetype, formatname, con, hostname=fqdn()) +dbfile.input.check(siteid, startdate, enddate, mimetype, formatname, con, hostname=PEcAn.utils::fqdn()) # a) query input table select * where input.id = id # i) check to make sure there is only 1 match # b) query dbfiles table to get all rows that match the id @@ -51,5 +51,5 @@ dbfile.input.check(siteid, startdate, enddate, mimetype, formatname, con, hostna # connection, hostname is localhost # insert into db as input -dbfile.input.insert <- function(filename, siteid, startdate, enddate, mimetype, formatname, con, hostname=fqdn()) { +dbfile.input.insert <- function(filename, siteid, startdate, enddate, mimetype, formatname, con, hostname=PEcAn.utils::fqdn()) { diff --git a/modules/data.land/R/ic_process.R b/modules/data.land/R/ic_process.R index 1036c34e51c..3a6a7bd9b05 100644 --- a/modules/data.land/R/ic_process.R +++ b/modules/data.land/R/ic_process.R @@ -69,7 +69,7 @@ ic_process <- function(settings, input, dir, overwrite = FALSE){ # set up host information - machine.host <- ifelse(host == "localhost" || host$name == "localhost", fqdn(), host$name) + machine.host <- ifelse(host == "localhost" || host$name == "localhost", PEcAn.utils::fqdn(), host$name) machine <- db.query(paste0("SELECT * from machines where hostname = '", machine.host, "'"), con) # retrieve model type info diff --git a/modules/data.land/R/write_ic.R b/modules/data.land/R/write_ic.R index 5cbfccc8659..c577b7f9696 100644 --- a/modules/data.land/R/write_ic.R +++ b/modules/data.land/R/write_ic.R @@ -43,7 +43,7 @@ write_ic <- function(in.path, in.name, start_date, end_date, # Build results dataframe for convert.input results <- data.frame(file = out$filepath, - host = c(fqdn()), + host = c(PEcAn.utils::fqdn()), mimetype = out$mimetype, formatname = out$formatname, startdate = start_date, diff --git a/modules/data.remote/R/NLCD.R b/modules/data.remote/R/NLCD.R index 6124772dc03..fe55a2dde7b 100644 --- a/modules/data.remote/R/NLCD.R +++ b/modules/data.remote/R/NLCD.R @@ -28,9 +28,9 @@ download.NLCD <- function(outdir, year = 2011, con = NULL) { if (nrow(chk) > 0) { machines <- db.query(paste("SELECT * from machines where id in (", paste(chk$machine_id, sep = ","), ")"), con) - if (fqdn() %in% machines$hostname) { + if (PEcAn.utils::fqdn() %in% machines$hostname) { ## record already exists on this host - return(chk$id[fqdn() == machines$hostname]) + return(chk$id[PEcAn.utils::fqdn() == machines$hostname]) } } } @@ -84,13 +84,13 @@ extract_NLCD <- function(buffer, coords, data_dir = NULL, con = NULL, year = 201 if (nrow(chk) > 0) { machines <- db.query(paste("SELECT * from machines where id in (", paste(chk$machine_id, sep = ","), ")"), con) - if (fqdn() %in% machines$hostname) { + if (PEcAn.utils::fqdn() %in% machines$hostname) { ## record already exists on this host - data_dir <- chk$file_path[fqdn() == machines$hostname] + data_dir <- chk$file_path[PEcAn.utils::fqdn() == machines$hostname] } else { print(paste0("File not found on localhost, please check database input.id ", input.id, ". You may need to run download.NLCD")) - return(list(chk = chk, machines = machines, localhost = fqdn())) + return(list(chk = chk, machines = machines, localhost = PEcAn.utils::fqdn())) } } else { print(paste("No files found for input.id", input.id)) From b7ab25954bc6ce06fceccd9b566e1fec286b3869 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 22 Aug 2017 19:46:56 -0400 Subject: [PATCH 373/771] Debugging messages --- models/sipnet/R/met2model.SIPNET.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index 76a32aa84e6..2d0b072b399 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -213,14 +213,17 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date ##filter out days not included in start or end date if(year == start_year){ + print(start_date) extra.days <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date if (extra.days > 1){ + PEcAn.logger::logger.info("Subsetting SIPNET met to match start date") start.row <- ((extra.days - 1) * 86400 / dt) + 1 #subtract to include start.date, add to exclude last half hour of day before tmp <- tmp[start.row:nrow(tmp),] } } else if (year == end_year){ extra.days <- length(as.Date(end_date):as.Date(paste0(end_year, "-12-31"))) #extra days length includes the end date if (extra.days > 1){ + PEcAn.logger::logger.info("Subsetting SIPNET met to match end date") end.row <- nrow(tmp) - ((extra.days - 1) * 86400 / dt) #subtract to include end.date tmp <- tmp[1:end.row,] } From 260f0cf82355c97a41c9076be529b284c0da401b Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Wed, 23 Aug 2017 03:31:50 -0500 Subject: [PATCH 374/771] PR#1594 related comments --- db/R/query.dplyr.R | 2 +- shiny/workflowPlot/helper.R | 3 --- shiny/workflowPlot/server.R | 32 +++++++++----------------------- shiny/workflowPlot/ui.R | 5 ++--- 4 files changed, 12 insertions(+), 30 deletions(-) diff --git a/db/R/query.dplyr.R b/db/R/query.dplyr.R index f392886efce..f7f3f01bae1 100644 --- a/db/R/query.dplyr.R +++ b/db/R/query.dplyr.R @@ -141,7 +141,7 @@ get_workflow_ids <- function(bety, session,all.ids=FALSE) { ids <- unlist(query[names(query) == "workflow_id"], use.names = FALSE) } else { # Get all workflow IDs - ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% + ids <- workflows(bety, ensemble = FALSE) %>% distinct(workflow_id) %>% collect %>% .[["workflow_id"]] %>% sort(decreasing = TRUE) # pull(.,workflow_id) %>% sort(decreasing = TRUE) } diff --git a/shiny/workflowPlot/helper.R b/shiny/workflowPlot/helper.R index 7e4cee2ba15..7115f781bca 100644 --- a/shiny/workflowPlot/helper.R +++ b/shiny/workflowPlot/helper.R @@ -11,9 +11,6 @@ isInstalled <- function(mypkg){ is.element(mypkg, installed.packages()[,1]) } # checkAndDownload(c('plotly','scales','dplyr')) -# We can also save the csv on the run from the shiny app as well -# write.csv(inputs_df,file='/home/carya/pecan/shiny/workflowPlot/inputs_df.csv', -# quote = FALSE,sep = ',',col.names = TRUE,row.names=FALSE) # Stashing Code for file upload to shiny app # Based on https://shiny.rstudio.com/gallery/file-upload.html diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index a81e11ced3e..9e178759282 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -103,31 +103,22 @@ server <- shinyServer(function(input, output, session) { # loadObservationData <- function(bety,settings,File_path,File_format){ loadObservationData <- function(bety,inputs_df){ input_id <- inputs_df$input_id - File_format <- getFileFormat(bety,input_id) + # File_format <- getFileFormat(bety,input_id) + File_format <- PEcAn.DB::query.format.vars(bety = bety, input.id = input_id) start.year <- as.numeric(lubridate::year(inputs_df$start_date)) end.year <- as.numeric(lubridate::year(inputs_df$end_date)) - File_path <- inputs_df$filePath + # File_path <- inputs_df$filePath # TODO There is an issue with the db where file names are not saved properly. # To make it work with the VM, uncomment the line below - # File_path <- paste0(inputs_df$filePath,'.csv') + File_path <- paste0(inputs_df$filePath,'.csv') site.id <- inputs_df$site_id site<-PEcAn.DB::query.site(site.id,bety$con) observations<-PEcAn.benchmark::load_data(data.path = File_path, format= File_format, time.row = File_format$time.row, site = site, start_year = start.year, end_year = end.year) return(observations) } - # This function is a wrapper over PEcAn.DB::query.format.vars where - # file format can be retrieved using either by input or format id. - getFileFormat <- function(bety,input.id,format.id=NULL){ - # TODO Retaining the code for getting file format using format Id as in tutorial - # File_format <- PEcAn.DB::query.format.vars(bety = bety, format.id = format.id) - File_format <- PEcAn.DB::query.format.vars(bety = bety, input.id = input.id) - return(File_format) - } getSettingsFromWorkflowId <- function(bety,workflowID){ - basePath <- tbl(bety, 'workflows') %>% dplyr::filter(id %in% workflowID) %>% pull(folder) + basePath <- dplyr::tbl(bety, 'workflows') %>% dplyr::filter(id %in% workflowID) %>% dplyr::pull(folder) configPath <- file.path(basePath, 'pecan.CONFIGS.xml') - # Second way of providing configPath. More of a hack - # configPath <- paste0("~/output/PEcAn_",workflowID,"/pecan.CONFIGS.xml") settings<-PEcAn.settings::read.settings(configPath) return(settings) } @@ -147,14 +138,14 @@ server <- shinyServer(function(input, output, session) { getInputs <- function(bety,site_Id){ # Subsetting the input id list based on the current (VM) machine my_hostname <- PEcAn.utils::fqdn() - my_machine_id <- tbl(bety, 'machines') %>% dplyr::filter(hostname == my_hostname) %>% pull(id) + my_machine_id <- dplyr::tbl(bety, 'machines') %>% dplyr::filter(hostname == my_hostname) %>% dplyr::pull(id) # Inner join 'inputs' table with 'dbfiles' table # inputs_df would contain all the information about the site and input id required for # the tutorial mentioned above to compare model run with actual observations - inputs_df <- tbl(bety, 'dbfiles') %>% + inputs_df <- dplyr::tbl(bety, 'dbfiles') %>% dplyr::filter(container_type == 'Input', machine_id == my_machine_id) %>% - inner_join(tbl(bety, 'inputs') %>% dplyr::filter(site_id %in% site_Id), by = c('container_id' = 'id')) %>% - collect() + dplyr::inner_join(tbl(bety, 'inputs') %>% dplyr::filter(site_id %in% site_Id), by = c('container_id' = 'id')) %>% + dplyr::collect() # Order by container id (==input id) inputs_df <- inputs_df[order(inputs_df$container_id),] # Mutate column as (input id, name) to be shown to the user @@ -214,8 +205,6 @@ server <- shinyServer(function(input, output, session) { # Check if user wants to load external data (==observations) # Similar to using event reactive if (input$load_data>0) { - # Retaining the code for getting file format using formatID - # File_format <- getFileFormat(bety,input$formatID) # Input ID is of the form (input id, Name). Split by space and use the first element inputs_df <- getInputs(bety,c(input$all_site_id)) inputs_df <- inputs_df %>% dplyr::filter(input_selection_list == input$all_input_id) @@ -233,9 +222,6 @@ server <- shinyServer(function(input, output, session) { colnames(aligned_data) <- c("model","observations","Date") # Order returned by align_data # Melt dataframe to plot two types of columns together aligned_data <- reshape2::melt(aligned_data, "Date") - # From the tutorial, if want to plot model vs observations - # plot(aligned_dat$NEE.m, aligned_dat$NEE.o) - # abline(0,1,col="red") ## intercept=0, slope=1 data_geom <- switch(input$data_geom, point = geom_point, line = geom_line) plt <- ggplot(aligned_data, aes(x=Date, y=value, color=variable)) + data_geom() output$outputNoVariableFound <- renderText({ diff --git a/shiny/workflowPlot/ui.R b/shiny/workflowPlot/ui.R index 4ce8cf0fe73..b2a88379968 100644 --- a/shiny/workflowPlot/ui.R +++ b/shiny/workflowPlot/ui.R @@ -1,6 +1,7 @@ library(shiny) +library(plotly) # Helper allows to load functions and variables that could be shared both by server.R and ui.R -source('helper.R') +# source('helper.R') # Define UI ui <- shinyUI(fluidPage( # Application title @@ -35,8 +36,6 @@ ui <- shinyUI(fluidPage( mainPanel( plotlyOutput("outputPlot"), verbatimTextOutput("outputNoVariableFound") - # ,verbatimTextOutput("info") - # ,verbatimTextOutput("info1") ) ) )) From 6be1aa9bea2f8c210c9d365db533a1ab87f39cfa Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Wed, 23 Aug 2017 03:35:27 -0500 Subject: [PATCH 375/771] Correcting file path after testing. --- shiny/workflowPlot/server.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/shiny/workflowPlot/server.R b/shiny/workflowPlot/server.R index 9e178759282..d78bf8774cf 100644 --- a/shiny/workflowPlot/server.R +++ b/shiny/workflowPlot/server.R @@ -107,10 +107,10 @@ server <- shinyServer(function(input, output, session) { File_format <- PEcAn.DB::query.format.vars(bety = bety, input.id = input_id) start.year <- as.numeric(lubridate::year(inputs_df$start_date)) end.year <- as.numeric(lubridate::year(inputs_df$end_date)) - # File_path <- inputs_df$filePath + File_path <- inputs_df$filePath # TODO There is an issue with the db where file names are not saved properly. # To make it work with the VM, uncomment the line below - File_path <- paste0(inputs_df$filePath,'.csv') + # File_path <- paste0(inputs_df$filePath,'.csv') site.id <- inputs_df$site_id site<-PEcAn.DB::query.site(site.id,bety$con) observations<-PEcAn.benchmark::load_data(data.path = File_path, format= File_format, time.row = File_format$time.row, site = site, start_year = start.year, end_year = end.year) From fbc8a25eef2dde5b873555df6a638babb7d6f869 Mon Sep 17 00:00:00 2001 From: shubhamagarwal92 Date: Wed, 23 Aug 2017 04:09:45 -0500 Subject: [PATCH 376/771] Changelog related to PR 1594 --- CHANGELOG.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 88e043ad076..694c61fb61a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,11 +16,17 @@ For more information about this file see also [Keep a Changelog](http://keepacha ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) +- #1594 shiny/workflowPlot Adding interactiveness using ggploltly +- #1594 shiny/workflowPlot Load outputs from multiple runs of the model +- #1594 shiny/workflowPlot Ways to toggle geometries (e.g. geom_point vs. geom_line). +- #1594 shiny/workflowPlot Smoothing using geom_smooth (Slider for specifying moving window width) +- #1594 shiny/workflowPlot Comparing model output vs loaded data according to [tutorial](https://github.com/PecanProject/pecan/blob/develop/documentation/tutorials/AnalyzeOutput/modelVSdata.Rmd) ### Changed - Clean up directory structure: * Move `base` packages (`utils`, `settings`, `db`, `visualizaton`) to a `base` directory, for consistency with `modules` and `models` * Move `logger.*` functions out of the `PEcAn.utils` package and into the `pecan.logger` package +- #1594 shiny/workflowPlot Refactoring of code. `get_workflow_ids` in db/R/query.dplyr.R changed with `ensemble = FALSE`. Also allowing to load all workflow IDs. `load_data_single_run` and `var_names_all` also moved from shiny/workflowPlot/server.R to query.dplyr.R ## [1.5.10] - Prerelease ### Added From e80819d4785ebd1363192aae72eda7f63a4131f2 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 11:14:05 -0400 Subject: [PATCH 377/771] Fix wrong `PEcAn.db` to correct `PEcAn.DB` --- base/db/R/utils.R | 2 +- modules/data.atmosphere/R/met2cf.module.R | 2 +- modules/data.atmosphere/R/met2model.module.R | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/base/db/R/utils.R b/base/db/R/utils.R index 8fc67e99b4e..4d3a3cf1671 100644 --- a/base/db/R/utils.R +++ b/base/db/R/utils.R @@ -116,7 +116,7 @@ db.close <- function(con, showWarnings=TRUE) { id <- attr(con, "pecanid") if (showWarnings && is.null(id)) { - PEcAn.logger::logger.warn("Connection created outside of PEcAn.db package") + PEcAn.logger::logger.warn("Connection created outside of PEcAn.DB package") } else { deleteme <- which(.db.utils$connections$id==id) if (showWarnings && length(deleteme) == 0) { diff --git a/modules/data.atmosphere/R/met2cf.module.R b/modules/data.atmosphere/R/met2cf.module.R index e296701fa43..eedfa23f021 100644 --- a/modules/data.atmosphere/R/met2cf.module.R +++ b/modules/data.atmosphere/R/met2cf.module.R @@ -75,7 +75,7 @@ exact.dates = FALSE) } else if (exists(fcn2)) { fcn <- fcn2 - format <- PEcAn.db::query.format.vars(input.id = input.id, bety = bety) + format <- PEcAn.DB::query.format.vars(input.id = input.id, bety = bety) cf.id <- PEcAn.utils::convert.input(input.id = input.id, outfolder = outfolder, formatname = formatname, diff --git a/modules/data.atmosphere/R/met2model.module.R b/modules/data.atmosphere/R/met2model.module.R index 147d4b2f202..13a211b24fb 100644 --- a/modules/data.atmosphere/R/met2model.module.R +++ b/modules/data.atmosphere/R/met2model.module.R @@ -3,7 +3,7 @@ browndog, new.site, overwrite = FALSE, exact.dates,spin) { # Determine output format name and mimetype - model_info <- PEcAn.db::db.query(paste0("SELECT f.name, f.id, mt.type_string from modeltypes as m", " join modeltypes_formats as mf on m.id = mf.modeltype_id", + model_info <- PEcAn.DB::db.query(paste0("SELECT f.name, f.id, mt.type_string 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", " join mimetypes as mt on f.mimetype_id = mt.id", " where m.name = '", model, "' AND mf.tag='met'"), con) From 133675b6f6453487690aeb2ae86370364a26065e Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 11:19:59 -0400 Subject: [PATCH 378/771] Prepend `PEcAn.utils::` to `fqdn()` --- base/db/R/query.file.path.R | 2 +- base/db/tests/testthat/db.setup.R | 2 +- base/settings/tests/testthat/get.test.settings.R | 4 ++-- models/biocro/R/met2model.BIOCRO.R | 2 +- models/dalec/R/met2model.DALEC.R | 2 +- models/ed/R/met2model.ED2.R | 2 +- models/fates/R/met2model.FATES.R | 2 +- models/linkages/R/met2model.LINKAGES.R | 2 +- models/lpjguess/R/met2model.LPJGUESS.R | 2 +- models/maat/R/met2model.MAAT.R | 2 +- models/maespa/R/met2model.MAESPA.R | 2 +- models/sipnet/R/met2model.SIPNET.R | 2 +- modules/benchmark/R/create_BRR.R | 8 ++++---- modules/data.atmosphere/R/download.Ameriflux.R | 2 +- modules/data.atmosphere/R/download.FACE.R | 2 +- modules/data.atmosphere/R/download.GLDAS.R | 2 +- modules/data.atmosphere/R/download.Geostreams.R | 2 +- modules/data.atmosphere/R/download.MACA.R | 2 +- modules/data.atmosphere/R/download.MsTMIP_NARR.R | 2 +- modules/data.atmosphere/R/download.NLDAS.R | 2 +- modules/data.atmosphere/R/download.PalEON.R | 2 +- modules/data.atmosphere/R/download.PalEON_ENS.R | 2 +- modules/data.atmosphere/R/extract.nc.R | 2 +- modules/data.atmosphere/R/met.process.R | 10 +++++----- modules/data.atmosphere/R/met2CF.ALMA.R | 6 +++--- modules/data.atmosphere/R/met2CF.Ameriflux.R | 2 +- modules/data.atmosphere/R/met2CF.csv.R | 2 +- modules/data.atmosphere/inst/scripts/met2CF.R | 4 ++-- modules/data.land/R/ic_process.R | 4 ++-- modules/data.land/R/write_ic.R | 2 +- modules/data.remote/R/NLCD.R | 10 +++++----- tests/interactive-workflow.R | 2 +- 32 files changed, 48 insertions(+), 48 deletions(-) diff --git a/base/db/R/query.file.path.R b/base/db/R/query.file.path.R index 69cd066d794..de8e4f66680 100644 --- a/base/db/R/query.file.path.R +++ b/base/db/R/query.file.path.R @@ -7,7 +7,7 @@ ##' ##' @author Betsy Cowdery query.file.path <- function(input.id, host_name, con){ - machine.host <- ifelse(host_name == "localhost",fqdn(),host_name) + machine.host <- ifelse(host_name == "localhost", PEcAn.utils::fqdn(), host_name) machine = db.query(paste0("SELECT * from machines where hostname = '",machine.host,"'"),con) dbfile = db.query(paste("SELECT file_name,file_path from dbfiles where container_id =",input.id," and container_type = 'Input' and machine_id =",machine$id),con) path <- file.path(dbfile$file_path,dbfile$file_name) diff --git a/base/db/tests/testthat/db.setup.R b/base/db/tests/testthat/db.setup.R index efc1b7876e7..5cfa59f3352 100644 --- a/base/db/tests/testthat/db.setup.R +++ b/base/db/tests/testthat/db.setup.R @@ -5,7 +5,7 @@ check_db_test <- function() { con <- NULL if (!is_ci) { try({ - if(fqdn() == "pecan2.bu.edu") { + if(PEcAn.utils::fqdn() == "pecan2.bu.edu") { con <- db.open(list(host="psql-pecan.bu.edu", driver = "PostgreSQL", user = "bety", dbname = "bety", password = "bety")) } else { con <- db.open(list(host="localhost", driver = "PostgreSQL", user = "bety", dbname = "bety", password = "bety")) diff --git a/base/settings/tests/testthat/get.test.settings.R b/base/settings/tests/testthat/get.test.settings.R index af082668bf0..d02f25b83ac 100644 --- a/base/settings/tests/testthat/get.test.settings.R +++ b/base/settings/tests/testthat/get.test.settings.R @@ -1,7 +1,7 @@ .get.test.settings = function() { settings <- NULL try({ - if(fqdn() == "pecan2.bu.edu") { + if(PEcAn.utils::fqdn() == "pecan2.bu.edu") { settings <- read.settings("testinput.pecan2.bu.edu.xml") } else { settings <- read.settings("testinput.xml") @@ -13,4 +13,4 @@ skip("Can't get a valid test Settings right now. Skipping test. ") } return(settings) -} \ No newline at end of file +} diff --git a/models/biocro/R/met2model.BIOCRO.R b/models/biocro/R/met2model.BIOCRO.R index 2165e0245b8..47d6b97be71 100644 --- a/models/biocro/R/met2model.BIOCRO.R +++ b/models/biocro/R/met2model.BIOCRO.R @@ -83,7 +83,7 @@ met2model.BIOCRO <- function(in.path, in.prefix, outfolder, overwrite = FALSE, res[[as.character(year)]] <- data.frame( file = csvfile, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/csv", formatname = "biocromet", startdate = yrstart, diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index d346b651db8..952901c41a5 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -65,7 +65,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, out.file.full <- file.path(outfolder, out.file) results <- data.frame(file = c(out.file.full), - host = c(fqdn()), + host = c(PEcAn.utils::fqdn()), mimetype = c("text/plain"), formatname = c("DALEC meteorology"), startdate = c(start_date), diff --git a/models/ed/R/met2model.ED2.R b/models/ed/R/met2model.ED2.R index 97dbe2cb787..e5b0a2f7920 100644 --- a/models/ed/R/met2model.ED2.R +++ b/models/ed/R/met2model.ED2.R @@ -46,7 +46,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l met_header <- file.path(met_folder, "ED_MET_DRIVER_HEADER") results <- data.frame(file = c(met_header), - host = c(fqdn()), + host = c(PEcAn.utils::fqdn()), mimetype = c("text/plain"), formatname = c("ed.met_driver_header files format"), startdate = c(start_date), diff --git a/models/fates/R/met2model.FATES.R b/models/fates/R/met2model.FATES.R index b3b71dc1129..592cb169647 100644 --- a/models/fates/R/met2model.FATES.R +++ b/models/fates/R/met2model.FATES.R @@ -154,7 +154,7 @@ met2model.FATES <- function(in.path, in.prefix, outfolder, start_date, end_date, PEcAn.logger::logger.info("Done with met2model.FATES") return(data.frame(file = paste0(outfolder, "/"), - host = c(fqdn()), + host = c(PEcAn.utils::fqdn()), mimetype = c("application/x-netcdf"), formatname = c("CLM met"), startdate = c(start_date), diff --git a/models/linkages/R/met2model.LINKAGES.R b/models/linkages/R/met2model.LINKAGES.R index e421459ea89..11aa102bf54 100644 --- a/models/linkages/R/met2model.LINKAGES.R +++ b/models/linkages/R/met2model.LINKAGES.R @@ -31,7 +31,7 @@ met2model.LINKAGES <- function(in.path, in.prefix, outfolder, start_date, end_da # strptime(end_date, '%Y-%m-%d'), 'dat', sep='.')) results <- data.frame(file = c(out.file), - host = c(fqdn()), + host = c(PEcAn.utils::fqdn()), mimetype = c("text/plain"), formatname = c("LINKAGES meteorology"), startdate = c(start_date), diff --git a/models/lpjguess/R/met2model.LPJGUESS.R b/models/lpjguess/R/met2model.LPJGUESS.R index bfbbf68c3d9..6d7e7d021a9 100644 --- a/models/lpjguess/R/met2model.LPJGUESS.R +++ b/models/lpjguess/R/met2model.LPJGUESS.R @@ -56,7 +56,7 @@ met2model.LPJGUESS <- function(in.path, in.prefix, outfolder, start_date, end_da } results <- data.frame(file = unlist(out.files.full), - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "application/x-netcdf", formatname = "lpj-guess.metfile", startdate = start_date, diff --git a/models/maat/R/met2model.MAAT.R b/models/maat/R/met2model.MAAT.R index 935fe28bc0e..6f283579558 100644 --- a/models/maat/R/met2model.MAAT.R +++ b/models/maat/R/met2model.MAAT.R @@ -52,7 +52,7 @@ met2model.MAAT <- function(in.path, in.prefix, outfolder, start_date, end_date, out.file.full <- file.path(outfolder, out.file) results <- data.frame(file = out.file.full, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/csv", formatname = "MAAT meteorology", startdate = start_date, diff --git a/models/maespa/R/met2model.MAESPA.R b/models/maespa/R/met2model.MAESPA.R index 0b05aae4881..71151215247 100755 --- a/models/maespa/R/met2model.MAESPA.R +++ b/models/maespa/R/met2model.MAESPA.R @@ -45,7 +45,7 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date out.file.full <- file.path(outfolder, out.file) results <- data.frame(file = out.file.full, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/plain", formatname = "maespa.met", startdate = start_date, diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index 01e67940b6d..856a6acf769 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -39,7 +39,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date out.file.full <- file.path(outfolder, out.file) results <- data.frame(file = out.file.full, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/csv", formatname = "Sipnet.climna", startdate = start_date, diff --git a/modules/benchmark/R/create_BRR.R b/modules/benchmark/R/create_BRR.R index 1084362b6dc..f850c8ae566 100644 --- a/modules/benchmark/R/create_BRR.R +++ b/modules/benchmark/R/create_BRR.R @@ -11,9 +11,9 @@ create_BRR <- function(ens_wf, con, user_id = ""){ - cnd1 <- ens_wf$hostname == fqdn() - cnd2 <- ens_wf$hostname == 'test-pecan.bu.edu' & fqdn() == 'pecan2.bu.edu' - cnd3 <- ens_wf$hostname == 'pecan2.bu.edu' & fqdn() == 'test-pecan.bu.edu' + cnd1 <- ens_wf$hostname == PEcAn.utils::fqdn() + cnd2 <- ens_wf$hostname == 'test-pecan.bu.edu' & PEcAn.utils::fqdn() == 'pecan2.bu.edu' + cnd3 <- ens_wf$hostname == 'pecan2.bu.edu' & PEcAn.utils::fqdn() == 'test-pecan.bu.edu' db.query <- PEcAn.DB::db.query # if(cnd1|cnd2|cnd3){ # If the ensemble run was done on localhost, turn into a BRR @@ -46,4 +46,4 @@ create_BRR <- function(ens_wf, con, user_id = ""){ return(BRR) # }else{logger.error(sprintf("Cannot create a benchmark reference run for a run on hostname: %s", # ens_wf$hostname))} -} #create_BRR \ No newline at end of file +} #create_BRR diff --git a/modules/data.atmosphere/R/download.Ameriflux.R b/modules/data.atmosphere/R/download.Ameriflux.R index 5b27591a9ba..95198793c01 100644 --- a/modules/data.atmosphere/R/download.Ameriflux.R +++ b/modules/data.atmosphere/R/download.Ameriflux.R @@ -71,7 +71,7 @@ download.Ameriflux <- function(sitename, outfolder, start_date, end_date, # create array with results row <- year - start_year + 1 results$file[row] <- outputfile - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/download.FACE.R b/modules/data.atmosphere/R/download.FACE.R index a72513ab311..934c2130132 100644 --- a/modules/data.atmosphere/R/download.FACE.R +++ b/modules/data.atmosphere/R/download.FACE.R @@ -38,7 +38,7 @@ download.FACE <- function(sitename, outfolder, start_date, end_date, overwrite = # return file info return(invisible(data.frame(file = out.file, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "application/x-netcdf", formatname = "FACE", startdate = start_date, diff --git a/modules/data.atmosphere/R/download.GLDAS.R b/modules/data.atmosphere/R/download.GLDAS.R index 7c0aaf7cbfc..ff9bf40ebbf 100644 --- a/modules/data.atmosphere/R/download.GLDAS.R +++ b/modules/data.atmosphere/R/download.GLDAS.R @@ -165,7 +165,7 @@ download.GLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon ncdf4::nc_close(loc) results$file[i] <- loc.file - results$host[i] <- fqdn() + results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year, "-01-01 00:00:00") results$enddate[i] <- paste0(year, "-12-31 23:59:59") results$mimetype[i] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/download.Geostreams.R b/modules/data.atmosphere/R/download.Geostreams.R index 21c893d8d71..73a60279234 100644 --- a/modules/data.atmosphere/R/download.Geostreams.R +++ b/modules/data.atmosphere/R/download.Geostreams.R @@ -80,7 +80,7 @@ download.Geostreams <- function(outfolder, sitename, } return(data.frame(file = result_files, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "application/json", formatname = "Geostreams met", startdate = start_date, diff --git a/modules/data.atmosphere/R/download.MACA.R b/modules/data.atmosphere/R/download.MACA.R index 61f62a97ce7..d65aaf276ee 100644 --- a/modules/data.atmosphere/R/download.MACA.R +++ b/modules/data.atmosphere/R/download.MACA.R @@ -142,7 +142,7 @@ download.MACA <- function(outfolder, start_date, end_date, site_id, lat.in, lon. ncdf4::nc_close(loc) results$file[i] <- loc.file - results$host[i] <- fqdn() + results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year,"-01-01 00:00:00") results$enddate[i] <- paste0(year,"-12-31 23:59:59") results$mimetype[i] <- 'application/x-netcdf' diff --git a/modules/data.atmosphere/R/download.MsTMIP_NARR.R b/modules/data.atmosphere/R/download.MsTMIP_NARR.R index d43adee3f97..aa9d770e2a3 100644 --- a/modules/data.atmosphere/R/download.MsTMIP_NARR.R +++ b/modules/data.atmosphere/R/download.MsTMIP_NARR.R @@ -98,7 +98,7 @@ download.MsTMIP_NARR <- function(outfolder, start_date, end_date, site_id, lat.i ncdf4::nc_close(loc) results$file[i] <- loc.file - results$host[i] <- fqdn() + results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year, "-01-01 00:00:00") results$enddate[i] <- paste0(year, "-12-31 23:59:59") results$mimetype[i] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/download.NLDAS.R b/modules/data.atmosphere/R/download.NLDAS.R index daac94caba8..34531161e4b 100644 --- a/modules/data.atmosphere/R/download.NLDAS.R +++ b/modules/data.atmosphere/R/download.NLDAS.R @@ -166,7 +166,7 @@ download.NLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon ncdf4::nc_close(loc) results$file[i] <- loc.file - results$host[i] <- fqdn() + results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year, "-01-01 00:00:00") results$enddate[i] <- paste0(year, "-12-31 23:59:59") results$mimetype[i] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/download.PalEON.R b/modules/data.atmosphere/R/download.PalEON.R index 1c7e6deb411..11796a6e262 100644 --- a/modules/data.atmosphere/R/download.PalEON.R +++ b/modules/data.atmosphere/R/download.PalEON.R @@ -72,7 +72,7 @@ download.PalEON <- function(sitename, outfolder, start_date, end_date, overwrite row <- (which(vlist == v) - 1) * Y * M + (which(ylist == y) - 1) * M + m # print(row) results$file[row] <- dirname(file) - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(y, "-01-01 00:00:00") results$enddate[row] <- paste0(y, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/download.PalEON_ENS.R b/modules/data.atmosphere/R/download.PalEON_ENS.R index fe7aa2f6341..9bb1276f706 100644 --- a/modules/data.atmosphere/R/download.PalEON_ENS.R +++ b/modules/data.atmosphere/R/download.PalEON_ENS.R @@ -43,7 +43,7 @@ download.PalEON_ENS <- function(sitename, outfolder, start_date, end_date, overw }) results[[i]] <- data.frame(file = ens_files, - host = rep(fqdn(),rows), + host = rep(PEcAn.utils::fqdn(),rows), mimetype = rep("application/x-netcdf",rows), formatname = rep("ALMA",rows), ## would really like to switch to CF startdate = paste0(ens_years, "-01-01 00:00:00"), diff --git a/modules/data.atmosphere/R/extract.nc.R b/modules/data.atmosphere/R/extract.nc.R index 22bb0caf01a..9ceabc24cc8 100644 --- a/modules/data.atmosphere/R/extract.nc.R +++ b/modules/data.atmosphere/R/extract.nc.R @@ -53,7 +53,7 @@ extract.nc <- function(in.path, in.prefix, outfolder, start_date, end_date, slat # create array with results row <- year - start_year + 1 results$file[row] <- outfile - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/met.process.R b/modules/data.atmosphere/R/met.process.R index e99e4f9cd06..76ff7bd9d97 100644 --- a/modules/data.atmosphere/R/met.process.R +++ b/modules/data.atmosphere/R/met.process.R @@ -88,7 +88,7 @@ met.process <- function(site, input_met, start_date, end_date, model, con <- bety$con on.exit(db.close(con)) username <- ifelse(is.null(input_met$username), "pecan", input_met$username) - machine.host <- ifelse(host == "localhost" || host$name == "localhost", fqdn(), host$name) + machine.host <- ifelse(host == "localhost" || host$name == "localhost", PEcAn.utils::fqdn(), host$name) machine <- db.query(paste0("SELECT * from machines where hostname = '", machine.host, "'"), con) # special case Brown Dog @@ -335,7 +335,7 @@ browndog.met <- function(browndog, source, site, start_date, end_date, model, di formatname <- "clim" outputfile <- file.path(folder, "sipnet.clim") results <- data.frame(file = outputfile, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/csv", formatname = "Sipnet.climna", startdate = start_date, enddate = end_date, @@ -345,7 +345,7 @@ browndog.met <- function(browndog, source, site, start_date, end_date, model, di formatname <- "ed.zip" outputfile <- file.path(folder, "ed.zip") results <- data.frame(file = file.path(folder, "ED_MET_DRIVER_HEADER"), - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/plain", formatname = "ed.met_driver_header files format", startdate = start_date, enddate = end_date, @@ -355,7 +355,7 @@ browndog.met <- function(browndog, source, site, start_date, end_date, model, di formatname <- "dalec" outputfile <- file.path(folder, "dalec.dat") results <- data.frame(file = outputfile, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/plain", formatname = "DALEC meteorology", startdate = start_date, enddate = end_date, @@ -365,7 +365,7 @@ browndog.met <- function(browndog, source, site, start_date, end_date, model, di formatname <- "linkages" outputfile <- file.path(folder, "climate.txt") results <- data.frame(file = outputfile, - host = fqdn(), + host = PEcAn.utils::fqdn(), mimetype = "text/plain", formatname = "LINKAGES meteorology", startdate = start_date, enddate = end_date, diff --git a/modules/data.atmosphere/R/met2CF.ALMA.R b/modules/data.atmosphere/R/met2CF.ALMA.R index dc275b376bf..6a889846521 100644 --- a/modules/data.atmosphere/R/met2CF.ALMA.R +++ b/modules/data.atmosphere/R/met2CF.ALMA.R @@ -58,7 +58,7 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end row <- year - start_year + 1 results$file[row] <- new.file - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" @@ -224,7 +224,7 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l row <- year - start_year + 1 results$file[row] <- new.file - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" @@ -397,7 +397,7 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove row <- year - start_year + 1 results$file[row] <- new.file - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/met2CF.Ameriflux.R b/modules/data.atmosphere/R/met2CF.Ameriflux.R index be65af3e5ca..3e15983e62e 100644 --- a/modules/data.atmosphere/R/met2CF.Ameriflux.R +++ b/modules/data.atmosphere/R/met2CF.Ameriflux.R @@ -113,7 +113,7 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date # create array with results row <- year - start_year + 1 results$file[row] <- new.file - results$host[row] <- fqdn() + results$host[row] <- PEcAn.utils::fqdn() results$startdate[row] <- paste0(year, "-01-01 00:00:00") results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" diff --git a/modules/data.atmosphere/R/met2CF.csv.R b/modules/data.atmosphere/R/met2CF.csv.R index 20b8dc03568..c8c69ada5d6 100644 --- a/modules/data.atmosphere/R/met2CF.csv.R +++ b/modules/data.atmosphere/R/met2CF.csv.R @@ -96,7 +96,7 @@ met2CF.csv <- function(in.path, in.prefix, outfolder, start_date, end_date, form ".nc") results$file <- all_files - results$host <- fqdn() + results$host <- PEcAn.utils::fqdn() # The For below loop updates the start/end date once file is read in results$startdate <- paste0(all_years, "-01-01 00:00:00") diff --git a/modules/data.atmosphere/inst/scripts/met2CF.R b/modules/data.atmosphere/inst/scripts/met2CF.R index 350e0df03fd..a0ec59ea303 100644 --- a/modules/data.atmosphere/inst/scripts/met2CF.R +++ b/modules/data.atmosphere/inst/scripts/met2CF.R @@ -28,7 +28,7 @@ query.base.con <- function(settings,...){ # required steps: # 1) query database using dbfile.input.check # check to see if file exists as an input in dbfile -dbfile.input.check(siteid, startdate, enddate, mimetype, formatname, con, hostname=fqdn()) +dbfile.input.check(siteid, startdate, enddate, mimetype, formatname, con, hostname = PEcAn.utils::fqdn()) # a) query input table select * where input.id = id # i) check to make sure there is only 1 match # b) query dbfiles table to get all rows that match the id @@ -51,5 +51,5 @@ dbfile.input.check(siteid, startdate, enddate, mimetype, formatname, con, hostna # connection, hostname is localhost # insert into db as input -dbfile.input.insert <- function(filename, siteid, startdate, enddate, mimetype, formatname, con, hostname=fqdn()) { +dbfile.input.insert <- function(filename, siteid, startdate, enddate, mimetype, formatname, con, hostname=PEcAn.utils::fqdn()) { diff --git a/modules/data.land/R/ic_process.R b/modules/data.land/R/ic_process.R index 1036c34e51c..2a9e4784f0c 100644 --- a/modules/data.land/R/ic_process.R +++ b/modules/data.land/R/ic_process.R @@ -69,7 +69,7 @@ ic_process <- function(settings, input, dir, overwrite = FALSE){ # set up host information - machine.host <- ifelse(host == "localhost" || host$name == "localhost", fqdn(), host$name) + machine.host <- ifelse(host == "localhost" || host$name == "localhost", PEcAn.utils::fqdn(), host$name) machine <- db.query(paste0("SELECT * from machines where hostname = '", machine.host, "'"), con) # retrieve model type info @@ -172,4 +172,4 @@ ic_process <- function(settings, input, dir, overwrite = FALSE){ return(settings) -} # ic_process \ No newline at end of file +} # ic_process diff --git a/modules/data.land/R/write_ic.R b/modules/data.land/R/write_ic.R index 5cbfccc8659..c577b7f9696 100644 --- a/modules/data.land/R/write_ic.R +++ b/modules/data.land/R/write_ic.R @@ -43,7 +43,7 @@ write_ic <- function(in.path, in.name, start_date, end_date, # Build results dataframe for convert.input results <- data.frame(file = out$filepath, - host = c(fqdn()), + host = c(PEcAn.utils::fqdn()), mimetype = out$mimetype, formatname = out$formatname, startdate = start_date, diff --git a/modules/data.remote/R/NLCD.R b/modules/data.remote/R/NLCD.R index 6124772dc03..fe55a2dde7b 100644 --- a/modules/data.remote/R/NLCD.R +++ b/modules/data.remote/R/NLCD.R @@ -28,9 +28,9 @@ download.NLCD <- function(outdir, year = 2011, con = NULL) { if (nrow(chk) > 0) { machines <- db.query(paste("SELECT * from machines where id in (", paste(chk$machine_id, sep = ","), ")"), con) - if (fqdn() %in% machines$hostname) { + if (PEcAn.utils::fqdn() %in% machines$hostname) { ## record already exists on this host - return(chk$id[fqdn() == machines$hostname]) + return(chk$id[PEcAn.utils::fqdn() == machines$hostname]) } } } @@ -84,13 +84,13 @@ extract_NLCD <- function(buffer, coords, data_dir = NULL, con = NULL, year = 201 if (nrow(chk) > 0) { machines <- db.query(paste("SELECT * from machines where id in (", paste(chk$machine_id, sep = ","), ")"), con) - if (fqdn() %in% machines$hostname) { + if (PEcAn.utils::fqdn() %in% machines$hostname) { ## record already exists on this host - data_dir <- chk$file_path[fqdn() == machines$hostname] + data_dir <- chk$file_path[PEcAn.utils::fqdn() == machines$hostname] } else { print(paste0("File not found on localhost, please check database input.id ", input.id, ". You may need to run download.NLCD")) - return(list(chk = chk, machines = machines, localhost = fqdn())) + return(list(chk = chk, machines = machines, localhost = PEcAn.utils::fqdn())) } } else { print(paste("No files found for input.id", input.id)) diff --git a/tests/interactive-workflow.R b/tests/interactive-workflow.R index 8026efa69b3..d5883428523 100644 --- a/tests/interactive-workflow.R +++ b/tests/interactive-workflow.R @@ -111,7 +111,7 @@ status.start("FINISHED") if (!is.null(settings$email) && !is.null(settings$email$to) && (settings$email$to != "")) { sendmail(settings$email$from, settings$email$to, paste0("Workflow has finished executing at ", date()), - paste0("You can find the results on ", fqdn(), " in ", normalizePath(settings$outdir))) + paste0("You can find the results on ", PEcAn.utils::fqdn(), " in ", normalizePath(settings$outdir))) } # write end time in database From 3e5e640944c2067170550372fb08b7ed36a1828f Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 23 Aug 2017 22:08:31 +0530 Subject: [PATCH 379/771] minor fixes --- web/setups/sync.php | 3 ++- web/setups/synccorn.php | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/web/setups/sync.php b/web/setups/sync.php index c67e05d9e58..00b58572be1 100644 --- a/web/setups/sync.php +++ b/web/setups/sync.php @@ -17,6 +17,7 @@ $want_id = fgets ($flagfile); fclose($flagfile); -exec('../../scripts/load.bety.sh', $outcome, $status); +$cmd = '../../scripts/load.bety.sh -r ' . $want_id; +exec($cmd, $outcome, $status); ?> diff --git a/web/setups/synccorn.php b/web/setups/synccorn.php index 8fa62226903..1477ef2f4b9 100644 --- a/web/setups/synccorn.php +++ b/web/setups/synccorn.php @@ -8,7 +8,7 @@ * http://opensource.ncsa.illinois.edu/license.html */ -// cornjob +// cronjob if (file_exists ("syncflag.txt") == true){ include 'sync.php'; From 1b2291905a93601728cbd83099dc79b1893be399 Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 23 Aug 2017 22:11:39 +0530 Subject: [PATCH 380/771] removed blank feedback page --- web/setups/feedback.php | 18 ------------------ 1 file changed, 18 deletions(-) delete mode 100644 web/setups/feedback.php diff --git a/web/setups/feedback.php b/web/setups/feedback.php deleted file mode 100644 index 8560446e554..00000000000 --- a/web/setups/feedback.php +++ /dev/null @@ -1,18 +0,0 @@ - From 19cc0a9b9f596897f9522a92a6563b4037d85baa Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 23 Aug 2017 22:13:29 +0530 Subject: [PATCH 381/771] Typo fix in clientsyncscript.php --- web/setups/clientsyncscript.php | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/web/setups/clientsyncscript.php b/web/setups/clientsyncscript.php index f6f38ddcfac..d561c75774d 100644 --- a/web/setups/clientsyncscript.php +++ b/web/setups/clientsyncscript.php @@ -32,7 +32,7 @@ if ($curl_response === false) { $info = curl_getinfo($curl); curl_close($curl); - die('error occured during curl exec. Additioanl info: ' . var_export($info)); + die('error occured during curl exec. Additional info: ' . var_export($info)); } // close curl From d93f1b395279119cd0849c0bc34c121f7bf2edda Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 11:46:17 -0500 Subject: [PATCH 382/771] DB: Cleanup dbfiles.R --- base/db/R/dbfiles.R | 456 ++++++++++++++++++++++++++------------------ 1 file changed, 269 insertions(+), 187 deletions(-) diff --git a/base/db/R/dbfiles.R b/base/db/R/dbfiles.R index 9ad11d724e3..8649ec58567 100644 --- a/base/db/R/dbfiles.R +++ b/base/db/R/dbfiles.R @@ -31,91 +31,109 @@ ##' \dontrun{ ##' dbfile.input.insert('trait.data.Rdata', siteid, startdate, enddate, 'application/x-RData', 'traits', dbcon) ##' } -dbfile.input.insert <- function(in.path, in.prefix, siteid, startdate, enddate, mimetype, formatname, parentid=NA, con, hostname=PEcAn.utils::fqdn(), allow.conflicting.dates=FALSE) { +dbfile.input.insert <- function(in.path, in.prefix, siteid, startdate, enddate, mimetype, formatname, + parentid=NA, con, hostname=PEcAn.utils::fqdn(), allow.conflicting.dates=FALSE) { name <- basename(in.path) - filename <- file.path(in.path, in.prefix) - - if (hostname == "localhost") hostname <- PEcAn.utils::fqdn(); - + hostname <- default_hostname(hostname) + # find mimetype, if it does not exist, it will create one - mimetypeid <- get.id("mimetypes", "type_string", mimetype, con, create=TRUE) - + mimetypeid <- get.id("mimetypes", "type_string", mimetype, con, create = TRUE) + # find appropriate format, create if it does not exist - formatid <- get.id("formats", colname = c('mimetype_id', 'name'), - value = c(mimetypeid, formatname), con, create=TRUE, dates=TRUE) - + formatid <- get.id( + table = "formats", + colnames = c('mimetype_id', 'name'), + values = c(mimetypeid, formatname), + con = con, + create = TRUE, + dates = TRUE + ) + # setup parent part of query if specified if (is.na(parentid)) { parent <- "" } else { parent <- paste0(" AND parent_id=", parentid) } - + # find appropriate input, if not in database, insert new input - existing.input <- db.query(paste0( - "SELECT * FROM inputs WHERE site_id=", siteid, " AND name= '", name, - "' AND format_id=", formatid, parent), con) - + existing.input <- db.query( + query = paste0( + "SELECT * FROM inputs WHERE site_id=", siteid, + " AND name= '", name, + "' AND format_id=", formatid, + parent + ), + con = con + ) + inputid <- NULL if (nrow(existing.input) > 0) { # Convert dates to Date objects and strip all time zones (DB values are timezone-free) - startdate <- lubridate::force_tz(lubridate::as_date(startdate), 'UTC') - enddate <- lubridate::force_tz(lubridate::as_date(enddate), 'UTC') - existing.input$start_date <- lubridate::force_tz(lubridate::as_date(existing.input$start_date), 'UTC') - existing.input$end_date <- lubridate::force_tz(lubridate::as_date(existing.input$end_date), 'UTC') - - for(i in 1:nrow(existing.input)) { + startdate <- lubridate::force_tz(time = lubridate::as_date(startdate), tzone = 'UTC') + enddate <- lubridate::force_tz(time = lubridate::as_date(enddate), tzone = 'UTC') + existing.input$start_date <- lubridate::force_tz(time = lubridate::as_date(existing.input$start_date), tzone = 'UTC') + existing.input$end_date <- lubridate::force_tz(time = lubridate::as_date(existing.input$end_date), tzone = 'UTC') + + for (i in seq_len(nrow(existing.input))) { existing.input.i <- existing.input[i,] - if(existing.input.i$start_date == startdate && existing.input.i$end_date == enddate) { + if (existing.input.i$start_date == startdate && existing.input.i$end_date == enddate) { inputid <- existing.input.i[['id']] break } } - - if(is.null(inputid) && !allow.conflicting.dates) { - print(existing.input, digits=10) + + if (is.null(inputid) && !allow.conflicting.dates) { + print(existing.input, digits = 10) PEcAn.logger::logger.error(paste0( "Duplicate inputs (in terms of site_id, name, and format_id) with differing ", "start/end dates are not allowed. The existing input record printed above would ", - " conflict with the one to be inserted, which has requested start/end dates of ", - startdate, "/", enddate, "Please resolve this conflict or set", + " conflict with the one to be inserted, which has requested start/end dates of ", + startdate, "/", enddate, "Please resolve this conflict or set", "allow.conflicting.dates=TRUE if you want to allow multiple input records ", " with different dates." )) return(NULL) } - } - - if(is.null(inputid)) { - # Either there was no existing input, or there was but the dates don't match and - # allow.conflicting.dates==TRUE. So, insert new input record. - if(parent == ""){ + } + + if (is.null(inputid)) { + # Either there was no existing input, or there was but the dates don't match and + # allow.conflicting.dates==TRUE. So, insert new input record. + if (parent == "") { cmd <- paste0("INSERT INTO inputs ", "(site_id, format_id, created_at, updated_at, start_date, end_date, name) VALUES (", - siteid, ", ", formatid, ", NOW(), NOW(), '", startdate, "', '", enddate,"','", name, "')") + siteid, ", ", formatid, ", NOW(), NOW(), '", startdate, "', '", enddate, "','", name, "')") } else { cmd <- paste0("INSERT INTO inputs ", "(site_id, format_id, created_at, updated_at, start_date, end_date, name, parent_id) VALUES (", - siteid, ", ", formatid, ", NOW(), NOW(), '", startdate, "', '", enddate,"','", name, "',",parentid,")") + siteid, ", ", formatid, ", NOW(), NOW(), '", startdate, "', '", enddate, "','", name, "',", parentid, ")") } - db.query(cmd, con) - - inputid <- db.query(paste0("SELECT id FROM inputs WHERE site_id=", siteid, - " AND format_id=", formatid, " AND start_date='", startdate, - "' AND end_date='", enddate, "'" , parent, ";"), con)[['id']] - } - + db.query(query = cmd, con = con) + + inputid <- db.query( + query = paste0( + "SELECT id FROM inputs WHERE site_id=", siteid, + " AND format_id=", formatid, + " AND start_date='", startdate, + "' AND end_date='", enddate, + "'" , parent, ";" + ), + con = con + )[['id']] + } + # find appropriate dbfile, if not in database, insert new dbfile - dbfile <- dbfile.check('Input', inputid, con, hostname) - - if(nrow(dbfile) > 0) { - if(nrow(dbfile) > 1) { + dbfile <- dbfile.check(type = 'Input', container.id = inputid, con = con, hostname = hostname) + + if (nrow(dbfile) > 0) { + if (nrow(dbfile) > 1) { print(dbfile) PEcAn.logger::logger.warn("Multiple dbfiles found. Using last.") dbfile <- dbfile[nrow(dbfile),] } - if(dbfile$file_name != in.prefix || dbfile$file_path != in.path) { - print(dbfile, digits=10) + if (dbfile$file_name != in.prefix || dbfile$file_path != in.path) { + print(dbfile, digits = 10) PEcAn.logger::logger.error(paste0( "The existing dbfile record printed above has the same machine_id and container ", "but a diferent file name than expected (prefix='", in.prefix, "', path=", in.path, ").", @@ -127,9 +145,10 @@ dbfile.input.insert <- function(in.path, in.prefix, siteid, startdate, enddate, } } else { #insert dbfile & return dbfile id - dbfileid <- dbfile.insert(in.path, in.prefix, 'Input', inputid, con, reuse=TRUE, hostname) + dbfileid <- dbfile.insert(in.path = in.path, in.prefix = in.prefix, type = 'Input', id = inputid, + con = con, reuse = TRUE, hostname = hostname) } - + invisible(list(input.id = inputid, dbfile.id = dbfileid)) } @@ -157,95 +176,108 @@ dbfile.input.insert <- function(in.path, in.prefix, siteid, startdate, enddate, ##' \dontrun{ ##' dbfile.input.check(siteid, startdate, enddate, 'application/x-RData', 'traits', dbcon) ##' } -dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, formatname, parentid=NA, - con, hostname=PEcAn.utils::fqdn(), exact.dates=FALSE,pattern=NULL) { - if (hostname == "localhost") hostname <- PEcAn.utils::fqdn(); - - mimetypeid <- get.id('mimetypes', 'type_string', mimetype, con = con) +dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, formatname, parentid=NA, + con, hostname=PEcAn.utils::fqdn(), exact.dates=FALSE, pattern=NULL) { + hostname <- default_hostname(hostname) + + mimetypeid <- get.id(table = 'mimetypes', colnames = 'type_string', values = mimetype, con = con) if (is.null(mimetypeid)) { return(invisible(data.frame())) } - + # find appropriate format - formatid <- get.id('formats', c("mimetype_id", "name"), c(mimetypeid, formatname), con) + formatid <- get.id(table = 'formats', values = c("mimetype_id", "name"), colnames = c(mimetypeid, formatname), con = con) if (is.null(formatid)) { invisible(data.frame()) } - + # setup parent part of query if specified if (is.na(parentid)) { parent <- "" } else { parent <- paste0(" AND parent_id=", parentid) } - + # find appropriate input - if(exact.dates) { - inputs <- db.query(paste0( - "SELECT * FROM inputs WHERE site_id=", siteid, " AND format_id=", formatid, - " AND start_date='", startdate, "' AND end_date='", enddate, "'", parent), con)#[['id']] + if (exact.dates) { + inputs <- db.query( + query = paste0( + "SELECT * FROM inputs WHERE site_id=", siteid, + " AND format_id=", formatid, + " AND start_date='", startdate, + "' AND end_date='", enddate, + "'", parent + ), + con = con + )#[['id']] } else { - inputs <- db.query(paste0( - "SELECT * FROM inputs WHERE site_id=", siteid, " AND format_id=", formatid, parent), con)#[['id']] + inputs <- db.query( + query = paste0( + "SELECT * FROM inputs WHERE site_id=", siteid, + " AND format_id=", formatid, + parent + ), + con = con + )#[['id']] } - + if (is.null(inputs) | length(inputs$id) == 0) { return(data.frame()) } else { - + ## parent check when NA - if(is.na(parentid)){ - - if (!is.null(pattern)){ + if (is.na(parentid)) { + + if (!is.null(pattern)) { ## Case where pattern is not NULL - inputs <-inputs[grepl(pattern, inputs$name),] + inputs <- inputs[grepl(pattern, inputs$name),] } - + inputs <- inputs[is.na(inputs$parent_id),] } - - if(length(inputs$id) > 1){ + + if (length(inputs$id) > 1) { PEcAn.logger::logger.warn("Found multiple matching inputs. Checking for one with associate files on host machine") - - print(inputs) + + print(inputs) # ni = length(inputs$id) # dbfile = list() # for(i in seq_len(ni)){ # dbfile[[i]] <- dbfile.check(type = 'Input', container.id = inputs$id[i], con = con, hostname = hostname, machine.check = TRUE) # } dbfile <- dbfile.check(type = 'Input', container.id = inputs$id, con = con, hostname = hostname, machine.check = TRUE) - - - if(nrow(dbfile) == 0){ + + + if (nrow(dbfile) == 0) { ## With the possibility of dbfile.check returning nothing, - ## as.data.frame ensures a empty data.frame is returned + ## as.data.frame ensures a empty data.frame is returned ## rather than an empty list. PEcAn.logger::logger.info("File not found on host machine. Returning Valid input with file associated on different machine if possible") - return(as.data.frame(dbfile.check('Input', inputs$id, con, hostname, machine.check = FALSE))) + return(as.data.frame(dbfile.check(type = 'Input', container.id = inputs$id, con = con, hostname = hostname, machine.check = FALSE))) } - + return(dbfile) - }else if(length(inputs$id) == 0){ - + } else if (length(inputs$id) == 0) { + # need this third case here because prent check above can return an empty inputs return(data.frame()) - + }else{ - + PEcAn.logger::logger.warn("Found possible matching input. Checking if its associate files are on host machine") - print(inputs) + print(inputs) dbfile <- dbfile.check(type = 'Input', container.id = inputs$id, con = con, hostname = hostname, machine.check = TRUE) - - if(nrow(dbfile) == 0){ + + if (nrow(dbfile) == 0) { ## With the possibility of dbfile.check returning nothing, - ## as.data.frame ensures an empty data.frame is returned + ## as.data.frame ensures an empty data.frame is returned ## rather than an empty list. PEcAn.logger::logger.info("File not found on host machine. Returning Valid input with file associated on different machine if possible") return(as.data.frame(dbfile.check(type = 'Input', container.id = inputs$id, con = con, hostname = hostname, machine.check = FALSE))) } - + return(dbfile) - + } } } @@ -271,32 +303,44 @@ dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, f ##' dbfile.posterior.insert('trait.data.Rdata', pft, 'application/x-RData', 'traits', dbcon) ##' } dbfile.posterior.insert <- function(filename, pft, mimetype, formatname, con, hostname=PEcAn.utils::fqdn()) { - if (hostname == "localhost") hostname <- PEcAn.utils::fqdn(); - + hostname <- default_hostname(hostname) + # find appropriate pft pftid <- get.id("pfts", "name", pft, con) if (is.null(pftid)) { PEcAn.logger::logger.severe("Could not find pft, could not store file", filename) } - - mimetypeid <- get.id('mimetypes', 'type_string', mimetype, con = con, create=TRUE) - + + mimetypeid <- get.id(table = 'mimetypes', colnames = 'type_string', values = mimetype, + con = con, create = TRUE) + # find appropriate format - formatid <- get.id("formats", colname=c('mimetype_id', 'name'), value=c(mimetypeid, formatname), con, create=TRUE, dates=TRUE) - + formatid <- get.id(table = "formats", colnames = c('mimetype_id', 'name'), values = c(mimetypeid, formatname), + con = con, create = TRUE, dates = TRUE) + # find appropriate posterior - posterior_ids <- get.id("posteriors", "pft_id", pftid, con) - - posteriorid_query <- paste0("SELECT id FROM posteriors WHERE pft_id=", - pftid, " AND format_id=", formatid) - posteriorid <- db.query(posteriorid_query, con)[['id']] + # NOTE: This is defined but not used + # posterior_ids <- get.id("posteriors", "pft_id", pftid, con) + + posteriorid_query <- paste0("SELECT id FROM posteriors WHERE pft_id=", pftid, + " AND format_id=", formatid) + posteriorid <- db.query(query = posteriorid_query, con = con)[['id']] if (is.null(posteriorid)) { # insert input - db.query(paste0("INSERT INTO posteriors (pft_id, format_id, created_at, updated_at) VALUES (", pftid, ", ", formatid, ", NOW(), NOW())"), con) + db.query( + query = paste0( + "INSERT INTO posteriors (pft_id, format_id, created_at, updated_at) VALUES (", + pftid, ", ", formatid, ", NOW(), NOW())" + ), + con = con + ) posteriorid <- db.query(posteriorid_query, con)[['id']] } - - invisible(dbfile.insert(filename, 'Posterior', posteriorid, con, reuse=TRUE, hostname)) + + # NOTE: Modified by Alexey Shiklomanov. + # I'm not sure how this is supposed to work, but I think it's like this + invisible(dbfile.insert(in.path = dirname(filename), in.prefix = basename(filename), type = "Posterior", id = posteriorid, + con = con, reuse = TRUE, hostname = hostname)) } ##' Function to check to see if a file exists in the dbfiles table as an input @@ -319,30 +363,38 @@ dbfile.posterior.insert <- function(filename, pft, mimetype, formatname, con, ho ##' dbfile.posterior.check(pft, 'application/x-RData', 'traits', dbcon) ##' } dbfile.posterior.check <- function(pft, mimetype, formatname, con, hostname=PEcAn.utils::fqdn()) { - if (hostname == "localhost") hostname <- PEcAn.utils::fqdn(); - + hostname <- default_hostname(hostname) + # find appropriate pft - pftid <- get.id("pfts", "name", pft, con) + pftid <- get.id(table = "pfts", values = "name", colnames = pft, con = con) if (is.null(pftid)) { invisible(data.frame()) } - + # find appropriate format - mimetypeid <- get.id("mimetypes", "type_string", mimetype, con) - if(is.null(mimetypeid)) PEcAn.logger::logger.error("mimetype ", mimetype, "does not exist") - formatid <- get.id("formats", colnames = c("mimetype_id", "name"), values = c(mimetypeid, formatname), con) - + mimetypeid <- get.id(table = "mimetypes", values = "type_string", colnames = mimetype, con = con) + if (is.null(mimetypeid)) { + PEcAn.logger::logger.error("mimetype ", mimetype, "does not exist") + } + formatid <- get.id(table = "formats", colnames = c("mimetype_id", "name"), values = c(mimetypeid, formatname), con = con) + if (is.null(formatid)) { invisible(data.frame()) } - + # find appropriate posterior - posteriorid <- db.query(paste0("SELECT id FROM posteriors WHERE pft_id=", pftid, " AND format_id=", formatid), con)[['id']] + posteriorid <- db.query( + query = paste0( + "SELECT id FROM posteriors WHERE pft_id=", pftid, + " AND format_id=", formatid + ), + con = con + )[['id']] if (is.null(posteriorid)) { invisible(data.frame()) } - - invisible(dbfile.check('Posterior', posteriorid, con, hostname)) + + invisible(dbfile.check(type = 'Posterior', container.id = posteriorid, con = con, hostname = hostname)) } ##' Function to insert a file into the dbfiles table @@ -350,7 +402,8 @@ dbfile.posterior.check <- function(pft, mimetype, formatname, con, hostname=PEcA ##' This will write into the dbfiles and machines the required data to store the file ##' @name dbfile.insert ##' @title Insert file into tables -##' @param filename the name of the file to be inserted +##' @param in.path Path to file directory +##' @param in.prefix Filename prefix (not including directory) ##' @param con database connection object ##' @param hostname the name of the host where the file is stored, this will default to the name of the current machine ##' @param params database connection information @@ -362,41 +415,53 @@ dbfile.posterior.check <- function(pft, mimetype, formatname, con, hostname=PEcA ##' dbfile.insert('somefile.txt', 'Input', 7, dbcon) ##' } dbfile.insert <- function(in.path, in.prefix, type, id, con, reuse = TRUE, hostname=PEcAn.utils::fqdn()) { - if (hostname == "localhost") hostname <- PEcAn.utils::fqdn() - - if (substr(in.path, 1, 1) != '/') PEcAn.logger::logger.error("path to dbfiles:", in.path, " is not a valid full path") - + hostname <- default_hostname(hostname) + + if (substr(in.path, 1, 1) != '/') { + PEcAn.logger::logger.error("path to dbfiles:", in.path, " is not a valid full path") + } + # find appropriate host - hostid <- get.id("machines", colname = "hostname", value = hostname, con, create=TRUE, dates=TRUE) - - # Query for existing dbfile record with same file_name, file_path, machine_id, + hostid <- get.id(table = "machines", colnames = "hostname", values = hostname, con = con, create = TRUE, dates = TRUE) + + # Query for existing dbfile record with same file_name, file_path, machine_id , # container_type, and container_id. dbfile <- invisible(db.query( - paste0( + query = paste0( "SELECT * FROM dbfiles WHERE ", - "file_name='", basename(in.prefix), "' AND ", - "file_path='", in.path, "' AND ", + "file_name='", basename(in.prefix), "' AND ", + "file_path='", in.path, "' AND ", "machine_id='", hostid, "'" - ), con)) - - if(nrow(dbfile)==0) { + ), + con = con)) + + if (nrow(dbfile) == 0) { # If no exsting record, insert one now <- format(Sys.time(), "%Y-%m-%d %H:%M:%S") - - db.query(paste0("INSERT INTO dbfiles ", - "(container_type, container_id, file_name, file_path, machine_id, created_at, updated_at) VALUES (", - "'", type, "', ", id, ", '", basename(in.prefix), "', '", in.path, "', ", hostid, - ", '", now, "', '", now, "')"), con) - - file.id <- invisible(db.query(paste0( - "SELECT * FROM dbfiles WHERE container_type='", type, "' AND container_id=", id, - " AND created_at='", now, "' ORDER BY id DESC LIMIT 1"), con)[['id']]) - } else if(!reuse) { + + db.query( + query = paste0("INSERT INTO dbfiles ", + "(container_type, container_id, file_name, file_path, machine_id, created_at, updated_at) VALUES (", + "'", type, "', ", id, ", '", basename(in.prefix), "', '", in.path, "', ", hostid, + ", '", now, "', '", now, "')"), + con = con + ) + + file.id <- invisible(db.query( + query = paste0( + "SELECT * FROM dbfiles WHERE container_type='", type, + "' AND container_id=", id, + " AND created_at='", now, + "' ORDER BY id DESC LIMIT 1" + ), + con = con + )[['id']]) + } else if (!reuse) { # If there is an existing record but reuse==FALSE, return NA. file.id <- NA } else { - if(dbfile$container_type != type || dbfile$container_id != id) { - print(dbfile, digits=10) + if (dbfile$container_type != type || dbfile$container_id != id) { + print(dbfile, digits = 10) PEcAn.logger::logger.error(paste0( "The existing dbfile record printed above has the same machine_id, file_path, and file_name ", "but is associated with a different input than requested (type='", type, "', id=", id, ").", @@ -407,7 +472,7 @@ dbfile.insert <- function(in.path, in.prefix, type, id, con, reuse = TRUE, hostn file.id <- dbfile[['id']] } } - + # Return the new dbfile ID, or the one that existed already (reuse==T), or NA (reuse==F) return(file.id) } @@ -431,45 +496,55 @@ dbfile.insert <- function(in.path, in.prefix, type, id, con, reuse = TRUE, hostn ##' dbfile.check('Input', 7, dbcon) ##' } -dbfile.check <- function(type, container.id, con, hostname=PEcAn.utils::fqdn(), machine.check = TRUE, return.all = FALSE) { - - if (hostname == "localhost") hostname <- PEcAn.utils::fqdn() - +dbfile.check <- function(type, container.id, con, hostname = PEcAn.utils::fqdn(), machine.check = TRUE, return.all = FALSE) { + + hostname <- default_hostname(hostname) + # find appropriate host - hostid <- get.id("machines", "hostname", hostname, con) - # hostid <- db.query(paste0("SELECT id FROM machines WHERE hostname='", hostname, "'"), con)[['id']] + hostid <- get.id(table = "machines", colnames = "hostname", values = hostname, con = con) if (is.null(hostid)) { return(data.frame()) - } else if (machine.check){ - - dbfiles <- db.query(paste0("SELECT * FROM dbfiles WHERE container_type='", type, - "' AND container_id IN (", paste(container.id, collapse = ", "), - ") AND machine_id=", hostid), con) - - if(nrow(dbfiles) > 1 && !return.all){ - + } else if (machine.check) { + + dbfiles <- db.query( + query = paste0( + "SELECT * FROM dbfiles WHERE container_type='", type, + "' AND container_id IN (", paste(container.id, collapse = ", "), + ") AND machine_id=", hostid + ), + con = con + ) + + if (nrow(dbfiles) > 1 && !return.all) { + PEcAn.logger::logger.warn("Multiple Valid Files found on host machine. Returning last updated record.") return(dbfiles[dbfiles$updated_at == max(dbfiles$updated_at),]) - - }else{ - + + } else { + return(dbfiles) - + } - - }else{ - - dbfiles <- db.query(paste0("SELECT * FROM dbfiles WHERE container_type='", type, - "' AND container_id IN (", paste(container.id, collapse = ", "),")"), con) - - if(nrow(dbfiles) > 1 && !return.all){ - + + } else { + + dbfiles <- db.query( + query = paste0( + "SELECT * FROM dbfiles WHERE container_type='", type, + "' AND container_id IN (", paste(container.id, collapse = ", "), ")" + ), + con = con + ) + + if (nrow(dbfiles) > 1 && !return.all) { + PEcAn.logger::logger.warn("Multiple Valid Files found on host machine. Returning last updated record.") return(dbfiles[dbfiles$updated_at == max(dbfiles$updated_at),]) - - }else{ - + + } else { + return(dbfiles) + } } } @@ -496,11 +571,11 @@ dbfile.check <- function(type, container.id, con, hostname=PEcAn.utils::fqdn(), ##' dbfile.file('Input', 7, dbcon) ##' } dbfile.file <- function(type, id, con, hostname=PEcAn.utils::fqdn()) { - if (hostname == "localhost") hostname <- PEcAn.utils::fqdn(); - - files <- dbfile.check(type, id, con, hostname) - - if(nrow(files) > 1) { + hostname <- default_hostname(hostname) + + files <- dbfile.check(type = type, container.id = id, con = con, hostname = hostname) + + if (nrow(files) > 1) { PEcAn.logger::logger.warn("multiple files found for", id, "returned; using the first one found") invisible(file.path(files[1, 'file_path'], files[1, 'file_name'])) } else if (nrow(files) == 1) { @@ -531,20 +606,27 @@ dbfile.file <- function(type, id, con, hostname=PEcAn.utils::fqdn()) { ##' dbfile.id('Model', '/usr/local/bin/sipnet', dbcon) ##' } dbfile.id <- function(type, file, con, hostname=PEcAn.utils::fqdn()) { - if (hostname == "localhost") hostname <- PEcAn.utils::fqdn(); - + hostname <- default_hostname(hostname) + # find appropriate host - hostid <- db.query(paste0("SELECT id FROM machines WHERE hostname='", hostname, "'"), con)[['id']] + hostid <- db.query(query = paste0("SELECT id FROM machines WHERE hostname='", hostname, "'"), con = con)[['id']] if (is.null(hostid)) { invisible(NA) } - + # find file file_name <- basename(file) file_path <- dirname(file) - ids <- db.query(paste0("SELECT container_id FROM dbfiles WHERE container_type='", type, "' AND file_path='", file_path, "' AND file_name='", file_name, "' AND machine_id=", hostid), con) - - if(nrow(ids) > 1) { + ids <- db.query( + query = paste0( + "SELECT container_id FROM dbfiles WHERE container_type='", type, + "' AND file_path='", file_path, + "' AND file_name='", file_name, + "' AND machine_id=", hostid + ), + con = con) + + if (nrow(ids) > 1) { PEcAn.logger::logger.warn("multiple ids found for", file, "returned; using the first one found") invisible(ids[1, 'container_id']) } else if (nrow(ids) == 1) { From 7549a88d781cf059e1ebb0e3351621d8727f3e9b Mon Sep 17 00:00:00 2001 From: Amanskywalker Date: Wed, 23 Aug 2017 22:22:17 +0530 Subject: [PATCH 383/771] Added Basic setup page link in generic PEcAn landing page --- documentation/index_vm.html | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/documentation/index_vm.html b/documentation/index_vm.html index 3a3e077c41f..4bdb9ec1829 100644 --- a/documentation/index_vm.html +++ b/documentation/index_vm.html @@ -13,6 +13,8 @@

    PEcAn

    RStudio

    +

    Basic Setups

    +

    Code Repository

    Chat Room

    @@ -20,11 +22,11 @@

    PEcAn

    Submit an Issue / Bug Report

    Project Homepage

    - +

    Documentation

    The documentation for PEcAn is rendered using bookdown. A PDF version can be found locally. The most up to date version can be found at our website. - +

    Acknowledgements

    This material is based upon work supported by the National Science Foundation under Grants 1062547, 1062204, 1241894, 1261582, 1318164, 1346748, and 1458021, the National Aeronautics and Space Administration (NASA) grant 13-TE13-0060, the Energy Biosciences Institute, Department of Energy (ARPA-E awards #DE-AR0000594 and DE-AR0000598) and Amazon Web Services. Any opinions, findings, and conclusions or recommendations expressed in this material are those of the author(s) and do not necessarily reflect the views of NSF or NASA.

    From 57b6d806c447b60595374e6f021a0b84f6df9407 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:02:41 -0500 Subject: [PATCH 384/771] DB: Cleanup `get.trait.data.R` --- base/db/R/get.trait.data.R | 139 ++++++++++++++++++++----------------- 1 file changed, 75 insertions(+), 64 deletions(-) diff --git a/base/db/R/get.trait.data.R b/base/db/R/get.trait.data.R index 665bca9126c..b03e4b1f7ca 100644 --- a/base/db/R/get.trait.data.R +++ b/base/db/R/get.trait.data.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -22,19 +22,9 @@ check.lists <- function(x, y) { if (nrow(x) != nrow(y)) { return(FALSE) } - if (!identical(as.character(x$id), as.character(y$id))) { - return(FALSE) - } - if (!identical(as.character(x$genus), as.character(y$genus))) { - return(FALSE) - } - if (!identical(as.character(x$species), as.character(y$species))) { - return(FALSE) - } - if (!identical(as.character(x$scientificname), as.character(y$scientificname))) { - return(FALSE) - } - return(TRUE) + cols <- c('id', 'genus', 'species', 'scientificname') + xy_match <- vapply(cols, function(i) identical(as.character(x[[i]]), as.character(y[[i]])), logical(1)) + return(all(unlist(xy_match))) } ##--------------------------------------------------------------------------------------------------# @@ -56,19 +46,29 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, trait.names = traitdictionary$id) { # Create directory if necessary - if(!file.exists(pft$outdir) && !dir.create(pft$outdir, recursive=TRUE)) { + if (!file.exists(pft$outdir) && !dir.create(pft$outdir, recursive = TRUE)) { PEcAn.logger::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) + old.files <- list.files(path = pft$outdir, full.names = TRUE, include.dirs = FALSE) file.remove(old.files) # find appropriate pft if (is.null(modeltype)) { - pftid <- db.query(paste0("SELECT id FROM pfts WHERE name='", pft$name, "'"), dbcon)[['id']] + pftid <- db.query( + query = paste0("SELECT id FROM pfts WHERE name='", pft$name, "'"), + con = dbcon + )[['id']] } else { - pftid <- db.query(paste0("SELECT pfts.id FROM pfts, modeltypes WHERE pfts.name='", pft$name, "' and pfts.modeltype_id=modeltypes.id and modeltypes.name='", modeltype, "'"), dbcon)[['id']] + pftid <- db.query( + query = paste0( + "SELECT pfts.id FROM pfts, modeltypes WHERE pfts.name='", pft$name, + "' and pfts.modeltype_id=modeltypes.id and modeltypes.name='", modeltype, + "'" + ), + con = dbcon + )[['id']] } if (is.null(pftid)) { PEcAn.logger::logger.severe("Could not find pft, could not store file", filename) @@ -76,30 +76,36 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, } # get the species, we need to check if anything changed - species <- PEcAn.DB::query.pft_species(pft$name, modeltype, dbcon) + species <- PEcAn.DB::query.pft_species(pft = pft$name, modeltype = modeltype, con = dbcon) spstr <- PEcAn.utils::vecpaste(species$id) # get the priors - prior.distns <- PEcAn.DB::query.priors(pftid, PEcAn.utils::vecpaste(trait.names), out = pft$outdir, con = dbcon) + prior.distns <- PEcAn.DB::query.priors(pft = pftid, trstr = PEcAn.utils::vecpaste(trait.names), out = pft$outdir, con = dbcon) prior.distns <- prior.distns[which(!rownames(prior.distns) %in% names(pft$constants)),] - traits <- rownames(prior.distns) + traits <- rownames(prior.distns) # get the trait data (don't bother sampling derived traits until after update check) - trait.data.check <- PEcAn.DB::query.traits(spstr, traits, con = dbcon, update.check.only=TRUE) + trait.data.check <- PEcAn.DB::query.traits(spstr = spstr, priors = traits, con = dbcon, update.check.only = TRUE) traits <- names(trait.data.check) # Set forceupdate FALSE if it's a string (backwards compatible with 'AUTO' flag used in the past) - if(!is.logical(forceupdate)) { + if (!is.logical(forceupdate)) { forceupdate <- FALSE } - + # check to see if we need to update if (!forceupdate) { if (is.null(pft$posteriorid)) { - pft$posteriorid <- db.query(paste0("SELECT id FROM posteriors WHERE pft_id=", pftid, " ORDER BY created_at DESC LIMIT 1"), dbcon)[['id']] + pft$posteriorid <- db.query( + query = paste0( + "SELECT id FROM posteriors WHERE pft_id=", pftid, + " ORDER BY created_at DESC LIMIT 1" + ), + con = dbcon + )[['id']] } - if (!is.null(pft$posteriorid)) { - files <- dbfile.check('Posterior', pft$posteriorid, dbcon) + if (!is.null(pft$posteriorid)) { + files <- dbfile.check(type = 'Posterior', container.id = pft$posteriorid, con = dbcon) ids <- match(c('trait.data.Rdata', 'prior.distns.Rdata', 'species.csv'), files$file_name) if (!any(is.na(ids))) { foundallfiles <- TRUE @@ -110,7 +116,7 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, PEcAn.logger::logger.error("can not find posterior file: ", file.path(files$file_path[[id]], files$file_name[[id]])) } else if (files$file_name[[id]] == "species.csv") { PEcAn.logger::logger.debug("Checking if species have changed") - testme <- read.csv(file.path(files$file_path[[id]], files$file_name[[id]])) + testme <- read.csv(file = file.path(files$file_path[[id]], files$file_name[[id]])) if (!check.lists(species, testme)) { foundallfiles <- FALSE PEcAn.logger::logger.error("species have changed: ", file.path(files$file_path[[id]], files$file_name[[id]])) @@ -137,12 +143,12 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, # For trait data including converted data, only check unconverted converted.stats2na <- function(x) { - if(all(c("mean", "stat", "mean_unconverted", "stat_unconverted") %in% names(x))) + if (all(c("mean", "stat", "mean_unconverted", "stat_unconverted") %in% names(x))) x[,c("mean","stat")] <- NA return(x) } - trait.data = lapply(trait.data, converted.stats2na) - trait.data.check = lapply(trait.data.check, converted.stats2na) + trait.data <- lapply(trait.data, converted.stats2na) + trait.data.check <- lapply(trait.data.check, converted.stats2na) if (!identical(trait.data.check, trait.data)) { foundallfiles <- FALSE @@ -153,19 +159,22 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, } if (foundallfiles) { PEcAn.logger::logger.info("Reusing existing files from posterior", pft$posteriorid, "for", pft$name) - for(id in 1:nrow(files)) { - file.copy(file.path(files[[id, 'file_path']], files[[id, 'file_name']]), file.path(pft$outdir, files[[id, 'file_name']])) + for (id in seq_len(nrow(files))) { + file.copy(from = file.path(files[[id, 'file_path']], files[[id, 'file_name']]), + to = file.path(pft$outdir, files[[id, 'file_name']])) } - + # May need to symlink the generic post.distns.Rdata to a specific post.distns.*.Rdata file. - if(length(dir(pft$outdir, "post.distns.Rdata"))==0) { + if (length(dir(pft$outdir, "post.distns.Rdata")) == 0) { all.files <- dir(pft$outdir) post.distn.file <- all.files[grep("post.distns.*.Rdata", all.files)] - if(length(post.distn.file) > 1) + if (length(post.distn.file) > 1) stop("get.trait.data.pft() doesn't know how to handle multiple post.distns.*.Rdata files") - else if(length(post.distn.file) == 1) { + else if (length(post.distn.file) == 1) { # Found exactly one post.distns.*.Rdata file. Use it. - file.symlink(file.path(pft$outdir, post.distn.file), file.path(pft$outdir, 'post.distns.Rdata')) + file.symlink(from = file.path(pft$outdir, post.distn.file), + to = file.path(pft$outdir, 'post.distns.Rdata') + ) } } return(pft) @@ -175,16 +184,18 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, } # get the trait data (including sampling of derived traits, if any) - trait.data <- query.traits(spstr, traits, con = dbcon, update.check.only=FALSE) + trait.data <- query.traits(spstr, traits, con = dbcon, update.check.only = FALSE) traits <- names(trait.data) # get list of existing files so they get ignored saving - old.files <- list.files(path=pft$outdir) + old.files <- list.files(path = pft$outdir) # create a new posterior - now <- format(Sys.time(), "%Y-%m-%d %H:%M:%S") - db.query(paste0("INSERT INTO posteriors (pft_id, created_at, updated_at) VALUES (", pftid, ", '", now, "', '", now, "')"), dbcon) - pft$posteriorid <- db.query(paste0("SELECT id FROM posteriors WHERE pft_id=", pftid, " AND created_at='", now, "'"), dbcon)[['id']] + now <- format(x = Sys.time(), format = "%Y-%m-%d %H:%M:%S") + db.query(query = paste0("INSERT INTO posteriors (pft_id, created_at, updated_at) VALUES (", pftid, ", '", now, "', '", now, "')"), + con = dbcon) + pft$posteriorid <- db.query(query = paste0("SELECT id FROM posteriors WHERE pft_id=", pftid, " AND created_at='", now, "'"), + con = dbcon)[['id']] # create path where to store files pathname <- file.path(dbfiles, "posterior", pft$posteriorid) @@ -201,28 +212,28 @@ get.trait.data.pft <- function(pft, modeltype, dbfiles, dbcon, ## 3. display info to the console PEcAn.logger::logger.info('Summary of Prior distributions for: ', pft$name) PEcAn.logger::logger.info(colnames(prior.distns)) - apply(cbind(rownames(prior.distns), prior.distns), MARGIN=1, PEcAn.logger::logger.info) + apply(X = cbind(rownames(prior.distns), prior.distns), MARGIN = 1, FUN = PEcAn.logger::logger.info) - ## traits = variables with prior distributions for this pft + ## traits = variables with prior distributions for this pft trait.data.file <- file.path(pft$outdir, "trait.data.Rdata") save(trait.data, file = trait.data.file) write.csv(plyr::ldply(trait.data), file = file.path(pft$outdir, "trait.data.csv"), row.names = FALSE) - + PEcAn.logger::logger.info("number of observations per trait for", pft$name) - for(t in names(trait.data)){ + for (t in names(trait.data)) { PEcAn.logger::logger.info(nrow(trait.data[[t]]), "observations of", t) } - + ### save and store in database all results except those that were there already - for(file in list.files(path=pft$outdir)) { + for (file in list.files(path = pft$outdir)) { if (file %in% old.files) { next } filename <- file.path(pathname, file) file.copy(file.path(pft$outdir, file), filename) - dbfile.insert(pathname,file, 'Posterior', pft$posteriorid, dbcon) + dbfile.insert(in.path = pathname, in.prefix = file, type = 'Posterior', id = pft$posteriorid, con = dbcon) } return(pft) @@ -259,8 +270,8 @@ get.trait.data <- function(pfts, modeltype, dbfiles, database, forceupdate, trai PEcAn.logger::logger.severe('At least one pft in settings is missing its "outdir"') } ##---------------- Load trait dictionary --------------# - if(is.logical(trait.names)){ - if(trait.names){ + if (is.logical(trait.names)) { + if (trait.names) { data(trait.dictionary, package = "PEcAn.utils") trait.names <- trait.dictionary$id } @@ -269,8 +280,8 @@ get.trait.data <- function(pfts, modeltype, dbfiles, database, forceupdate, trai # process all pfts dbcon <- db.open(database) on.exit(db.close(dbcon)) - result <- lapply(pfts, get.trait.data.pft, - modeltype = modeltype, + result <- lapply(pfts, get.trait.data.pft, + modeltype = modeltype, dbfiles = dbfiles, dbcon = dbcon, forceupdate = forceupdate, @@ -282,11 +293,11 @@ get.trait.data <- function(pfts, modeltype, dbfiles, database, forceupdate, trai ##' @export runModule.get.trait.data <- function(settings) { - if(is.null(settings$meta.analysis)) return(settings) ## if there's no MA, there's no need for traits - if(PEcAn.settings::is.MultiSettings(settings)) { + if (is.null(settings$meta.analysis)) return(settings) ## if there's no MA, there's no need for traits + if (PEcAn.settings::is.MultiSettings(settings)) { pfts <- list() pft.names <- character(0) - for(i in seq_along(settings)) { + for (i in seq_along(settings)) { pfts.i <- settings[[i]]$pfts if (!is.list(pfts.i)) { PEcAn.logger::logger.severe("settings[[i]]$pfts is not a list") @@ -296,17 +307,17 @@ runModule.get.trait.data <- function(settings) { pfts <- c(pfts, pfts.i[ind]) pft.names <- sapply(pfts, function(x) x$name) } - + PEcAn.logger::logger.info(paste0("Getting trait data for all PFTs listed by any Settings object in the list: ", - paste(pft.names, collapse=", "))) - + paste(pft.names, collapse = ", "))) + modeltype <- settings$model$type dbfiles <- settings$database$dbfiles database <- settings$database$bety forceupdate <- ifelse(is.null(settings$meta.analysis$update), FALSE, settings$meta.analysis$update) - settings$pfts <- get.trait.data(pfts, modeltype, dbfiles, database, forceupdate) + settings$pfts <- get.trait.data(pfts = pfts, modeltype = modeltype, dbfiles = dbfiles, database = database, forceupdate = forceupdate) return(settings) - } else if(PEcAn.settings::is.Settings(settings)) { + } else if (PEcAn.settings::is.Settings(settings)) { pfts <- settings$pfts if (!is.list(pfts)) { PEcAn.logger::logger.severe("settings$pfts is not a list") @@ -315,7 +326,7 @@ runModule.get.trait.data <- function(settings) { dbfiles <- settings$database$dbfiles database <- settings$database$bety forceupdate <- ifelse(is.null(settings$meta.analysis$update), FALSE, settings$meta.analysis$update) - settings$pfts <- get.trait.data(pfts, modeltype, dbfiles, database, forceupdate) + settings$pfts <- get.trait.data(pfts = pfts, modeltype = modeltype, dbfiles = dbfiles, database = database, forceupdate = forceupdate) return(settings) } else { stop("runModule.get.trait.data only works with Settings or MultiSettings") @@ -325,5 +336,5 @@ runModule.get.trait.data <- function(settings) { #################################################################################################### -### EOF. End of R script file. +### EOF. End of R script file. #################################################################################################### From b67e50a1fab543ee42008741e18607e303512aaa Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:03:32 -0500 Subject: [PATCH 385/771] DB: Cleanup `input.name.check.R` --- base/db/R/input.name.check.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/base/db/R/input.name.check.R b/base/db/R/input.name.check.R index 253daa03197..71eb20e8686 100644 --- a/base/db/R/input.name.check.R +++ b/base/db/R/input.name.check.R @@ -1,3 +1,3 @@ input.name.check <- function(inputname, con){ - inputid <- db.query(paste0("SELECT id FROM inputs WHERE name = '", inputname, "'"), con)[['id']] -} \ No newline at end of file + db.query(query = paste0("SELECT id FROM inputs WHERE name = '", inputname, "'"), con = con)[['id']] +} From 5f9667a1d6638f84d8f6f762bae39e3d66cb1808 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:06:25 -0500 Subject: [PATCH 386/771] DB: Cleanup `priordupe.R`. --- base/db/R/priordupe.R | 62 +++++++++++++++++++++++++------------------ 1 file changed, 36 insertions(+), 26 deletions(-) diff --git a/base/db/R/priordupe.R b/base/db/R/priordupe.R index b095c869aee..837110a857b 100644 --- a/base/db/R/priordupe.R +++ b/base/db/R/priordupe.R @@ -3,9 +3,9 @@ ##' Creates a new pft that is a duplicate of an existing pft, ##' including relationships with priors and species of the existing pft ##' @title Duplicate PFT -##' @param parent.pft.name -##' @param new.pft.name -##' @param new.pft.definition +##' @param parent.pft.name +##' @param new.pft.name +##' @param new.pft.definition ##' @return nothing, creates new pft in database as a side-effect ##' @author David LeBauer ##' @examples \dontrun{ @@ -17,36 +17,46 @@ priordupe <- function(parent.pft.name = NULL, new.pft.name = NULL, new.pft.definition = NULL, settings = 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) + + parent.pft.id <- db.query(query = paste("select id from pfts where name = ", parent.pft.name, ";"), + con = con) ## create new pft - db.query(paste("insert into pfts set definition = ", - newpftdefn, " name = ", - new.pft.name, ";"), con=con) - new.pft.id <- db.query(paste("select id from pfts where name =", - new.pft.name,";"), con=con) + db.query( + query = paste( + "insert into pfts set definition = ", newpftdefn, + " name = ", new.pft.name, ";" + ), + con = con + ) + new.pft.id <- db.query(query = paste("select id from pfts where name =", + new.pft.name,";"), con = con) - old.species.id <- db.query(paste("select specie_id from pfts_species where pft_id =", - parent.pft.id, ";"), con=con) + old.species.id <- db.query(query = paste("select specie_id from pfts_species where pft_id =", + parent.pft.id, ";"), con = con) new.pfts_species <- c(pft_id = new.pft.id, specie_id = unique(old.species.id)) - - db.query(paste("insert into pfts_species set pft_id = ", - new.pfts_species$pft_id, - "specie_id = ", - new.pfts_species$specie_id, ";"), con=con) - old.priors <- db.query(paste("select prior_id from pfts_priors where pft_id =", - parent.pft.id, ";"), con=con) + db.query( + query = paste( + "insert into pfts_species set pft_id = ", new.pfts_species$pft_id, + "specie_id = ", new.pfts_species$specie_id, ";" + ), + con = con + ) + + old.priors <- db.query(query = paste("select prior_id from pfts_priors where pft_id =", + parent.pft.id, ";"), con = con) new.pfts_priors <- c(pft_id = new.pft.id, prior_id = unique(old.priors)) - db.query(paste("insert into pfts_priors set pft_id = ", - new.pfts_priors$pft_id, - "specie_id = ", - new.pfts_priors$priors_id, ";"), con=con) + db.query( + query = paste( + "insert into pfts_priors set pft_id = ", new.pfts_priors$pft_id, + "specie_id = ", new.pfts_priors$priors_id, + ";" + ), + con = con + ) } From 34848d297c056ceb83b51c5f9e403e7ca19907f0 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:09:27 -0500 Subject: [PATCH 387/771] DB: Permanently remove `query.base` functions --- base/db/R/query.base.R | 101 ------------------------------------ scripts/workflow.treering.R | 8 +-- 2 files changed, 4 insertions(+), 105 deletions(-) delete mode 100644 base/db/R/query.base.R diff --git a/base/db/R/query.base.R b/base/db/R/query.base.R deleted file mode 100644 index 77b9b0902a3..00000000000 --- a/base/db/R/query.base.R +++ /dev/null @@ -1,101 +0,0 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2012 University of Illinois, NCSA. -# All rights reserved. This program and the accompanying materials -# are made available under the terms of the -# University of Illinois/NCSA Open Source License -# which accompanies this distribution, and is available at -# http://opensource.ncsa.illinois.edu/license.html -#------------------------------------------------------------------------------- - -#---------------- Base database query function. ---------------------------------------------------# -##' Generic function to query trait database -##' -##' Given a connection and a query, will return a query as a data frame -##' -##' Deprecated, please use db.query -##' -##' @name query.base -##' @title Query database -##' @param query SQL query string -##' @param con database connection object -##' @param ... optional arguments for connecting to database (e.g. password, user name, database) -##' @return data frame with query results -##' @export query.base -##' @examples -##' \dontrun{ -##' query.base('select count(id) from traits;') -##' } -query.base <- function(query, con=NULL, ...){ - .Deprecated("db.query") - .db.utils$deprecated <- .db.utils$deprecated+1 - if(is.null(con)){ - invisible(db.query(query, params=settings$database$bety)) - } else { - invisible(db.query(query, con)) - } -} -#==================================================================================================# - -#---------------- Base database connection function. ----------------------------------------------# -##' Creates database connection object. -##' -##' Also removes any existing connections. -##' -##' Deprecated, please use db.open -##' -##' @name query.base.con -##' @title Query database connection -##' @param ... optional arguments for connecting to database (e.g. password, user name, database) -##' @return database connection object -##' @export query.base.con -##' @examples -##' \dontrun{ -##' con <- query.base.con(settings) -##' } -query.base.con <- function(settings,...){ - .Deprecated("db.open") - .db.utils$deprecated <- .db.utils$deprecated+1 - invisible(db.open(settings$database$bety)) -} -#==================================================================================================# - -#---------------- Close open database connections. --------------------------------------------# -##' Close database connection -##' -##' Deprecated, please use db.close -##' -##' Closes a database connection -##' @name query.close -##' @title Close existing database connections -##' @param con database connection object -##' @return nothing, as a side effect closes all open connections -##' @author Rob Kooper -##' @export query.close -query.close <- function(con) { - .Deprecated("db.close") - .db.utils$deprecated <- .db.utils$deprecated+1 - invisible(db.close(con)) -} -#==================================================================================================# - -#---------------- Close all open database connections. --------------------------------------------# -##' Kill existing database connections -##' -##' Deprecated, this should never be called -##' -##' resolves (provides workaround to) bug #769 caused by having too many open connections \code{Error during wrapup: RS-DBI driver: (cannot allocate a new connection -- maximum of 16 connections already opened)} -##' @name killdbcons -##' @title Kill existing database connections -##' @return nothing, as a side effect closes all open connections -##' @author David LeBauer -killdbcons <- function(){ - .Deprecated("NeverCallThisFunction") - .db.utils$deprecated <- .db.utils$deprecated+1 - for (i in dbListConnections(MySQL())) db.close(i) -} -#==================================================================================================# - - -#################################################################################################### -### EOF. End of R script file. -#################################################################################################### diff --git a/scripts/workflow.treering.R b/scripts/workflow.treering.R index e73aaaf16fc..527074b0542 100644 --- a/scripts/workflow.treering.R +++ b/scripts/workflow.treering.R @@ -22,7 +22,7 @@ library(mvtnorm) library(rjags) library(reshape2) #--------------------------------------------------------------------------------------------------# -# +# #---------------- Load PEcAn settings file. -------------------------------------------------------# # Open and read in settings file for PEcAn run. @@ -61,7 +61,7 @@ pft.data <- list() for (ipft in seq_along(settings$pfts)) { ## loop over PFTs pft_name <- settings$pfts[[ipft]]$name - query <- paste0("SELECT s.spcd,", "s.\"Symbol\"", " as acronym from pfts as p join pfts_species on p.id = pfts_species.pft_id join species as s on pfts_species.specie_id = s.id where p.name like '%", + query <- paste0("SELECT s.spcd,", "s.\"Symbol\"", " as acronym from pfts as p join pfts_species on p.id = pfts_species.pft_id join species as s on pfts_species.specie_id = s.id where p.name like '%", pft_name, "%'") pft.data[[pft_name]] <- db.query(query, con) } @@ -79,7 +79,7 @@ state <- plot2AGB(combined, out[, sel], settings$outdir, list(allom.stats[[2]]), NPP.conv <- 0.48 #Mg/ha/yr -> MgC/ha/yr AGB.conv <- (1/10000) * (1000/1) * 0.48 #Mg/ha -> kgC/m2 -NPP <- apply(state$NPP[1, , ], 2, mean, na.rm = TRUE) * NPP.conv # MgC/ha/yr +NPP <- apply(state$NPP[1, , ], 2, mean, na.rm = TRUE) * NPP.conv # MgC/ha/yr AGB <- apply(state$AGB[1, , ], 2, mean, na.rm = TRUE) * AGB.conv # kgC/m2 obs.mean <- list() @@ -110,7 +110,7 @@ status.end() ### PEcAn workflow run complete status.start("FINISHED") if (settings$workflow$id != "NA") { - query.base(paste("UPDATE workflows SET finished_at=NOW() WHERE id=", settings$workflow$id, "AND finished_at IS NULL"), con) + db.query(paste("UPDATE workflows SET finished_at=NOW() WHERE id=", settings$workflow$id, "AND finished_at IS NULL"), con) } status.end() db.close(con) From 043ef50197080a45399a5e12b57ea7d2768b4329 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:20:24 -0500 Subject: [PATCH 388/771] DB: Cleanup `query.dplyr.R` --- base/db/R/query.dplyr.R | 102 +++++++++++++++++++++------------------- 1 file changed, 54 insertions(+), 48 deletions(-) diff --git a/base/db/R/query.dplyr.R b/base/db/R/query.dplyr.R index 7fdcb5715b6..55ffb7e79a5 100644 --- a/base/db/R/query.dplyr.R +++ b/base/db/R/query.dplyr.R @@ -12,11 +12,13 @@ betyConnect <- function(php.config = "../../web/config.php") { config <- config[-grep("$", config, fixed = TRUE)] ## lines with variable references fail config <- config[-grep("exec", config, fixed = TRUE)] ## lines 'exec' fail config.list <- eval(parse(text = paste("list(", paste0(config[1:14], collapse = ","), ")"))) - + ## Database connection - src_postgres(dbname = config.list$db_bety_database, - host = config.list$db_bety_hostname, - user = config.list$db_bety_username, + # TODO: The latest version of dplyr/dbplyr works with standard DBI-based + # objects, so we should replace this with a standard `db.open` call. + src_postgres(dbname = config.list$db_bety_database, + host = config.list$db_bety_hostname, + user = config.list$db_bety_username, password = config.list$db_bety_password) } # betyConnect @@ -43,7 +45,7 @@ fancy_scientific <- function(l) { #' @param df Data frame of which to count length #' @export dplyr.count <- function(df) { - return(collect(tally(df))[["n"]]) + return(dplyr::collect(dplyr::tally(df))[["n"]]) } # dplyr.count @@ -60,23 +62,24 @@ ncdays2date <- function(time, unit) { #' @name dbHostInfo #' @title Database host information #' @param bety BETYdb connection, as opened by `betyConnect()` +#' @importFrom dplyr `%>%` #' @export dbHostInfo <- function(bety) { # get host id - result <- db.query("select cast(floor(nextval('users_id_seq') / 1e9) as bigint);", bety$con) + result <- db.query(query = "select cast(floor(nextval('users_id_seq') / 1e9) as bigint);", con = bety$con) hostid <- result[["floor"]] - + # get machine start and end based on hostid - machine <- tbl(bety, "machines") %>% - filter(sync_host_id == hostid) %>% + machine <- dplyr::tbl(bety, "machines") %>% + dplyr::filter(sync_host_id == hostid) %>% dplyr::select(sync_start, sync_end) - + if (is.na(nrow(machine)) || nrow(machine) == 0) { - return(list(hostid = hostid, - start = 1e+09 * hostid, + return(list(hostid = hostid, + start = 1e+09 * hostid, end = 1e+09 * (hostid + 1) - 1)) } else { - return(list(hostid = hostid, + return(list(hostid = hostid, start = machine$sync_start, end = machine$sync_end)) } @@ -86,29 +89,31 @@ dbHostInfo <- function(bety) { #' list of workflows that exist #' @param ensemble Logical. Use workflows from ensembles table. #' @inheritParams dbHostInfo +#' @importFrom dplyr `%>%` #' @export workflows <- function(bety, ensemble = FALSE) { hostinfo <- dbHostInfo(bety) if (ensemble) { - query <- paste("SELECT ensembles.id AS ensemble_id, ensembles.workflow_id, workflows.folder", + query <- paste("SELECT ensembles.id AS ensemble_id, ensembles.workflow_id, workflows.folder", "FROM ensembles, workflows WHERE runtype = 'ensemble'") } else { query <- "SELECT id AS workflow_id, folder FROM workflows" } - out <- tbl(bety, sql(query)) %>% - filter(workflow_id >= hostinfo$start & workflow_id <= hostinfo$end) - return(out) + dplyr::tbl(bety, dbplyr::sql(query)) %>% + dplyr::filter(workflow_id >= hostinfo$start & workflow_id <= hostinfo$end) %>% + return() } # workflows #' Get single workflow by workflow_id #' @param workflow_id Workflow ID #' @inheritParams dbHostInfo +#' @importFrom dplyr `%>%` #' @export workflow <- function(bety, workflow_id) { - workflows(bety) %>% - filter_(paste("workflow_id ==", workflow_id)) %>% - return + workflows(bety) %>% + dplyr::filter_(paste("workflow_id ==", workflow_id)) %>% + return() } # workflow @@ -117,16 +122,16 @@ workflow <- function(bety, workflow_id) { #' @inheritParams workflow #' @export runs <- function(bety, workflow_id) { - Workflows <- workflow(bety, workflow_id) %>% + Workflows <- workflow(bety, workflow_id) %>% dplyr::select(workflow_id, folder) - Ensembles <- tbl(bety, "ensembles") %>% - dplyr::select(ensemble_id = id, workflow_id) %>% + Ensembles <- dplyr::tbl(bety, "ensembles") %>% + dplyr::select(ensemble_id = id, workflow_id) %>% inner_join(Workflows, by = "workflow_id") - Runs <- tbl(bety, "runs") %>% - dplyr::select(run_id = id, ensemble_id) %>% - inner_join(Ensembles, by = "ensemble_id") - dplyr::select(Runs, -workflow_id, -ensemble_id) %>% - return + Runs <- dplyr::tbl(bety, "runs") %>% + dplyr::select(run_id = id, ensemble_id) %>% + dplyr::inner_join(Ensembles, by = "ensemble_id") + dplyr::select(Runs, -workflow_id, -ensemble_id) %>% + return() } # runs @@ -134,16 +139,17 @@ runs <- function(bety, workflow_id) { #' @inheritParams dbHostInfo #' @param session Session object passed through Shiny #' @export -get_workflow_ids <- function(bety, session,all.ids=FALSE) { - query <- isolate(parseQueryString(session$clientData$url_search)) +get_workflow_ids <- function(bety, session, all.ids=FALSE) { + query <- isolate(shiny::parseQueryString(session$clientData$url_search)) # If we dont want all workflow ids but only workflow id from the user url query if (!all.ids & "workflow_id" %in% names(query)) { ids <- unlist(query[names(query) == "workflow_id"], use.names = FALSE) } else { # Get all workflow IDs - ids <- workflows(bety, ensemble = TRUE) %>% distinct(workflow_id) %>% collect %>% - .[["workflow_id"]] %>% sort(decreasing = TRUE) - # pull(.,workflow_id) %>% sort(decreasing = TRUE) + ids <- workflows(bety, ensemble = TRUE) %>% + dplyr::distinct(workflow_id) %>% + dplyr::pull() %>% + sort(decreasing = TRUE) } return(ids) } # get_workflow_ids @@ -155,8 +161,8 @@ get_workflow_ids <- function(bety, session,all.ids=FALSE) { get_users <- function(bety, session) { hostinfo <- dbHostInfo(bety) query <- "SELECT id, login FROM users" - out <- tbl(bety, sql(query)) %>% - filter(id >= hostinfo$start & id <= hostinfo$end) + out <- dplyr::tbl(bety, dbplyr::sql(query)) %>% + dplyr::filter(id >= hostinfo$start & id <= hostinfo$end) return(out) } # get_workflow_ids @@ -170,7 +176,7 @@ get_run_ids <- function(bety, workflow_id) { if (workflow_id != "") { runs <- runs(bety, workflow_id) if (dplyr.count(runs) > 0) { - run_ids <- collect(runs)[["run_id"]] %>% sort + run_ids <- pull(runs, run_id) %>% sort() } } return(run_ids) @@ -232,23 +238,23 @@ var_names_all <- function(bety, workflow_id, run_id) { #' @param run_id Run ID #' @param workflow_id Workflow ID #' @export -load_data_single_run <- function(bety, workflow_id,run_id) { +load_data_single_run <- function(bety, workflow_id, run_id) { # For a particular combination of workflow and run id, loads # all variables from all files. # @return Dataframe for one run # Adapted from earlier code in pecan/shiny/workflowPlot/server.R globalDF <- data.frame() - workflow <- collect(workflow(bety, workflow_id)) + workflow <- dplyr::collect(workflow(bety, workflow_id)) # Use the function 'var_names_all' to get all variables - removeVarNames <- c('Year','FracJulianDay') - var_names <- var_names_all(bety,workflow_id,run_id) + var_names <- var_names_all(bety, workflow_id, run_id) + # TODO: This looks a lot like `read.output`. Should probably just use that here. # Using earlier code, refactored - if(nrow(workflow) > 0) { + if (nrow(workflow) > 0) { outputfolder <- file.path(workflow$folder, 'out', run_id) - files <- list.files(outputfolder, "*.nc$", full.names=TRUE) - for(file in files) { + files <- list.files(outputfolder, "*.nc$", full.names = TRUE) + for (file in files) { nc <- nc_open(file) - for(var_name in var_names){ + for (var_name in var_names) { dates <- NA vals <- NA title <- var_name @@ -258,19 +264,19 @@ load_data_single_run <- function(bety, workflow_id,run_id) { # Snow water sw <- TRUE # Check required bcoz many files don't contain title - if(!is.null(var$long_name)){ + if (!is.null(var$long_name)) { title <- var$long_name } # Check required bcoz many files don't contain units - if(!is.null(var$units)){ + if (!is.null(var$units)) { ylab <- var$units } x <- ncdays2date(ncdf4::ncvar_get(nc, 'time'), ncdf4::ncatt_get(nc, 'time')) y <- ncdf4::ncvar_get(nc, var_name) b <- !is.na(x) & !is.na(y) & sw != 0 - dates <- if(is.na(dates)) x[b] else c(dates, x[b]) + dates <- if (is.na(dates)) x[b] else c(dates, x[b]) dates <- as.Date(dates) - vals <- if(is.na(vals)) y[b] else c(vals, y[b]) + vals <- if (is.na(vals)) y[b] else c(vals, y[b]) xlab <- "Time" # Values of the data which we will plot valuesDF <- data.frame(dates,vals) From d2845b11447b9491a1f2957377489a654a756502 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:27:44 -0500 Subject: [PATCH 389/771] DB: Cleanup `query.file.path` --- base/db/R/query.file.path.R | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/base/db/R/query.file.path.R b/base/db/R/query.file.path.R index de8e4f66680..9b399a8f789 100644 --- a/base/db/R/query.file.path.R +++ b/base/db/R/query.file.path.R @@ -4,16 +4,22 @@ ##' @param host_name ##' @param con : database connection ##' @export query.file.path -##' -##' @author Betsy Cowdery +##' +##' @author Betsy Cowdery query.file.path <- function(input.id, host_name, con){ - machine.host <- ifelse(host_name == "localhost", PEcAn.utils::fqdn(), host_name) - machine = db.query(paste0("SELECT * from machines where hostname = '",machine.host,"'"),con) - dbfile = db.query(paste("SELECT file_name,file_path from dbfiles where container_id =",input.id," and container_type = 'Input' and machine_id =",machine$id),con) + machine.host <- default_hostname(host_name) + machine <- db.query(query = paste0("SELECT * from machines where hostname = '",machine.host,"'"), con = con) + dbfile <- db.query( + query = paste( + "SELECT file_name,file_path from dbfiles where container_id =", input.id, + " and container_type = 'Input' and machine_id =", machine$id + ), + con = con + ) path <- file.path(dbfile$file_path,dbfile$file_name) cmd <- paste0("file.exists( '",path,"')") - remote.execute.R(cmd,machine.host,verbose=TRUE) - # Check - to be determined later + PEcAn.utils::remote.execute.R(script = cmd, host = machine.host, verbose=TRUE) + # Check - to be determined later # if(file.exists(path)){ # return(path) # }else{ From 58d18fe3145ab67eaaa20ad1770f6df37b4c4e30 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:28:07 -0500 Subject: [PATCH 390/771] DB: Cleanup `query.format.vars` --- base/db/R/query.format.vars.R | 151 ++++++++++++++++++++-------------- 1 file changed, 87 insertions(+), 64 deletions(-) diff --git a/base/db/R/query.format.vars.R b/base/db/R/query.format.vars.R index a6886484597..ef00620ae7c 100644 --- a/base/db/R/query.format.vars.R +++ b/base/db/R/query.format.vars.R @@ -3,110 +3,130 @@ ##' @param input_id ##' @param con : database connection ##' @export query.format.vars -##' +##' @importFrom dplyr `%>%` +##' ##' @author Betsy Cowdery , Ankur Desai, Istem Fer -##' -query.format.vars <- function(bety,input.id=NA,format.id=NA,var.ids=NA){ - - if(is.na(input.id) & is.na(format.id)){PEcAn.logger::logger.error("Must specify input id or format id")} - +##' +query.format.vars <- function(bety, input.id=NA, format.id=NA, var.ids=NA) { + + if(is.na(input.id) & is.na(format.id)){ + PEcAn.logger::logger.error("Must specify input id or format id") + } + con <- bety$con - + # get input info either form input.id or format.id, depending which is provided # defaults to format.id if both provided # also query site information (id/lat/lon) if an input.id - + site.id <- NULL site.lat <- NULL site.lon <- NULL site.time_zone <- NULL - + if (is.na(format.id)) { - f <- PEcAn.DB::db.query(paste("SELECT * from formats as f join inputs as i on f.id = i.format_id where i.id = ", input.id),con) - site.id <- PEcAn.DB::db.query(paste("SELECT site_id from inputs where id =",input.id),con) + f <- PEcAn.DB::db.query( + query = paste("SELECT * from formats as f join inputs as i on f.id = i.format_id where i.id = ", input.id), + con = con + ) + site.id <- PEcAn.DB::db.query(query = paste("SELECT site_id from inputs where id =", input.id), con = con) if (is.data.frame(site.id) && nrow(site.id)>0) { site.id <- site.id$site_id - site.info <- PEcAn.DB::db.query(paste("SELECT id, time_zone, ST_X(ST_CENTROID(geometry)) AS lon, ST_Y(ST_CENTROID(geometry)) AS lat FROM sites WHERE id =",site.id),con) + site.info <- + PEcAn.DB::db.query( + query = paste( + "SELECT id, time_zone, ST_X(ST_CENTROID(geometry)) AS lon, ST_Y(ST_CENTROID(geometry)) AS lat FROM sites WHERE id =", + site.id + ), + con = con + ) site.lat <- site.info$lat site.lon <- site.info$lon site.time_zone <- site.info$time_zone - } + } } else { - f <- PEcAn.DB::db.query(paste("SELECT * from formats where id = ", format.id),con) + f <- PEcAn.DB::db.query(query = paste("SELECT * from formats where id = ", format.id), con = con) } - - mimetype <- PEcAn.DB::db.query(paste("SELECT * from mimetypes where id = ", - f$mimetype_id),con)[["type_string"]] + + mimetype <- PEcAn.DB::db.query(query = paste("SELECT * from mimetypes where id = ", f$mimetype_id), con = con)[["type_string"]] f$mimetype <- tail(unlist(strsplit(mimetype, "/")),1) - + # get variable names and units of input data - fv <- PEcAn.DB::db.query(paste("SELECT variable_id,name,unit,storage_type,column_number from formats_variables where format_id = ", f$id),con) - + fv <- PEcAn.DB::db.query( + query = paste( + "SELECT variable_id,name,unit,storage_type,column_number from formats_variables where format_id = ", f$id + ), + con = con + ) + if(all(!is.na(var.ids))){ # Need to subset the formats table - fv <- fv %>% dplyr::filter(variable_id %in% var.ids | storage_type != "") + fv <- fv %>% dplyr::filter(variable_id %in% var.ids | storage_type != "") if(dim(fv)[1] == 0){ PEcAn.logger::logger.error("None of your requested variables are available") - } - + } + } - + if (nrow(fv)>0) { colnames(fv) <- c("variable_id", "input_name", "input_units", "storage_type", "column_number") fv$variable_id <- as.numeric(fv$variable_id) n <- dim(fv)[1] - - # get bety names and units + + # get bety names and units vars <- as.data.frame(matrix(NA, ncol=2, nrow=n)) colnames(vars) <- c("bety_name", "bety_units") - - # fv and vars need to go together from now on, - # otherwise when there are more than one of the same variable_id it confuses merge + + # fv and vars need to go together from now on, + # otherwise when there are more than one of the same variable_id it confuses merge vars_bety <- cbind(fv, vars) for(i in 1:n){ - vars_bety[i, (ncol(vars_bety)-1):ncol(vars_bety)] <- as.matrix(PEcAn.DB::db.query(paste("SELECT name, units from variables where id = ", - fv$variable_id[i]),con)) + vars_bety[i, (ncol(vars_bety) - 1):ncol(vars_bety)] <- + as.matrix(PEcAn.DB::db.query( + query = paste("SELECT name, units from variables where id = ", fv$variable_id[i]), + con = con + )) } - + # Fill in input names and units with bety names and units if they are missing - + ind1 <- fv$input_name == "" vars_bety$input_name[ind1] <- vars_bety$bety_name[ind1] ind2 <- fv$input_units == "" vars_bety$input_units[ind2] <- vars_bety$bety_units[ind2] - + # Fill in CF vars # This will ultimately be useful when looking at met variables where CF != Bety # met <- read.csv(system.file("/data/met.lookup.csv", package= "PEcAn.data.atmosphere"), header = T, stringsAsFactors=FALSE) - - #Fill in MstMIP vars - #All PEcAn output is in MstMIP variables - - bety_mstmip <- read.csv(system.file("bety_mstmip_lookup.csv", package= "PEcAn.DB"), header = T, stringsAsFactors=FALSE) + + #Fill in MstMIP vars + #All PEcAn output is in MstMIP variables + + bety_mstmip <- read.csv(system.file("bety_mstmip_lookup.csv", package= "PEcAn.DB"), header = T, stringsAsFactors = FALSE) vars_full <- merge(vars_bety, bety_mstmip, by = "bety_name", all.x = TRUE) - + vars_full$pecan_name <- vars_full$mstmip_name vars_full$pecan_units <- vars_full$mstmip_units ind <- is.na(vars_full$pecan_name) vars_full$pecan_name[ind] <- vars_full$bety_name[ind] vars_full$pecan_units[ind] <- vars_full$bety_units[ind] - + header <- as.numeric(f$header) skip <- ifelse(is.na(as.numeric(f$skip)),0,as.numeric(f$skip)) - - # Right now I'm making the inappropriate assumption that storage type will be - # empty unless it's a time variable. + + # Right now I'm making the inappropriate assumption that storage type will be + # empty unless it's a time variable. # This is because I haven't come up for a good way to test that a character string is a date format - + st <- vars_full$storage_type time.row <- which(nchar(st)>1 & substr(st, 1,1) == "%") if(length(time.row) == 0) time.row <- NULL - + # Final format list format <- list(file_name = f$name, mimetype = f$mimetype, vars = vars_full, - skip = skip, + skip = skip, header = header, na.strings=c("-9999","-6999","9999","NA"), # This shouldn't be hardcoded in, but not specified in format table ? time.row = time.row, @@ -115,23 +135,23 @@ query.format.vars <- function(bety,input.id=NA,format.id=NA,var.ids=NA){ lon = site.lon, time_zone = site.time_zone ) - - # Check that all bety units are convertible. If not, throw a warning. - for(i in 1:length(format$vars$bety_units)){ - - if( format$vars$storage_type[i] != ""){ #units with storage type are a special case - - # This would be a good place to put a test for valid sotrage types. Currently not implemented. - - }else if(udunits2::ud.are.convertible(format$vars$input_units[i], format$vars$pecan_units[i]) == FALSE){ - - if(PEcAn.utils::misc.are.convertible(format$vars$input_units[i], format$vars$pecan_units[i]) == FALSE){ + + # Check that all bety units are convertible. If not, throw a warning. + for (i in 1:length(format$vars$bety_units)) { + + if (format$vars$storage_type[i] != "") { #units with storage type are a special case + + # This would be a good place to put a test for valid sotrage types. Currently not implemented. + + } else if (udunits2::ud.are.convertible(format$vars$input_units[i], format$vars$pecan_units[i]) == FALSE) { + + if (PEcAn.utils::misc.are.convertible(format$vars$input_units[i], format$vars$pecan_units[i]) == FALSE) { PEcAn.logger::logger.warn("Units not convertible for",format$vars$input_name[i], "with units of",format$vars$input_units[i], ". Please make sure the varible has units that can be converted to", format$vars$pecan_units[i]) } - + } } - + } else { format <- list(file_name = f$name, @@ -144,11 +164,14 @@ query.format.vars <- function(bety,input.id=NA,format.id=NA,var.ids=NA){ time_zone = site.time_zone ) } - if(length(unique(format$vars$pecan_name))!=length(format$vars$pecan_name)){ - unique_cols<-match(unique(format$vars$pecan_name), format$vars$pecan_name) - PEcAn.logger::logger.warn("There are duplicate columns in format record",format$file_name, "If format is not wide format, check column(s)",format$vars$pecan_name[-unique_cols]) + if (length(unique(format$vars$pecan_name))!=length(format$vars$pecan_name)) { + unique_cols <- match(unique(format$vars$pecan_name), format$vars$pecan_name) + PEcAn.logger::logger.warn( + "There are duplicate columns in format record", format$file_name, + ". If format is not wide format, check column(s)", format$vars$pecan_name[-unique_cols] + ) } return(format) -} \ No newline at end of file +} From f3d35bdfa2873edb447b0afc088c949367a90cbd Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:28:49 -0500 Subject: [PATCH 391/771] DB: Cleanup `query.pft.R` --- base/db/R/query.pft.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/base/db/R/query.pft.R b/base/db/R/query.pft.R index f2284ee2c25..ce5bcdee79a 100644 --- a/base/db/R/query.pft.R +++ b/base/db/R/query.pft.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -22,7 +22,7 @@ ##' query.pft_species('ebifarm.pavi') ##' query.pft_species(settings = read.settings("pecan.xml")) ##' } -query.pft_species <- function(pft, modeltype, con){ +query.pft_species <- function(pft, modeltype, con) { # create pft subquery if (is.null(modeltype)) { query <- paste0("select species.id, species.genus, species.species, species.scientificname", @@ -40,12 +40,12 @@ query.pft_species <- function(pft, modeltype, con){ " and modeltypes.name='", modeltype, "'") } - species <- db.query(query, con) + species <- db.query(query = query, con = con) invisible(species) } #==================================================================================================# #################################################################################################### -### EOF. End of R script file. +### EOF. End of R script file. #################################################################################################### From be859002f828b30a921f6e7aefff49d3651b26ad Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:29:28 -0500 Subject: [PATCH 392/771] DB: Cleanup `query.prior.R` --- base/db/R/query.prior.R | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/base/db/R/query.prior.R b/base/db/R/query.prior.R index 7de1fc1eda9..ba6238b19fa 100644 --- a/base/db/R/query.prior.R +++ b/base/db/R/query.prior.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -23,8 +23,8 @@ ##' \dontrun{ ##' query.priors('ebifarm.pavi', vecpaste('SLA', 'Vcmax', 'leaf_width')) ##' } -query.priors <- function(pft, trstr=NULL, out=NULL, con=NULL,...){ - +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)) @@ -34,30 +34,30 @@ query.priors <- function(pft, trstr=NULL, out=NULL, con=NULL,...){ print("WEB QUERY OF DATABASE NOT IMPLEMENTED") return(NULL) } - + query.text <- paste("select variables.name, distn, parama, paramb, n", "from priors", "join variables on priors.variable_id = variables.id", "join pfts_priors on pfts_priors.prior_id = priors.id", "join pfts on pfts.id = pfts_priors.pft_id", "where pfts.id = ", pft) - + if(is.null(trstr) || trstr == "''"){ query.text = paste(query.text,";",sep="") } else { query.text = paste(query.text,"and variables.name in (", trstr, ");") } - - - priors <- db.query(query.text, con) - - + + + priors <- db.query(query = query.text, con = con) + + if(nrow(priors) <= 0){ warning(paste("No priors found for pft(s): ", pft)) priors <- priors[, which(colnames(priors)!='name')] return(priors) } - else { + else { rownames(priors) <- priors$name priors <- priors[, which(colnames(priors)!='name')] return(priors) @@ -67,5 +67,5 @@ query.priors <- function(pft, trstr=NULL, out=NULL, con=NULL,...){ #################################################################################################### -### EOF. End of R script file. +### EOF. End of R script file. #################################################################################################### From be576e7e831fd3bef0392dcbb97f0391c6c4dbd4 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:30:26 -0500 Subject: [PATCH 393/771] DB: Cleanup `query.site.R` --- base/db/R/query.site.R | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/base/db/R/query.site.R b/base/db/R/query.site.R index 71f58fbac65..30789282bdf 100644 --- a/base/db/R/query.site.R +++ b/base/db/R/query.site.R @@ -3,16 +3,23 @@ ##' @param site_id ##' @param con : database connection ##' @export query.site -##' -##' @author Betsy Cowdery -##' +##' +##' @author Betsy Cowdery +##' query.site <- function(site.id,con){ - site <- db.query(paste("SELECT *, ST_X(ST_CENTROID(geometry)) AS lon, ST_Y(ST_CENTROID(geometry)) - AS lat FROM sites WHERE id =",site.id),con) - if(nrow(site)==0){logger.error("Site not found"); return(NULL)} - if(!(is.na(site$lon)) && !(is.na(site$lat))){ + site <- db.query( + query = paste( + "SELECT *, ST_X(ST_CENTROID(geometry)) AS lon, ST_Y(ST_CENTROID(geometry)) + AS lat FROM sites WHERE id =", site.id + ), + con = con + ) + if (nrow(site)==0) { + logger.error("Site not found"); return(NULL) + } + if (!(is.na(site$lon)) && !(is.na(site$lat))) { return(site) } else { return(NULL) } -} \ No newline at end of file +} From 04829f5bb9ecd46bfe95fb0033756981901896f6 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 23 Aug 2017 13:30:47 -0400 Subject: [PATCH 394/771] Allow model2netcdf to process partial years --- models/sipnet/R/model2netcdf.SIPNET.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/models/sipnet/R/model2netcdf.SIPNET.R b/models/sipnet/R/model2netcdf.SIPNET.R index 869f949f904..d15af5379cd 100644 --- a/models/sipnet/R/model2netcdf.SIPNET.R +++ b/models/sipnet/R/model2netcdf.SIPNET.R @@ -29,10 +29,12 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, sipnet.output.dims <- dim(sipnet.output) ### Determine number of years and output timestep + start.day <- sipnet.output$day[1] num.years <- length(unique(sipnet.output$year)) years <- unique(sipnet.output$year) - timestep.s <- 86400 / length(which(sipnet.output$year == years[1] & sipnet.output$day == 1)) - out.day <- length(which(sipnet.output$year == years[1] & sipnet.output$day == 1)) + out.day <- length(which(sipnet.output$year == years[1] & sipnet.output$day == start.day)) + timestep.s <- 86400 / out.day + ### Loop over years in SIPNET output to create separate netCDF outputs for (y in years) { @@ -45,7 +47,7 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, sub.sipnet.output <- subset(sipnet.output, year == y) sub.sipnet.output.dims <- dim(sub.sipnet.output) dayfrac <- 1 / out.day - step <- seq(0, 0.99, 1 / out.day) + step <- seq(0, 0.99, dayfrac) ## Setup outputs for netCDF file in appropriate units output <- list() From ea451a9a67c26bff16535d71e47c30f1aac896fb Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:38:39 -0500 Subject: [PATCH 395/771] DB: Cleanup `query.trait.data.R` --- base/db/R/query.trait.data.R | 99 +++++++++++++++++------------------- 1 file changed, 48 insertions(+), 51 deletions(-) diff --git a/base/db/R/query.trait.data.R b/base/db/R/query.trait.data.R index 3d6d928ad0c..e0e9d871f69 100644 --- a/base/db/R/query.trait.data.R +++ b/base/db/R/query.trait.data.R @@ -19,7 +19,7 @@ ##' @seealso used in \code{\link{query.trait.data}}; \code{\link{transformstats}} performs transformation calculations ##' @author fetch.stats2se <- function(connection, query){ - transformed <- PEcAn.utils::transformstats(db.query(query, connection)) + transformed <- PEcAn.utils::transformstats(db.query(query = query, con = connection)) return(transformed) } ##==================================================================================================# @@ -57,13 +57,13 @@ query.data <- function(trait, spstr, extra.columns='ST_X(ST_CENTROID(sites.geome left join variables on (traits.variable_id = variables.id) where specie_id in (", spstr,") and variables.name in ('", trait,"');", sep = "") - result <- fetch.stats2se(con, query) - + result <- fetch.stats2se(connection = con, query = query) + if(store.unconverted) { result$mean_unconverted <- result$mean result$stat_unconverted <- result$stat } - + return(result) } ##==================================================================================================# @@ -100,7 +100,7 @@ query.yields <- function(trait = 'yield', spstr, extra.columns='', con=NULL, ... query <- gsub(");", paste(" and variables.name in ('", trait,"');", sep = ""), query) } - return(fetch.stats2se(con, query)) + return(fetch.stats2se(connection = con, query = query)) } ##==================================================================================================# @@ -111,9 +111,9 @@ query.yields <- function(trait = 'yield', spstr, extra.columns='', con=NULL, ... ##' ##' @name append.covariate ##' @title Append covariate data as a column within a table -##' \code{append.covariate} appends a data frame of covariates as a new column in a data frame +##' \code{append.covariate} appends a data frame of covariates as a new column in a data frame ##' of trait data. -##' In the event a trait has several covariates available, the first one found +##' In the event a trait has several covariates available, the first one found ##' (i.e. lowest row number) will take precedence ##' ##' @param data trait dataframe that will be appended to. @@ -153,8 +153,8 @@ append.covariate<-function(data, column.name, covariates.data){ query.covariates<-function(trait.ids, con = NULL, ...){ covariate.query <- paste("select covariates.trait_id, covariates.level,variables.name", "from covariates left join variables on variables.id = covariates.variable_id", - "where trait_id in (",vecpaste(trait.ids),")") - covariates <- db.query(covariate.query, con) + "where trait_id in (", PEcAn.utils::vecpaste(trait.ids), ")") + covariates <- db.query(query = covariate.query, con = con) return(covariates) } ##==================================================================================================# @@ -166,7 +166,7 @@ query.covariates<-function(trait.ids, con = NULL, ...){ ##' @title Function to apply Arrhenius scaling to 25 degC for temperature-dependent traits ##' @param data data frame of data to scale, as returned by query.data() ##' @param covariates data frame of covariates, as returned by query.covariates(). -##' Note that data with no matching covariates will be unchanged. +##' Note that data with no matching covariates will be unchanged. ##' @param temp.covariates names of covariates used to adjust for temperature; ##' if length > 1, order matters (first will be used preferentially) ##' @param new.temp the reference temperature for the scaled traits. Curerntly 25 degC @@ -175,21 +175,21 @@ query.covariates<-function(trait.ids, con = NULL, ...){ arrhenius.scaling.traits <- function(data, covariates, temp.covariates, new.temp=25, missing.temp=25){ # Select covariates that match temp.covariates covariates <- covariates[covariates$name %in% temp.covariates,] - + if(nrow(covariates)>0) { # Sort covariates in order of priority - covariates <- do.call(rbind, + covariates <- do.call(rbind, lapply(temp.covariates, function(temp.covariate) covariates[covariates$name == temp.covariate, ]) ) - + data <- append.covariate(data, 'temp', covariates) # Assign default value for traits with no covariates data$temp[is.na(data$temp)] <- missing.temp - + # Scale traits - data$mean <- PEcAn.utils::arrhenius.scaling(data$mean, old.temp = data$temp, new.temp=new.temp) - data$stat <- PEcAn.utils::arrhenius.scaling(data$stat, old.temp = data$temp, new.temp=new.temp) + data$mean <- PEcAn.utils::arrhenius.scaling(observed.value = data$mean, old.temp = data$temp, new.temp=new.temp) + data$stat <- PEcAn.utils::arrhenius.scaling(observed.value = data$stat, old.temp = data$temp, new.temp=new.temp) #remove temporary covariate column. data<-data[,colnames(data)!='temp'] @@ -212,12 +212,12 @@ arrhenius.scaling.traits <- function(data, covariates, temp.covariates, new.temp ##' @author filter_sunleaf_traits <- function(data, covariates){ if(length(covariates)>0) { - data <- append.covariate(data, 'canopy_layer', - covariates[covariates$name == 'canopy_layer',]) - data <- data[data$canopy_layer >= 0.66 | is.na(data$canopy_layer),] - + data <- append.covariate(data = data, column.name = 'canopy_layer', + covariates.data = covariates[covariates$name == 'canopy_layer',]) + data <- data[data$canopy_layer >= 0.66 | is.na(data$canopy_layer),] + # remove temporary covariate column - data<-data[,colnames(data)!='canopy_layer'] + data <- data[,colnames(data)!='canopy_layer'] } else { data <- NULL } @@ -315,7 +315,7 @@ take.samples <- function(summary, sample.size = 10^6){ ans <- summary$mean } else { set.seed(0) - ans <- rnorm(sample.size, summary$mean, summary$stat) + ans <- rnorm(n = sample.size, mean = summary$mean, sd = summary$stat) } return(ans) } @@ -372,14 +372,14 @@ derive.trait <- function(FUN, ..., input=list(...), var.name=NA, sample.size=10^ ##' @param match.columns in the event more than one trait dataset is supplied, ##' this specifies the columns that identify a unique data point ##' @return a copy of the first input trait with modified mean, stat, and n -derive.traits <- function(FUN, ..., input=list(...), - match.columns=c('citation_id', 'site_id', 'specie_id'), - var.name=NA, sample.size=10^6){ +derive.traits <- function(FUN, ..., input = list(...), + match.columns = c('citation_id', 'site_id', 'specie_id'), + var.name = NA, sample.size = 10^6){ if(length(input) == 1){ - input<-input[[1]] + input <- input[[1]] #KLUDGE: modified to handle empty datasets for(i in (0:nrow(input))[-1]){ - input[i,]<-derive.trait(FUN, input[i,], sample.size=sample.size) + input[i,] <- derive.trait(FUN, input[i,], sample.size=sample.size) } return(input) } @@ -403,10 +403,8 @@ derive.traits <- function(FUN, ..., input=list(...), derived.traits <- derived.traits[!is.null(derived.traits)] derived.traits <- do.call(rbind, derived.traits) return(derived.traits) - } - else{ - return(derive.trait(FUN, input=input, - var.name=var.name, sample.size=sample.size)) + } else { + return(derive.trait(FUN, input=input, var.name=var.name, sample.size=sample.size)) } } ##==================================================================================================# @@ -436,27 +434,26 @@ derive.traits <- function(FUN, ..., input=list(...), query.trait.data <- function(trait, spstr, con = NULL, update.check.only=FALSE, ...){ if(is.list(con)){ - print("query.trait.data") - print("WEB QUERY OF DATABASE NOT IMPLEMENTED") + PEcAn.logger::logger.warn("WEB QUERY OF DATABASE NOT IMPLEMENTED") return(NULL) } # print trait info if(!update.check.only) { - print("---------------------------------------------------------") - print(trait) + PEcAn.logger::logger.info("---------------------------------------------------------") + PEcAn.logger::logger.info(trait) } ### Query the data from the database for trait X. - data <- query.data(trait, spstr, con=con, store.unconverted=TRUE) + data <- query.data(trait = trait, spstr = spstr, con = con, store.unconverted = TRUE) ### Query associated covariates from database for trait X. - covariates <- query.covariates(data$id, con=con) + covariates <- query.covariates(trait.ids = data$id, con = con) canopy.layer.covs <- covariates[covariates$name == 'canopy_layer', ] ### Set small sample size for derived traits if update-checking only. Otherwise use default. if(update.check.only) { - sample.size <- 10 + sample.size <- 10 } else { sample.size <- 10^6 ## Same default as derive.trait(), derive.traits(), and take.samples() } @@ -464,10 +461,10 @@ query.trait.data <- function(trait, spstr, con = NULL, update.check.only=FALSE, if(trait == 'Vcmax') { ######################### VCMAX ############################ ### Apply Arrhenius scaling to convert Vcmax at measurement temp to that at 25 degC (ref temp). - data <- arrhenius.scaling.traits(data, covariates, c('leafT', 'airT','T')) + data <- arrhenius.scaling.traits(data = data, covariates = covariates, temp.covariates = c('leafT', 'airT','T')) ### Keep only top of canopy/sunlit leaf samples based on covariate. - if(nrow(canopy.layer.covs) > 0) data <- filter_sunleaf_traits(data, canopy.layer.covs) + if(nrow(canopy.layer.covs) > 0) data <- filter_sunleaf_traits(data = data, covariates = canopy.layer.covs) ## select only summer data for Panicum virgatum ##TODO fix following hack to select only summer data @@ -484,7 +481,7 @@ query.trait.data <- function(trait, spstr, con = NULL, update.check.only=FALSE, sample.size=sample.size)) ### Keep only top of canopy/sunlit leaf samples based on covariate. - if(nrow(canopy.layer.covs) > 0) data <- filter_sunleaf_traits(data, canopy.layer.covs) + if(nrow(canopy.layer.covs) > 0) data <- filter_sunleaf_traits(data = data, covariates = canopy.layer.covs) ## select only summer data for Panicum virgatum ##TODO fix following hack to select only summer data @@ -504,38 +501,38 @@ query.trait.data <- function(trait, spstr, con = NULL, update.check.only=FALSE, ######################### ROOT RESPIRATION ############################ ## Apply Arrhenius scaling to convert root respiration at measurement temp ## to that at 25 degC (ref temp). - data <- arrhenius.scaling.traits(data, covariates, c('rootT', 'airT','soilT')) + data <- arrhenius.scaling.traits(data = data, covariates = covariates, temp.covariates = c('rootT', 'airT','soilT')) } else if (trait == 'leaf_respiration_rate_m2') { ######################### LEAF RESPIRATION ############################ ## Apply Arrhenius scaling to convert leaf respiration at measurement temp ## to that at 25 degC (ref temp). - data <- arrhenius.scaling.traits(data, covariates, c('leafT', 'airT','T')) + data <- arrhenius.scaling.traits(data = data, covariates = covariates, temp.covariates = c('leafT', 'airT','T')) } else if (trait == 'stem_respiration_rate') { ######################### STEM RESPIRATION ############################ ## Apply Arrhenius scaling to convert stem respiration at measurement temp ## to that at 25 degC (ref temp). - data <- arrhenius.scaling.traits(data, covariates, c('leafT', 'airT')) + data <- arrhenius.scaling.traits(data = data, covariates = covariates, temp.covariates = c('leafT', 'airT')) } else if (trait == 'c2n_leaf') { ######################### LEAF C:N ############################ data <- rbind(data, derive.traits(function(leafN){48/leafN}, - query.data('leafN', spstr, con=con, store.unconverted=TRUE), - sample.size=sample.size)) + query.data('leafN', spstr, con = con, store.unconverted = TRUE), + sample.size = sample.size)) } else if (trait == 'fineroot2leaf') { ######################### FINE ROOT ALLOCATION ############################ ## FRC_LC is the ratio of fine root carbon to leaf carbon - data<-rbind(data, query.data('FRC_LC', spstr, con=con, store.unconverted=TRUE)) + data <- rbind(data, query.data(trait = 'FRC_LC', spstr = spstr, con = con, store.unconverted = TRUE)) } result <- data ## if result is empty, stop run - if(nrow(result)==0) { + if (nrow(result)==0) { return(NA) warning(paste("there is no data for", trait)) } else { @@ -543,9 +540,9 @@ query.trait.data <- function(trait, spstr, con = NULL, update.check.only=FALSE, ## Do we really want to print each trait table?? Seems like a lot of ## info to send to console. Maybe just print summary stats? ## print(result) - if(!update.check.only) { - print(paste("Median ",trait," : ",round(median(result$mean,na.rm=TRUE),digits=3),sep="")) - print("---------------------------------------------------------") + if (!update.check.only) { + PEcAn.logger::logger.info(paste("Median ",trait," : ",round(median(result$mean,na.rm=TRUE),digits=3),sep="")) + PEcAn.logger::logger.info("---------------------------------------------------------") } # print list of traits queried and number by outdoor/glasshouse return(result) From 5dd053f04d95fbbf21b04a22c5289ec7adc1898c Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:39:58 -0500 Subject: [PATCH 396/771] DB: Cleanup `query.traits.R` --- base/db/R/query.traits.R | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) diff --git a/base/db/R/query.traits.R b/base/db/R/query.traits.R index 93310d08a58..892e168f96c 100644 --- a/base/db/R/query.traits.R +++ b/base/db/R/query.traits.R @@ -1,19 +1,19 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html #------------------------------------------------------------------------------- #--------------------------------------------------------------------------------------------------# ##' Query available trait data associated with a given pft and a list of traits -##' +##' ##' @name query.traits ##' @title Query trait data ##' @param spstr string of species id's from trait database -##' @param priors vector of parameters for which priors have been specified -##' @param con +##' @param priors vector of parameters for which priors have been specified +##' @param con ##' @return dataframe with trait data ##' @seealso \code{\link{query.trait.data}} ##' @export query.traits @@ -36,25 +36,31 @@ query.traits <- function(spstr, priors, con = NULL, update.check.only=FALSE){ print("WEB QUERY OF DATABASE NOT IMPLEMENTED") return(NULL) } - + if(!spstr == "''"){ - query <- paste("select distinct variables.name from traits join variables + query <- paste("select distinct variables.name from traits join variables on (traits.variable_id = variables.id) where specie_id in (", spstr,");", sep = "") - traits <- db.query(query, con)$name + traits <- db.query(query = query, con = con)[['name']] traits <- unique(traits[traits %in% priors]) - + ### Grab trait data - trait.data <- lapply(traits, function(trait) query.trait.data(trait, spstr, con=con, update.check.only=update.check.only)) + trait.data <- lapply(traits, function(trait) + query.trait.data( + trait = trait, + spstr = spstr, + con = con, + update.check.only = update.check.only + )) names(trait.data) <- traits } else { trait.data <- list() } - + return(trait.data) } #==================================================================================================# #################################################################################################### -### EOF. End of R script file. +### EOF. End of R script file. #################################################################################################### From e7dc76567e0d1ee161d07fc852a80c54768f990c Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:42:44 -0500 Subject: [PATCH 397/771] DB: Cleanup `utils.R` --- base/db/R/utils.R | 81 ++++++++++++++++++++++++++--------------------- 1 file changed, 45 insertions(+), 36 deletions(-) diff --git a/base/db/R/utils.R b/base/db/R/utils.R index 4d3a3cf1671..ab42176da11 100644 --- a/base/db/R/utils.R +++ b/base/db/R/utils.R @@ -1,13 +1,13 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html #------------------------------------------------------------------------------- -.db.utils <- new.env() +.db.utils <- new.env() .db.utils$created <- 0 .db.utils$queries <- 0 .db.utils$deprecated <- 0 @@ -69,15 +69,15 @@ db.query <- function(query, con=NULL, params=NULL) { db.open <- function(params) { params$dbfiles <- NULL params$write <- NULL - + if(is.null(params$driver) || params$driver == "PostgreSQL") { requireNamespace("RPostgreSQL") } - + if (is.null(params$driver)) { - args <- c(drv=DBI::dbDriver("PostgreSQL"), params, recursive=TRUE) + args <- c(drv = DBI::dbDriver("PostgreSQL"), params, recursive = TRUE) } else { - args <- c(drv=DBI::dbDriver(params$driver), params, recursive=TRUE) + args <- c(drv = DBI::dbDriver(params$driver), params, recursive = TRUE) args[['driver']] <- NULL } @@ -113,12 +113,12 @@ db.close <- function(con, showWarnings=TRUE) { if (is.null(con)) { return() } - + id <- attr(con, "pecanid") if (showWarnings && is.null(id)) { PEcAn.logger::logger.warn("Connection created outside of PEcAn.DB package") } else { - deleteme <- which(.db.utils$connections$id==id) + deleteme <- which(.db.utils$connections$id == id) if (showWarnings && length(deleteme) == 0) { PEcAn.logger::logger.warn("Connection might have been closed already."); } else { @@ -161,7 +161,7 @@ db.print.connections <- function() { } ##' Test connection to database -##' +##' ##' Useful to only run tests that depend on database when a connection exists ##' @title db.exists ##' @param params database connection information @@ -181,7 +181,7 @@ db.exists <- function(params, write=TRUE, table=NA) { } else { on.exit(db.close(con)) } - + #check table's privilege about read and write permission user.permission <<- tryCatch({ invisible(db.query(paste0("select privilege_type from information_schema.role_table_grants where grantee='",params$user,"' and table_catalog = '",params$dbname,"' and table_name='",table,"'"), con)) @@ -194,43 +194,43 @@ db.exists <- function(params, write=TRUE, table=NA) { if (!is.na(table)){ read.perm = FALSE write.perm = FALSE - + # check read permission if ('SELECT' %in% user.permission[['privilege_type']]) { read.perm = TRUE } - + #check write permission if ('INSERT' %in% user.permission[['privilege_type']] &&'UPDATE' %in% user.permission[['privilege_type']] ) { write.perm = TRUE } - + if (read.perm == FALSE){ return(invisible(FALSE)) } - + # read a row from the database read.result <- tryCatch({ - invisible(db.query(paste("SELECT * FROM", table, "LIMIT 1"), con)) + invisible(db.query(query = paste("SELECT * FROM", table, "LIMIT 1"), con = con)) }, error = function(e) { PEcAn.logger::logger.error("Could not query database.\n\t", e) db.close(con) invisible(NULL) - }) + }) if (is.null(read.result)) { return(invisible(FALSE)) } - + # get the table's primary key column get.key <- tryCatch({ - db.query(paste("SELECT pg_attribute.attname,format_type(pg_attribute.atttypid, pg_attribute.atttypmod) - FROM pg_index, pg_class, pg_attribute - WHERE - pg_class.oid = '",table,"'::regclass AND + db.query(query = paste("SELECT pg_attribute.attname,format_type(pg_attribute.atttypid, pg_attribute.atttypmod) + FROM pg_index, pg_class, pg_attribute + WHERE + pg_class.oid = '", table, "'::regclass AND indrelid = pg_class.oid AND - pg_attribute.attrelid = pg_class.oid AND + pg_attribute.attrelid = pg_class.oid AND pg_attribute.attnum = any(pg_index.indkey) - AND indisprimary"), con) + AND indisprimary"), con = con) }, error = function(e) { PEcAn.logger::logger.error("Could not query database.\n\t", e) db.close(con) @@ -239,7 +239,7 @@ db.exists <- function(params, write=TRUE, table=NA) { if (is.null(read.result)) { return(invisible(FALSE)) } - + # if requested write a row to the database if (write) { # in the case when has read permission but no write @@ -247,9 +247,9 @@ db.exists <- function(params, write=TRUE, table=NA) { { return(invisible(FALSE)) } - + # when the permission correct to check whether write works - key <- get.key$attname + key <- get.key$attname key.value<- read.result[key] coln.name <- names(read.result) write.coln <- "" @@ -257,13 +257,14 @@ db.exists <- function(params, write=TRUE, table=NA) { { if (name != key) { - write.coln <- name - break + write.coln <- name + break } } write.value <- read.result[write.coln] result <- tryCatch({ - db.query(paste("UPDATE ", table, " SET ", write.coln,"='", write.value, "' WHERE ", key, "=", key.value, sep=""), con) + db.query(query = paste("UPDATE ", table, " SET ", write.coln,"='", write.value, "' WHERE ", key, "=", key.value, sep=""), + con = con) invisible(TRUE) }, error = function(e) { PEcAn.logger::logger.error("Could not write to database.\n\t", e) @@ -273,16 +274,16 @@ db.exists <- function(params, write=TRUE, table=NA) { result <- TRUE } } - + else{ result <- TRUE } - + invisible(result) } ##' Sets if the queries should be shown that are being executed -##' +##' ##' Useful to print queries when debuging SQL statements ##' @title db.showQueries ##' @param show set to TRUE to show the queries, FALSE by default @@ -293,7 +294,7 @@ db.showQueries <- function(show) { } ##' Returns if the queries should be shown that are being executed -##' +##' ##' @title db.getShowQueries ##' @return will return TRUE if queries are shown ##' @export @@ -303,7 +304,7 @@ db.getShowQueries <- function() { } ##' Retrieve id from a table matching query -##' +##' ##' @title get.id ##' @param table name of table ##' @param colnames names of one or more columns used in where clause @@ -320,15 +321,23 @@ get.id <- function(table, colnames, values, con, create=FALSE, dates=FALSE){ values <- lapply(values, function(x) ifelse(is.character(x), shQuote(x), x)) where_clause <- paste(colnames, values , sep = " = ", collapse = " and ") query <- paste("select id from", table, "where", where_clause, ";") - id <- db.query(query, con)[["id"]] + id <- db.query(query = query, con = con)[["id"]] if (is.null(id) && create) { colinsert <- paste0(colnames, collapse=", ") if (dates) colinsert <- paste0(colinsert, ", created_at, updated_at") valinsert <- paste0(values, collapse=", ") if (dates) valinsert <- paste0(valinsert, ", NOW(), NOW()") PEcAn.logger::logger.info("INSERT INTO ", table, " (", colinsert, ") VALUES (", valinsert, ")") - db.query(paste0("INSERT INTO ", table, " (", colinsert, ") VALUES (", valinsert, ")"), con) + db.query(query = paste0("INSERT INTO ", table, " (", colinsert, ") VALUES (", valinsert, ")"), con = con) id <- db.query(query, con)[["id"]] } return(id) } + +##' Convenience function to fix hostname if localhost +default_hostname <- function(hostname) { + if (hostname == "localhost") { + hostname <- PEcAn.utils::fqdn(); + } + return(hostname) +} From dd764d37fe4addaee28f10f0b26277837e2de8f7 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:50:18 -0500 Subject: [PATCH 398/771] DB: Update documentation, fix imports. --- base/db/.Rbuildignore | 2 ++ base/db/DESCRIPTION | 5 ++--- base/db/NAMESPACE | 3 --- base/db/R/query.dplyr.R | 3 --- base/db/R/query.format.vars.R | 1 - base/db/R/zz.imports.R | 3 +++ base/db/man/append.covariate.Rd | 4 ++-- base/db/man/dbfile.insert.Rd | 6 ++++-- base/db/man/default_hostname.Rd | 11 +++++++++++ base/db/man/killdbcons.Rd | 22 ---------------------- base/db/man/priordupe.Rd | 7 ------- base/db/man/query.base.Rd | 31 ------------------------------- base/db/man/query.base.con.Rd | 27 --------------------------- base/db/man/query.close.Rd | 25 ------------------------- base/db/man/query.traits.Rd | 2 -- 15 files changed, 24 insertions(+), 128 deletions(-) create mode 100644 base/db/.Rbuildignore create mode 100644 base/db/R/zz.imports.R create mode 100644 base/db/man/default_hostname.Rd delete mode 100644 base/db/man/killdbcons.Rd delete mode 100644 base/db/man/query.base.Rd delete mode 100644 base/db/man/query.base.con.Rd delete mode 100644 base/db/man/query.close.Rd diff --git a/base/db/.Rbuildignore b/base/db/.Rbuildignore new file mode 100644 index 00000000000..91114bf2f2b --- /dev/null +++ b/base/db/.Rbuildignore @@ -0,0 +1,2 @@ +^.*\.Rproj$ +^\.Rproj\.user$ diff --git a/base/db/DESCRIPTION b/base/db/DESCRIPTION index 01a546e9d2c..af67e5ca3fa 100644 --- a/base/db/DESCRIPTION +++ b/base/db/DESCRIPTION @@ -11,11 +11,10 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific model parameterization, execution, and analysis. The goal of PECAn is to streamline the interaction between data and models, and to improve the efficacy of scientific investigation. -Depends: - DBI, - PEcAn.utils Imports: + DBI, PEcAn.logger, + PEcAn.utils, plyr (>= 1.8.4) Suggests: RPostgreSQL, diff --git a/base/db/NAMESPACE b/base/db/NAMESPACE index 772019202cf..fd732f7105e 100644 --- a/base/db/NAMESPACE +++ b/base/db/NAMESPACE @@ -32,9 +32,6 @@ export(get_var_names) export(get_workflow_ids) export(load_data_single_run) export(ncdays2date) -export(query.base) -export(query.base.con) -export(query.close) export(query.file.path) export(query.format.vars) export(query.pft_species) diff --git a/base/db/R/query.dplyr.R b/base/db/R/query.dplyr.R index 55ffb7e79a5..d0bdb36092d 100644 --- a/base/db/R/query.dplyr.R +++ b/base/db/R/query.dplyr.R @@ -62,7 +62,6 @@ ncdays2date <- function(time, unit) { #' @name dbHostInfo #' @title Database host information #' @param bety BETYdb connection, as opened by `betyConnect()` -#' @importFrom dplyr `%>%` #' @export dbHostInfo <- function(bety) { # get host id @@ -89,7 +88,6 @@ dbHostInfo <- function(bety) { #' list of workflows that exist #' @param ensemble Logical. Use workflows from ensembles table. #' @inheritParams dbHostInfo -#' @importFrom dplyr `%>%` #' @export workflows <- function(bety, ensemble = FALSE) { hostinfo <- dbHostInfo(bety) @@ -108,7 +106,6 @@ workflows <- function(bety, ensemble = FALSE) { #' Get single workflow by workflow_id #' @param workflow_id Workflow ID #' @inheritParams dbHostInfo -#' @importFrom dplyr `%>%` #' @export workflow <- function(bety, workflow_id) { workflows(bety) %>% diff --git a/base/db/R/query.format.vars.R b/base/db/R/query.format.vars.R index ef00620ae7c..e7af2e2ecbc 100644 --- a/base/db/R/query.format.vars.R +++ b/base/db/R/query.format.vars.R @@ -3,7 +3,6 @@ ##' @param input_id ##' @param con : database connection ##' @export query.format.vars -##' @importFrom dplyr `%>%` ##' ##' @author Betsy Cowdery , Ankur Desai, Istem Fer ##' diff --git a/base/db/R/zz.imports.R b/base/db/R/zz.imports.R new file mode 100644 index 00000000000..050b5a37cf9 --- /dev/null +++ b/base/db/R/zz.imports.R @@ -0,0 +1,3 @@ +##' Imports from other packages +##' +##' @importFrom magrittr `%>%` diff --git a/base/db/man/append.covariate.Rd b/base/db/man/append.covariate.Rd index 07885f0b276..f16f6772204 100644 --- a/base/db/man/append.covariate.Rd +++ b/base/db/man/append.covariate.Rd @@ -3,9 +3,9 @@ \name{append.covariate} \alias{append.covariate} \title{Append covariate data as a column within a table -\code{append.covariate} appends a data frame of covariates as a new column in a data frame +\code{append.covariate} appends a data frame of covariates as a new column in a data frame of trait data. -In the event a trait has several covariates available, the first one found +In the event a trait has several covariates available, the first one found (i.e. lowest row number) will take precedence} \usage{ append.covariate(data, column.name, covariates.data) diff --git a/base/db/man/dbfile.insert.Rd b/base/db/man/dbfile.insert.Rd index c6e78e89e0b..5be2ffc334e 100644 --- a/base/db/man/dbfile.insert.Rd +++ b/base/db/man/dbfile.insert.Rd @@ -8,12 +8,14 @@ dbfile.insert(in.path, in.prefix, type, id, con, reuse = TRUE, hostname = PEcAn.utils::fqdn()) } \arguments{ +\item{in.path}{Path to file directory} + +\item{in.prefix}{Filename prefix (not including directory)} + \item{con}{database connection object} \item{hostname}{the name of the host where the file is stored, this will default to the name of the current machine} -\item{filename}{the name of the file to be inserted} - \item{params}{database connection information} } \value{ diff --git a/base/db/man/default_hostname.Rd b/base/db/man/default_hostname.Rd new file mode 100644 index 00000000000..ce361e1e22c --- /dev/null +++ b/base/db/man/default_hostname.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{default_hostname} +\alias{default_hostname} +\title{Convenience function to fix hostname if localhost} +\usage{ +default_hostname(hostname) +} +\description{ +Convenience function to fix hostname if localhost +} diff --git a/base/db/man/killdbcons.Rd b/base/db/man/killdbcons.Rd deleted file mode 100644 index 12a84e4a19d..00000000000 --- a/base/db/man/killdbcons.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/query.base.R -\name{killdbcons} -\alias{killdbcons} -\title{Kill existing database connections} -\usage{ -killdbcons() -} -\value{ -nothing, as a side effect closes all open connections -} -\description{ -Kill existing database connections -} -\details{ -Deprecated, this should never be called - -resolves (provides workaround to) bug #769 caused by having too many open connections \code{Error during wrapup: RS-DBI driver: (cannot allocate a new connection -- maximum of 16 connections already opened)} -} -\author{ -David LeBauer -} diff --git a/base/db/man/priordupe.Rd b/base/db/man/priordupe.Rd index 52486cdcd19..7adfd2c8a93 100644 --- a/base/db/man/priordupe.Rd +++ b/base/db/man/priordupe.Rd @@ -7,13 +7,6 @@ priordupe(parent.pft.name = NULL, new.pft.name = NULL, new.pft.definition = NULL, settings = NULL) } -\arguments{ -\item{parent.pft.name}{} - -\item{new.pft.name}{} - -\item{new.pft.definition}{} -} \value{ nothing, creates new pft in database as a side-effect } diff --git a/base/db/man/query.base.Rd b/base/db/man/query.base.Rd deleted file mode 100644 index 7744afe9bb1..00000000000 --- a/base/db/man/query.base.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/query.base.R -\name{query.base} -\alias{query.base} -\title{Query database} -\usage{ -query.base(query, con = NULL, ...) -} -\arguments{ -\item{query}{SQL query string} - -\item{con}{database connection object} - -\item{...}{optional arguments for connecting to database (e.g. password, user name, database)} -} -\value{ -data frame with query results -} -\description{ -Generic function to query trait database -} -\details{ -Given a connection and a query, will return a query as a data frame - -Deprecated, please use db.query -} -\examples{ -\dontrun{ -query.base('select count(id) from traits;') -} -} diff --git a/base/db/man/query.base.con.Rd b/base/db/man/query.base.con.Rd deleted file mode 100644 index 18f24ac674f..00000000000 --- a/base/db/man/query.base.con.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/query.base.R -\name{query.base.con} -\alias{query.base.con} -\title{Query database connection} -\usage{ -query.base.con(settings, ...) -} -\arguments{ -\item{...}{optional arguments for connecting to database (e.g. password, user name, database)} -} -\value{ -database connection object -} -\description{ -Creates database connection object. -} -\details{ -Also removes any existing connections. - -Deprecated, please use db.open -} -\examples{ -\dontrun{ -con <- query.base.con(settings) -} -} diff --git a/base/db/man/query.close.Rd b/base/db/man/query.close.Rd deleted file mode 100644 index 8f64a099922..00000000000 --- a/base/db/man/query.close.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/query.base.R -\name{query.close} -\alias{query.close} -\title{Close existing database connections} -\usage{ -query.close(con) -} -\arguments{ -\item{con}{database connection object} -} -\value{ -nothing, as a side effect closes all open connections -} -\description{ -Close database connection -} -\details{ -Deprecated, please use db.close - -Closes a database connection -} -\author{ -Rob Kooper -} diff --git a/base/db/man/query.traits.Rd b/base/db/man/query.traits.Rd index 21bfb0f2e18..b665cb5169e 100644 --- a/base/db/man/query.traits.Rd +++ b/base/db/man/query.traits.Rd @@ -10,8 +10,6 @@ query.traits(spstr, priors, con = NULL, update.check.only = FALSE) \item{spstr}{string of species id's from trait database} \item{priors}{vector of parameters for which priors have been specified} - -\item{con}{} } \value{ dataframe with trait data From 8fae3fc0cad36578fda02404e291554a1014a6f4 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 12:58:31 -0500 Subject: [PATCH 399/771] DB: Update changelog. --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 88e043ad076..e94954a71aa 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,6 +13,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Added check for NA end/start year in read.output - Fixed jagify bug for raw field data - Fixed bug (order of dims in nc_create) introduced in model2netcdf.DALEC by standard_vars changes +- Cleaned up NAMESPACE and source code of `PEcAn.DB` (#1520) ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) From d319ec0bc1ab442a9c4047f79e80a21f671886ea Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 13:11:52 -0500 Subject: [PATCH 400/771] DB: Fix missed `dplyr::pull` reference --- base/db/R/query.dplyr.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/base/db/R/query.dplyr.R b/base/db/R/query.dplyr.R index d0bdb36092d..1dca642669e 100644 --- a/base/db/R/query.dplyr.R +++ b/base/db/R/query.dplyr.R @@ -62,6 +62,7 @@ ncdays2date <- function(time, unit) { #' @name dbHostInfo #' @title Database host information #' @param bety BETYdb connection, as opened by `betyConnect()` +#' @importFrom dplyr `%>%` #' @export dbHostInfo <- function(bety) { # get host id @@ -88,6 +89,7 @@ dbHostInfo <- function(bety) { #' list of workflows that exist #' @param ensemble Logical. Use workflows from ensembles table. #' @inheritParams dbHostInfo +#' @importFrom dplyr `%>%` #' @export workflows <- function(bety, ensemble = FALSE) { hostinfo <- dbHostInfo(bety) @@ -106,6 +108,7 @@ workflows <- function(bety, ensemble = FALSE) { #' Get single workflow by workflow_id #' @param workflow_id Workflow ID #' @inheritParams dbHostInfo +#' @importFrom dplyr `%>%` #' @export workflow <- function(bety, workflow_id) { workflows(bety) %>% @@ -173,7 +176,7 @@ get_run_ids <- function(bety, workflow_id) { if (workflow_id != "") { runs <- runs(bety, workflow_id) if (dplyr.count(runs) > 0) { - run_ids <- pull(runs, run_id) %>% sort() + run_ids <- dplyr::pull(runs, run_id) %>% sort() } } return(run_ids) From 96235b829d6eb1eb7ca07ca74e545c42e0f30800 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 13:25:45 -0500 Subject: [PATCH 401/771] Fix wrong `dplyr::`%>%` reference. Update docs. --- base/db/R/query.dplyr.R | 3 --- modules/data.land/NAMESPACE | 2 +- modules/data.land/R/match_species_id.R | 28 +++++++++++------------ modules/data.land/man/match_species_id.Rd | 2 +- 4 files changed, 16 insertions(+), 19 deletions(-) diff --git a/base/db/R/query.dplyr.R b/base/db/R/query.dplyr.R index 1dca642669e..d9a26dd090b 100644 --- a/base/db/R/query.dplyr.R +++ b/base/db/R/query.dplyr.R @@ -62,7 +62,6 @@ ncdays2date <- function(time, unit) { #' @name dbHostInfo #' @title Database host information #' @param bety BETYdb connection, as opened by `betyConnect()` -#' @importFrom dplyr `%>%` #' @export dbHostInfo <- function(bety) { # get host id @@ -89,7 +88,6 @@ dbHostInfo <- function(bety) { #' list of workflows that exist #' @param ensemble Logical. Use workflows from ensembles table. #' @inheritParams dbHostInfo -#' @importFrom dplyr `%>%` #' @export workflows <- function(bety, ensemble = FALSE) { hostinfo <- dbHostInfo(bety) @@ -108,7 +106,6 @@ workflows <- function(bety, ensemble = FALSE) { #' Get single workflow by workflow_id #' @param workflow_id Workflow ID #' @inheritParams dbHostInfo -#' @importFrom dplyr `%>%` #' @export workflow <- function(bety, workflow_id) { workflows(bety) %>% diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index e50c7e04bb2..fec745a1e27 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -42,5 +42,5 @@ export(to.Tag) export(to.TreeCode) export(write_ic) export(write_veg) -importFrom(dplyr,"%>%") +importFrom(magrittr,"%>%") importFrom(ncdf4,ncvar_get) diff --git a/modules/data.land/R/match_species_id.R b/modules/data.land/R/match_species_id.R index 5e400c8cbab..64b3ba4efc2 100644 --- a/modules/data.land/R/match_species_id.R +++ b/modules/data.land/R/match_species_id.R @@ -1,7 +1,7 @@ #' Match BETY species ID. #' #' Parses species codes in input data and matches them with the BETY species ID. -#' +#' #' \code{format_name} can be one of the following: #' \describe{ #' \item{\code{usda}}{USDA Plants database symbol (e.g. QURU, TSCA)} @@ -9,10 +9,10 @@ #' \item{\code{latin_name}}{Scientific name, as "Genus species"; must match exactly and unambiguously to \code{scientificname} field in BETY} #' \item{\code{custom}}{A data frame matching BETY IDs (column name \code{bety_species_id}) to input codes (column name \code{input_code}). This data frame must be passed via the \code{translation_table} argument.} #' } -#' +#' #' @param input_codes Character vector of species codes #' @param format_name Species code format name (see details) -#' @param bety \code{dplyr} \code{src} object containing BETY connection +#' @param bety \code{dplyr} \code{src} object containing BETY connection #' @param translation_table Data frame with custom translation table (see details). #' @return \code{data.frame} containing the following columns: #' \describe{ @@ -32,14 +32,14 @@ #' match_species_id(input_codes = input_codes, #' format_name = format_name, #' bety = bety) -#' -#' @importFrom dplyr %>% +#' +#' @importFrom magrittr %>% #' @export match_species_id <- function(input_codes, format_name = 'custom', bety = NULL, translation_table = NULL, ...) { # Relate format names to BETY columns formats_dict <- c('usda' = 'Symbol', 'fia' = 'spcd', - 'latin_name' = 'scientificname', + 'latin_name' = 'scientificname', 'custom' = 'custom') if (!format_name %in% names(formats_dict)) { PEcAn.logger::logger.severe('format_name "', format_name, '" not found. ', @@ -47,7 +47,7 @@ match_species_id <- function(input_codes, format_name = 'custom', bety = NULL, t paste(names(formats_dict), collapse = ', ')) } if (!is.null(translation_table)) { - msg2 <- c('Found the following columns: ', + msg2 <- c('Found the following columns: ', paste(colnames(translation_table), collapse = ', ')) if (!'input_code' %in% colnames(translation_table)) { PEcAn.logger::logger.severe('Custom translation table must have column "input_code". ', msg2) @@ -64,7 +64,7 @@ match_species_id <- function(input_codes, format_name = 'custom', bety = NULL, t dplyr::filter_(~id %in% translation_table[['bety_species_id']]) %>% dplyr::select_('bety_species_id' = 'id', 'genus', 'species') %>% dplyr::collect() - translation <- dplyr::left_join(translation_table, bety_species, + translation <- dplyr::left_join(translation_table, bety_species, by = 'bety_species_id', suffix = c('.translation_table', '')) } @@ -72,7 +72,7 @@ match_species_id <- function(input_codes, format_name = 'custom', bety = NULL, t column <- formats_dict[format_name] if(!is.null(bety)){ # query BETY - filter_cri <- lazyeval::interp(~ col %in% codes, + filter_cri <- lazyeval::interp(~ col %in% codes, col = as.name(column), codes = input_codes) translation <- dplyr::tbl(bety, 'species') %>% @@ -80,7 +80,7 @@ match_species_id <- function(input_codes, format_name = 'custom', bety = NULL, t dplyr::select_('bety_species_id' = 'id', 'genus', 'species', 'input_code' = column) %>% dplyr::collect() - + }else{ # use traits package @@ -91,9 +91,9 @@ match_species_id <- function(input_codes, format_name = 'custom', bety = NULL, t genus = rep(NA, length(unique(input_codes))), species = rep(NA, length(unique(input_codes))), stringsAsFactors = FALSE) - + for(i in 1:nrow(unique.tmp)){ - foo <- eval(parse(text =paste0("traits::betydb_query(", + foo <- eval(parse(text =paste0("traits::betydb_query(", column, "='", unique.tmp$input_code[i], "', table = 'species', user = 'bety', pwd = 'bety')"))) translation$bety_species_id[i] <- foo$id translation$genus[i] <- foo$genus @@ -106,12 +106,12 @@ match_species_id <- function(input_codes, format_name = 'custom', bety = NULL, t input_table <- data.frame(input_code = input_codes, stringsAsFactors = FALSE) # preserving the order is important for downstream merge_table <- dplyr::left_join(input_table, translation) - + if(sum(is.na(merge_table$bety_species_id)) > 0){ bad <- unique(merge_table$input_code[is.na(merge_table$bety_species_id)]) PEcAn.logger::logger.error(paste0("Species for the following code(s) not found : ", paste(bad, collapse = ", "))) } - + return(merge_table) } # match_species_id diff --git a/modules/data.land/man/match_species_id.Rd b/modules/data.land/man/match_species_id.Rd index 56724ad5db0..a21a618fbf3 100644 --- a/modules/data.land/man/match_species_id.Rd +++ b/modules/data.land/man/match_species_id.Rd @@ -47,7 +47,7 @@ format_name <- 'usda' match_species_id(input_codes = input_codes, format_name = format_name, bety = bety) - + } \author{ Alexey Shiklomanov , Istem Fer From 8b545eac4e9552c2898dd2d64cfad813e7f7da51 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 23 Aug 2017 14:36:53 -0400 Subject: [PATCH 402/771] Allow DALEC met2model and model2netcdf to filter dates --- models/dalec/R/met2model.DALEC.R | 17 +++++++++++++++++ models/dalec/R/model2netcdf.DALEC.R | 3 ++- models/sipnet/R/met2model.SIPNET.R | 1 - 3 files changed, 19 insertions(+), 2 deletions(-) diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index 952901c41a5..3da2de5bd62 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -176,6 +176,23 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, ## build data matrix tmp <- cbind(doy, Tmean, Tmax, Tmin, Rin, LeafWaterPot, CO2, HydResist, leafN) + ##filter out days not included in start or end date + if(year == start_year){ + extra.days <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date + if (extra.days > 1){ + PEcAn.logger::logger.info("Subsetting DALEC met to match start date") + start.row <- ((extra.days - 1) * 86400 / dt) + 1 #subtract to include start.date, add to exclude last half hour of day before + tmp <- tmp[start.row:nrow(tmp),] + } + } else if (year == end_year){ + extra.days <- length(as.Date(end_date):as.Date(paste0(end_year, "-12-31"))) #extra days length includes the end date + if (extra.days > 1){ + PEcAn.logger::logger.info("Subsetting DALEC met to match end date") + end.row <- nrow(tmp) - ((extra.days - 1) * 86400 / dt) #subtract to include end.date + tmp <- tmp[1:end.row,] + } + } + if (is.null(out)) { out <- tmp } else { diff --git a/models/dalec/R/model2netcdf.DALEC.R b/models/dalec/R/model2netcdf.DALEC.R index 90592596b55..3d929f50e49 100644 --- a/models/dalec/R/model2netcdf.DALEC.R +++ b/models/dalec/R/model2netcdf.DALEC.R @@ -100,8 +100,9 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { output[[17]] <- sub.DALEC.output[, 15] * DALEC.configs[grep("SLA", DALEC.configs) + 1][[1]] # ******************** Declare netCDF variables ********************# + start.day <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date t <- ncdim_def(name = "time", units = paste0("days since ", y, "-01-01 00:00:00"), - vals = 1:nrow(sub.DALEC.output), + vals = start.day:(start.day + nrow(sub.DALEC.output)), calendar = "standard", unlim = TRUE) lat <- ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") lon <- ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index 2d0b072b399..7135aec0d59 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -213,7 +213,6 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date ##filter out days not included in start or end date if(year == start_year){ - print(start_date) extra.days <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date if (extra.days > 1){ PEcAn.logger::logger.info("Subsetting SIPNET met to match start date") From 29e2d1bf820db4d585d9d832efc27cdefd1b8d3c Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 23 Aug 2017 14:39:58 -0400 Subject: [PATCH 403/771] Clean up --- models/dalec/R/model2netcdf.DALEC.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/dalec/R/model2netcdf.DALEC.R b/models/dalec/R/model2netcdf.DALEC.R index 3d929f50e49..f4216a16c9e 100644 --- a/models/dalec/R/model2netcdf.DALEC.R +++ b/models/dalec/R/model2netcdf.DALEC.R @@ -100,7 +100,7 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { output[[17]] <- sub.DALEC.output[, 15] * DALEC.configs[grep("SLA", DALEC.configs) + 1][[1]] # ******************** Declare netCDF variables ********************# - start.day <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date + start.day <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) t <- ncdim_def(name = "time", units = paste0("days since ", y, "-01-01 00:00:00"), vals = start.day:(start.day + nrow(sub.DALEC.output)), calendar = "standard", unlim = TRUE) From 3a46aaa3ccd3ac4754e9d6b87814c8d8ebd06a20 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 23 Aug 2017 15:17:56 -0400 Subject: [PATCH 404/771] logger messages --- models/dalec/R/met2model.DALEC.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index 3da2de5bd62..a3cd88a0b04 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -180,8 +180,10 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, if(year == start_year){ extra.days <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date if (extra.days > 1){ - PEcAn.logger::logger.info("Subsetting DALEC met to match start date") + PEcAn.logger::logger.info("Subsetting DALEC met to match start date ", start_date) start.row <- ((extra.days - 1) * 86400 / dt) + 1 #subtract to include start.date, add to exclude last half hour of day before + print(start.row) + print(nrow(tmp)) tmp <- tmp[start.row:nrow(tmp),] } } else if (year == end_year){ From fcc743415cc0555948663f3a0e5d03f749f954e8 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 15:02:25 -0500 Subject: [PATCH 405/771] RTM: Add ability to set convergence diag threshold --- modules/rtm/R/bayestools.R | 9 ++++++--- modules/rtm/man/invert_bt.Rd | 1 + 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R index 067a14b8d28..e826a718b35 100644 --- a/modules/rtm/R/bayestools.R +++ b/modules/rtm/R/bayestools.R @@ -97,6 +97,7 @@ prospect_bt_prior <- function(version, custom_prior = list()) { #' Default is `10 * log10(n)` (same as `stats::acf` function). #' - `save_progress` -- File name for saving samples between loop #' iterations. If `NULL` (default), do not save progress samples. +#' - `threshold` -- Threshold for Gelman PSRF convergence diagnostic. Default is 1.1. #' #' See the BayesianTools sampler documentation for what can go in the `BayesianTools` settings lists. #' @param observed Vector of observations @@ -115,7 +116,8 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { min_samp = 1000, max_iter = 1e6, lag.max = NULL, - save_progress = NULL)) + save_progress = NULL, + threshold = 1.1)) if (length(custom_settings) > 0) { settings <- list() @@ -137,6 +139,7 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { lag.max <- settings[['other']][['lag.max']] max_iter <- settings[['other']][['max_iter']] save_progress <- settings[['other']][['save_progress']] + threshold <- settings[['other']][['threshold']] if (!is.null(save_progress)) { # `file.create` returns FALSE if target directory doesn't exist. @@ -170,7 +173,7 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { if (!is.null(save_progress)) { saveRDS(object = samples, file = save_progress) } - converged <- bt_check_convergence(samples = samples, use_mpsrf = use_mpsrf) + converged <- bt_check_convergence(samples = samples, threshold = threshold, use_mpsrf = use_mpsrf) loop_settings <- modifyList(settings[['common']], settings[['loop']]) @@ -194,7 +197,7 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { if (!is.null(save_progress)) { saveRDS(object = samples, file = save_progress) } - converged <- bt_check_convergence(samples = samples, use_mpsrf = use_mpsrf) + converged <- bt_check_convergence(samples = samples, threshold = threshold, use_mpsrf = use_mpsrf) if (converged) { coda_samples <- BayesianTools::getSample(samples, coda = TRUE) burned_samples <- PEcAn.assim.batch::autoburnin(coda_samples, return.burnin = TRUE, method = 'gelman.plot') diff --git a/modules/rtm/man/invert_bt.Rd b/modules/rtm/man/invert_bt.Rd index 560d7120f38..8742db4b0a7 100644 --- a/modules/rtm/man/invert_bt.Rd +++ b/modules/rtm/man/invert_bt.Rd @@ -45,6 +45,7 @@ Default is 1000. Default is \code{10 * log10(n)} (same as \code{stats::acf} function). \item \code{save_progress} -- File name for saving samples between loop iterations. If \code{NULL} (default), do not save progress samples. +\item \code{threshold} -- Threshold for Gelman PSRF convergence diagnostic. Default is 1.1. } } From 740acbaa9250451d7869c8a3e263e035de53bc60 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 23 Aug 2017 16:03:59 -0400 Subject: [PATCH 406/771] Fix DALEC met2model day calcuation + allow start and end to be same year --- models/dalec/R/met2model.DALEC.R | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index a3cd88a0b04..8cfe2d0a150 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -178,21 +178,29 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, ##filter out days not included in start or end date if(year == start_year){ - extra.days <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date - if (extra.days > 1){ - PEcAn.logger::logger.info("Subsetting DALEC met to match start date ", start_date) - start.row <- ((extra.days - 1) * 86400 / dt) + 1 #subtract to include start.date, add to exclude last half hour of day before - print(start.row) + start.day <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date + if (start.day > 1){ + PEcAn.logger::logger.info("Subsetting DALEC met to match start date ", as.Date(start_date)) + print(start.day) print(nrow(tmp)) tmp <- tmp[start.row:nrow(tmp),] } - } else if (year == end_year){ - extra.days <- length(as.Date(end_date):as.Date(paste0(end_year, "-12-31"))) #extra days length includes the end date - if (extra.days > 1){ + } + if (year == end_year){ + if(year == start_year){ + end.day <- length(as.Date(start_date):as.Date(end_date)) + if (end.day < nrow(tmp)){ + PEcAn.logger::logger.info("Subsetting DALEC met to match end date") + tmp <- tmp[1:end.row,] + } + } else{ + end.day <- length(as.Date(paste0(end_year, "-01-01")):as.Date(end_date)) + if (end.day < nrow(tmp)){ PEcAn.logger::logger.info("Subsetting DALEC met to match end date") - end.row <- nrow(tmp) - ((extra.days - 1) * 86400 / dt) #subtract to include end.date tmp <- tmp[1:end.row,] } + } + } if (is.null(out)) { From 923d9c8ae02d43aef35dfba2fbea713279c78fe4 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 23 Aug 2017 16:09:28 -0400 Subject: [PATCH 407/771] Fix varname --- models/dalec/R/met2model.DALEC.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index 8cfe2d0a150..d4b56d5f09b 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -178,23 +178,23 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, ##filter out days not included in start or end date if(year == start_year){ - start.day <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date - if (start.day > 1){ + start.row <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date + if (start.row > 1){ PEcAn.logger::logger.info("Subsetting DALEC met to match start date ", as.Date(start_date)) - print(start.day) + print(start.row) print(nrow(tmp)) tmp <- tmp[start.row:nrow(tmp),] } } if (year == end_year){ if(year == start_year){ - end.day <- length(as.Date(start_date):as.Date(end_date)) - if (end.day < nrow(tmp)){ + end.row <- length(as.Date(start_date):as.Date(end_date)) + if (end.row < nrow(tmp)){ PEcAn.logger::logger.info("Subsetting DALEC met to match end date") tmp <- tmp[1:end.row,] } } else{ - end.day <- length(as.Date(paste0(end_year, "-01-01")):as.Date(end_date)) + end.row <- length(as.Date(paste0(end_year, "-01-01")):as.Date(end_date)) if (end.day < nrow(tmp)){ PEcAn.logger::logger.info("Subsetting DALEC met to match end date") tmp <- tmp[1:end.row,] From 4408934680160db49dfc6a5869f3d996d6979ff3 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 23 Aug 2017 16:12:28 -0400 Subject: [PATCH 408/771] Fix varname 2 --- models/dalec/R/met2model.DALEC.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index d4b56d5f09b..5992225494d 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -195,7 +195,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, } } else{ end.row <- length(as.Date(paste0(end_year, "-01-01")):as.Date(end_date)) - if (end.day < nrow(tmp)){ + if (end.row < nrow(tmp)){ PEcAn.logger::logger.info("Subsetting DALEC met to match end date") tmp <- tmp[1:end.row,] } From 1f08ee8cacf1ea652f5d1a67a336f8f231d69e0e Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 15:14:56 -0500 Subject: [PATCH 409/771] RTM: Check for threshold in autoburnin Also, add informative message when `autoburnin` doesn't detect convergence. --- modules/rtm/R/bayestools.R | 9 +++++++-- modules/rtm/tests/testthat/test.invert_bayestools.R | 2 +- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R index e826a718b35..e356fde2175 100644 --- a/modules/rtm/R/bayestools.R +++ b/modules/rtm/R/bayestools.R @@ -200,8 +200,13 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { converged <- bt_check_convergence(samples = samples, threshold = threshold, use_mpsrf = use_mpsrf) if (converged) { coda_samples <- BayesianTools::getSample(samples, coda = TRUE) - burned_samples <- PEcAn.assim.batch::autoburnin(coda_samples, return.burnin = TRUE, method = 'gelman.plot') - if (burned_samples$burnin == 1) next + burned_samples <- PEcAn.assim.batch::autoburnin(coda_samples, threshold = threshold, + return.burnin = TRUE, method = 'gelman.plot') + if (burned_samples$burnin == 1) { + message('PEcAn.assim.batch::autoburnin reports convergence has not been achieved. ', + 'Resuming sampling.') + next + } n_samples <- coda::niter(burned_samples$samples) enough_samples <- n_samples > min_samp if (!enough_samples) { diff --git a/modules/rtm/tests/testthat/test.invert_bayestools.R b/modules/rtm/tests/testthat/test.invert_bayestools.R index 2b4f5eb0657..5073177928c 100644 --- a/modules/rtm/tests/testthat/test.invert_bayestools.R +++ b/modules/rtm/tests/testthat/test.invert_bayestools.R @@ -15,7 +15,7 @@ if (Sys.getenv('CI') == 'true') { samples <- invert_bt(observed = observed, model = model, prior = prior, custom_settings = list(init = list(iterations = 2000), loop = list(iterations = 1000), - other = list(max_iter = 20000))) + other = list(max_iter = 20000, threshold = 1.3))) samples_burned <- PEcAn.assim.batch::autoburnin(BayesianTools::getSample(samples, coda = TRUE), method = 'gelman.plot') mean_estimates <- do.call(cbind, summary(samples_burned)[c('statistics', 'quantiles')]) From 89d15586e4f07f2acb35663e8731ca182c26c7b5 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 23 Aug 2017 16:20:41 -0400 Subject: [PATCH 410/771] Debugging --- models/dalec/R/model2netcdf.DALEC.R | 1 + 1 file changed, 1 insertion(+) diff --git a/models/dalec/R/model2netcdf.DALEC.R b/models/dalec/R/model2netcdf.DALEC.R index f4216a16c9e..e875964b3f6 100644 --- a/models/dalec/R/model2netcdf.DALEC.R +++ b/models/dalec/R/model2netcdf.DALEC.R @@ -35,6 +35,7 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { ### Determine number of years and output timestep days <- as.Date(start_date):as.Date(end_date) + print(paste("days: ",length(days))) year <- strftime(as.Date(days, origin = "1970-01-01"), "%Y") num.years <- length(unique(year)) years <- unique(year) From 92bc428e7cd92afeca2d5ddf725acbcec7791580 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 23 Aug 2017 16:31:21 -0400 Subject: [PATCH 411/771] Fix start_year reference and time vals --- models/dalec/R/model2netcdf.DALEC.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/models/dalec/R/model2netcdf.DALEC.R b/models/dalec/R/model2netcdf.DALEC.R index e875964b3f6..87d485ebee0 100644 --- a/models/dalec/R/model2netcdf.DALEC.R +++ b/models/dalec/R/model2netcdf.DALEC.R @@ -101,9 +101,12 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { output[[17]] <- sub.DALEC.output[, 15] * DALEC.configs[grep("SLA", DALEC.configs) + 1][[1]] # ******************** Declare netCDF variables ********************# - start.day <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) + start.day <- 1 + if(y == lubridate::year(start_date)){ + start.day <- length(as.Date(paste0(y, "-01-01")):as.Date(start_date)) + } t <- ncdim_def(name = "time", units = paste0("days since ", y, "-01-01 00:00:00"), - vals = start.day:(start.day + nrow(sub.DALEC.output)), + vals = start.day:(start.day + (nrow(sub.DALEC.output)-1)), calendar = "standard", unlim = TRUE) lat <- ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") lon <- ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") From 5f94a0c506afbd13bd2aff8c35d0f884d9616455 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 23 Aug 2017 16:47:47 -0400 Subject: [PATCH 412/771] cleanup --- models/dalec/R/met2model.DALEC.R | 8 ++++---- models/sipnet/R/met2model.SIPNET.R | 22 ++++++++++++++++------ 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index 5992225494d..ad2c1f59fc6 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -195,10 +195,10 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, } } else{ end.row <- length(as.Date(paste0(end_year, "-01-01")):as.Date(end_date)) - if (end.row < nrow(tmp)){ - PEcAn.logger::logger.info("Subsetting DALEC met to match end date") - tmp <- tmp[1:end.row,] - } + if (end.row < nrow(tmp)){ + PEcAn.logger::logger.info("Subsetting DALEC met to match end date") + tmp <- tmp[1:end.row,] + } } } diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index 7135aec0d59..af62c6558b0 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -219,12 +219,22 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date start.row <- ((extra.days - 1) * 86400 / dt) + 1 #subtract to include start.date, add to exclude last half hour of day before tmp <- tmp[start.row:nrow(tmp),] } - } else if (year == end_year){ - extra.days <- length(as.Date(end_date):as.Date(paste0(end_year, "-12-31"))) #extra days length includes the end date - if (extra.days > 1){ - PEcAn.logger::logger.info("Subsetting SIPNET met to match end date") - end.row <- nrow(tmp) - ((extra.days - 1) * 86400 / dt) #subtract to include end.date - tmp <- tmp[1:end.row,] + } + if (year == end_year){ + if(year == start_year){ + extra.days <- length(as.Date(start_date):as.Date(end_date)) + if (extra.days > 1){ + PEcAn.logger::logger.info("Subsetting SIPNET met to match end date") + end.row <- nrow(tmp) - ((extra.days - 1) * 86400 / dt) #subtract to include end.date + tmp <- tmp[1:end.row,] + } + } else{ + extra.days <- length(as.Date(end_date):as.Date(paste0(end_year, "-12-31"))) #extra days length includes the end date + if (extra.days > 1){ + PEcAn.logger::logger.info("Subsetting SIPNET met to match end date") + end.row <- nrow(tmp) - ((extra.days - 1) * 86400 / dt) #subtract to include end.date + tmp <- tmp[1:end.row,] + } } } From e541db88b60e43f48a96520d02942fd885567c17 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 23 Aug 2017 17:05:13 -0400 Subject: [PATCH 413/771] Make: Change installation order in Makefile On blank installations, this will now install modules before models, which makes more sense because many `models` depend on `modules` but not the other way around. --- Makefile | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/Makefile b/Makefile index 9181b0ebe74..5dd4456283b 100644 --- a/Makefile +++ b/Makefile @@ -13,27 +13,27 @@ MODULES := allometry assim.batch assim.sequential benchmark \ BASE := $(BASE:%=base/%) MODELS := $(MODELS:%=models/%) MODULES := $(MODULES:%=modules/%) -ALL_PKGS := $(BASE) $(MODELS) $(MODULES) models/template +ALL_PKGS := $(BASE) $(MODULES) $(MODELS) models/template BASE_I := $(BASE:%=.install/%) MODELS_I := $(MODELS:%=.install/%) MODULES_I := $(MODULES:%=.install/%) -ALL_PKGS_I := $(BASE_I) $(MODELS_I) $(MODULES_I) .install/models/template +ALL_PKGS_I := $(BASE_I) $(MODULES_I) $(MODELS_I) .install/models/template BASE_C := $(BASE:%=.check/%) MODELS_C := $(MODELS:%=.check/%) MODULES_C := $(MODULES:%=.check/%) -ALL_PKGS_C := $(BASE_C) $(MODELS_C) $(MODULES_C) .check/models/template +ALL_PKGS_C := $(BASE_C) $(MODULES_C) $(MODELS_C) .check/models/template BASE_T := $(BASE:%=.test/%) MODELS_T := $(MODELS:%=.test/%) MODULES_T := $(MODULES:%=.test/%) -ALL_PKGS_T := $(BASE_T) $(MODELS_T) $(MODULES_T) .test/models/template +ALL_PKGS_T := $(BASE_T) $(MODULES_T) $(MODELS_T) .test/models/template BASE_D := $(BASE:%=.doc/%) MODELS_D := $(MODELS:%=.doc/%) MODULES_D := $(MODULES:%=.doc/%) -ALL_PKGS_D := $(BASE_D) $(MODELS_D) $(MODULES_D) .doc/models/template +ALL_PKGS_D := $(BASE_D) $(MODULES_D) $(MODELS_D) .doc/models/template .PHONY: all install check test document From 757b5132c109d92e64706af06cc9af29346af1f4 Mon Sep 17 00:00:00 2001 From: araiho Date: Wed, 23 Aug 2017 17:37:21 -0400 Subject: [PATCH 414/771] continuing to work on ensemble adjustment visualization. looking for a way to view multidimensional data. --- modules/assim.sequential/R/sda.enkf.R | 121 +++++++++++++++++++++++--- 1 file changed, 111 insertions(+), 10 deletions(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index eeb3b185adb..7442d9fdf2b 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -959,28 +959,129 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { } else { print("climate diagnostics under development") } + ###-------------------------------------------------------------------### - ### ensemble adjustment ### + ### ensemble adjustment plots ### ###-------------------------------------------------------------------### - #Calculate the likelihood of the ensemble members given mu.a and Pa - wt.mat <- matrix(NA,nrow=nens,ncol=nt) + #function for plotting matplot with ensemble number as label + mattext = function(data, data_names, colors, ylab, xlab, type='b', na.fix = FALSE){ + if(na.fix == TRUE){ + data[is.na(data)] <- 0 + } + + matplot(data, pch=NA, type=type, col=colors, ylab = ylab, xlab = xlab) + for (i in 1:ncol(data)){ + text(x=1:nrow(data), y=data[,i], lab=data_names[i], col=colors[i]) + } + } + #calculate the likelihood of the ensemble members given mu.a and Pa + wt.mat <- matrix(NA,nrow=nens,ncol=nt) for(t in seq_len(nt)){ for(i in seq_len(nens)){ wt.mat[i,t]<-dmnorm_chol(FORECAST[[t]][i,],enkf.params[[t]]$mu.a,enkf.params[[t]]$Pa) } } - + #put into weights table wt.props <- t(prop.table(wt.mat,2)) - + pdf(file.path(settings$outdir,'ensemble.weights.time-series.pdf')) - matplot(wt.props,xlab='Time',ylab='Weights') + par(mfrow=c(1,1)) + mattext(data = wt.props,data_names = as.character(1:nens),colors=rainbow(nens), + ylab = c('Ensemble Weight'), xlab = c('Time')) dev.off() - param.hist <- unlist(lapply(lapply(params,'[[','Quercus.Rubra_Northern.Red.Oak'),'[[','FROST')) - weighted.hist(x = param.hist, w = wt.props[nt,],freq = FALSE,col = 'lightgrey') - hist(param.hist,freq = FALSE,col = 'lightgrey') + library(Hmisc) + pft.names <- as.character(lapply(settings$pfts, function(x) x[["name"]])) + param.names <- names(params[[1]][[1]]) + param.hist <- array(NA,dim=c(length(param.names),length(pft.names),nens)) + wt.df <- array(NA, dim = c(length(param.names),length(pft.names),nt,4)) + + pdf('weighted.param.time-series.pdf') + par(mfrow=c(4,5)) + for(p in 1:length(param.names)){ + for(s in 1:length(pft.names)){ + pft <- pft.names[s] + param.plot <- param.names[p] + + param.check <- unlist(lapply(lapply(params,'[[',pft),'[[',param.plot)) + + if(!is.null(param.check)){ + param.hist[p,s,] <- param.check + wt.mean <- wt.var <- numeric(nt) + + for(t in 1:nt){ + wt.mean[t] <- wtd.mean(x=param.hist[p,s,], w = wt.props[t,]) + wt.var[t] <- wtd.var(x=param.hist[p,s,], w = wt.props[t,]) + } + + wt.df[p,s,,1] <- wt.mean + wt.df[p,s,,2] <- wt.mean - mean(param.hist[p,s,]) + wt.df[p,s,,3] <- wt.var + wt.df[p,s,,4] <- wt.var - var(param.hist[p,s,]) + + #plot weighted mean + plot(wt.mean,type='l',ylab='Weighted Mean',xlab='Time') + points(wt.mean, pch=19,cex=.4) + abline(h=mean(param.hist[p,s,])) + abline(h = param.hist[p,s,which.min(colMeans(wt.props,na.rm = TRUE))],col='red') + abline(h = param.hist[p,s,which.max(colMeans(wt.props,na.rm = TRUE))],col='green') + title(main = list(paste(pft,'\n',param.plot), cex = .5)) + + #coloring by the difference in the mean relative to the scale of the parameter + diff.mean <- abs(mean(wt.mean) - mean(param.hist[p,s,])) + if(diff.mean > abs(.00001*mean(param.hist[p,s,]))){ + mtext(text = paste(signif(diff.mean,digits = 3)), side = 3,col = 'red') + }else{ + mtext(text = paste(signif(diff.mean,digits = 3)), side = 3) + } + + #Plot weighted variance + plot(wt.var,type='l',ylab='Weighted Variance',xlab='Time') + points(wt.var, pch=19,cex=.5) + abline(h=var(param.hist[p,s,])) + title(main = list(paste(pft,'\n',param.plot), cex = .5)) + + hist(param.hist[p,s,], freq = FALSE, col= 'lightgrey', main = paste(pft,'\n',param.plot)) + for(t in 1:nt){ + lines(density(param.hist[p,s,], weights = wt.props[t,], na.rm = TRUE), + lwd = 2, col=rainbow(49)[t]) + } + + }else{ + plot.new() + } + + } + } + dev.off() + + pdf('weighted.hists.pdf') + par(mfrow = c(4,4)) + plot.new() + legend('center',c('Weighted Means','Prior'),pch = 19,col=c('lightgrey','black')) + for(p in 1:length(param.names)){ + hist(wt.df[p,,,1], main=param.names[p], freq = FALSE, col = 'lightgrey', xlab = 'Param Value') + lines(density(param.hist[p,,],na.rm = TRUE), lwd = 2) + } + dev.off() + + which.min(colMeans(wt.props,na.rm = TRUE)) + which.max(colMeans(wt.props,na.rm = TRUE)) + + + + par(mfrow=c(1,1)) + mattext(param.hist[1,,], data_names = as.character(1:nens), colors=rainbow(nens), + ylab = c('Parameter Value'), xlab = c('PFT'), type='p', na.fix = TRUE) + + library(weights) + par(mfrow=c(1,2)) + weighted.hist(x = param.hist, w = wt.props[nt,],col = 'lightgrey') + hist(param.hist,col = 'lightgrey',xlim = range(dd$x)) + plot(density(param.hist)) + plot(density(param.hist*wt.props[nt,]*10)) ## weighted quantile wtd.quantile <- function(x,wt,q){ @@ -993,7 +1094,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { param.quant <- matrix(NA, 3, nt) for(t in seq_len(nt)){ - param.quant[,t] <- wtd.quantile(x = param.hist, wt=wt.props[t,],q=c(.025,.5,.975)) + param.quant[,t] <- wtd.quantile(x = param.hist, wt=wt.mat[,t],q=c(.025,.5,.975)) } plot(param.quant[2,], ylim = range(param.quant,na.rm = TRUE)) From bdd9a49db6cbd60086f026fa96a7226a3632d29c Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 23 Aug 2017 18:22:49 -0400 Subject: [PATCH 415/771] Changelog and cleanup --- CHANGELOG.md | 1 + models/dalec/R/met2model.DALEC.R | 2 +- models/dalec/R/model2netcdf.DALEC.R | 1 - models/sipnet/R/met2model.SIPNET.R | 2 +- 4 files changed, 3 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 88e043ad076..d10d4b3f34e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,6 +16,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) +- Allow SIPNET and DALEC met files and model2netcdf to start or end mid year ### Changed - Clean up directory structure: diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index ad2c1f59fc6..0ecd1c1eae7 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -93,7 +93,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - ## loop over files TODO need to filter out the data that is not inside start_date, end_date + ## loop over files for (year in start_year:end_year) { print(year) ## Assuming default values for leaf water potential, hydraulic resistance, foliar N diff --git a/models/dalec/R/model2netcdf.DALEC.R b/models/dalec/R/model2netcdf.DALEC.R index 87d485ebee0..5c8302044a4 100644 --- a/models/dalec/R/model2netcdf.DALEC.R +++ b/models/dalec/R/model2netcdf.DALEC.R @@ -35,7 +35,6 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { ### Determine number of years and output timestep days <- as.Date(start_date):as.Date(end_date) - print(paste("days: ",length(days))) year <- strftime(as.Date(days, origin = "1970-01-01"), "%Y") num.years <- length(unique(year)) years <- unique(year) diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index af62c6558b0..ccdb2f936c9 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -67,7 +67,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - ## loop over files TODO need to filter out the data that is not inside start_date, end_date + ## loop over files for (year in start_year:end_year) { skip <- FALSE From 20c8b36fab26fd51628c24f3717af5e81ab216dd Mon Sep 17 00:00:00 2001 From: araiho Date: Thu, 24 Aug 2017 13:35:44 -0400 Subject: [PATCH 416/771] taking out ensemble adjustment plotting for now --- modules/assim.sequential/R/sda.enkf.R | 143 -------------------------- 1 file changed, 143 deletions(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index 7442d9fdf2b..b310c0775b2 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -960,149 +960,6 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { print("climate diagnostics under development") } - ###-------------------------------------------------------------------### - ### ensemble adjustment plots ### - ###-------------------------------------------------------------------### - - #function for plotting matplot with ensemble number as label - mattext = function(data, data_names, colors, ylab, xlab, type='b', na.fix = FALSE){ - if(na.fix == TRUE){ - data[is.na(data)] <- 0 - } - - matplot(data, pch=NA, type=type, col=colors, ylab = ylab, xlab = xlab) - for (i in 1:ncol(data)){ - text(x=1:nrow(data), y=data[,i], lab=data_names[i], col=colors[i]) - } - } - - #calculate the likelihood of the ensemble members given mu.a and Pa - wt.mat <- matrix(NA,nrow=nens,ncol=nt) - for(t in seq_len(nt)){ - for(i in seq_len(nens)){ - wt.mat[i,t]<-dmnorm_chol(FORECAST[[t]][i,],enkf.params[[t]]$mu.a,enkf.params[[t]]$Pa) - } - } - #put into weights table - wt.props <- t(prop.table(wt.mat,2)) - - pdf(file.path(settings$outdir,'ensemble.weights.time-series.pdf')) - par(mfrow=c(1,1)) - mattext(data = wt.props,data_names = as.character(1:nens),colors=rainbow(nens), - ylab = c('Ensemble Weight'), xlab = c('Time')) - dev.off() - - library(Hmisc) - pft.names <- as.character(lapply(settings$pfts, function(x) x[["name"]])) - param.names <- names(params[[1]][[1]]) - param.hist <- array(NA,dim=c(length(param.names),length(pft.names),nens)) - wt.df <- array(NA, dim = c(length(param.names),length(pft.names),nt,4)) - - pdf('weighted.param.time-series.pdf') - par(mfrow=c(4,5)) - for(p in 1:length(param.names)){ - for(s in 1:length(pft.names)){ - pft <- pft.names[s] - param.plot <- param.names[p] - - param.check <- unlist(lapply(lapply(params,'[[',pft),'[[',param.plot)) - - if(!is.null(param.check)){ - param.hist[p,s,] <- param.check - wt.mean <- wt.var <- numeric(nt) - - for(t in 1:nt){ - wt.mean[t] <- wtd.mean(x=param.hist[p,s,], w = wt.props[t,]) - wt.var[t] <- wtd.var(x=param.hist[p,s,], w = wt.props[t,]) - } - - wt.df[p,s,,1] <- wt.mean - wt.df[p,s,,2] <- wt.mean - mean(param.hist[p,s,]) - wt.df[p,s,,3] <- wt.var - wt.df[p,s,,4] <- wt.var - var(param.hist[p,s,]) - - #plot weighted mean - plot(wt.mean,type='l',ylab='Weighted Mean',xlab='Time') - points(wt.mean, pch=19,cex=.4) - abline(h=mean(param.hist[p,s,])) - abline(h = param.hist[p,s,which.min(colMeans(wt.props,na.rm = TRUE))],col='red') - abline(h = param.hist[p,s,which.max(colMeans(wt.props,na.rm = TRUE))],col='green') - title(main = list(paste(pft,'\n',param.plot), cex = .5)) - - #coloring by the difference in the mean relative to the scale of the parameter - diff.mean <- abs(mean(wt.mean) - mean(param.hist[p,s,])) - if(diff.mean > abs(.00001*mean(param.hist[p,s,]))){ - mtext(text = paste(signif(diff.mean,digits = 3)), side = 3,col = 'red') - }else{ - mtext(text = paste(signif(diff.mean,digits = 3)), side = 3) - } - - #Plot weighted variance - plot(wt.var,type='l',ylab='Weighted Variance',xlab='Time') - points(wt.var, pch=19,cex=.5) - abline(h=var(param.hist[p,s,])) - title(main = list(paste(pft,'\n',param.plot), cex = .5)) - - hist(param.hist[p,s,], freq = FALSE, col= 'lightgrey', main = paste(pft,'\n',param.plot)) - for(t in 1:nt){ - lines(density(param.hist[p,s,], weights = wt.props[t,], na.rm = TRUE), - lwd = 2, col=rainbow(49)[t]) - } - - }else{ - plot.new() - } - - } - } - dev.off() - - pdf('weighted.hists.pdf') - par(mfrow = c(4,4)) - plot.new() - legend('center',c('Weighted Means','Prior'),pch = 19,col=c('lightgrey','black')) - for(p in 1:length(param.names)){ - hist(wt.df[p,,,1], main=param.names[p], freq = FALSE, col = 'lightgrey', xlab = 'Param Value') - lines(density(param.hist[p,,],na.rm = TRUE), lwd = 2) - } - dev.off() - - which.min(colMeans(wt.props,na.rm = TRUE)) - which.max(colMeans(wt.props,na.rm = TRUE)) - - - - par(mfrow=c(1,1)) - mattext(param.hist[1,,], data_names = as.character(1:nens), colors=rainbow(nens), - ylab = c('Parameter Value'), xlab = c('PFT'), type='p', na.fix = TRUE) - - library(weights) - par(mfrow=c(1,2)) - weighted.hist(x = param.hist, w = wt.props[nt,],col = 'lightgrey') - hist(param.hist,col = 'lightgrey',xlim = range(dd$x)) - plot(density(param.hist)) - plot(density(param.hist*wt.props[nt,]*10)) - - ## weighted quantile - wtd.quantile <- function(x,wt,q){ - ord <- order(x) - wstar <- cumsum(wt[ord])/sum(wt) - qi <- findInterval(q,wstar); qi[qi<1]=1;qi[qi>length(x)]=length(x) - return(x[ord[qi]]) - } - - param.quant <- matrix(NA, 3, nt) - - for(t in seq_len(nt)){ - param.quant[,t] <- wtd.quantile(x = param.hist, wt=wt.mat[,t],q=c(.025,.5,.975)) - } - - plot(param.quant[2,], ylim = range(param.quant,na.rm = TRUE)) - ciEnvelope(x = 1:nt, ylo = param.quant[1,1:nt], yhi = param.quant[3,1:nt], col = 'lightblue') - points(param.quant[2,], pch = 19, cex = 1) - - - ###-------------------------------------------------------------------### ### time series ### ###-------------------------------------------------------------------### From ed2f5a822b51d33097f68c66dc59134d3c506222 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Thu, 24 Aug 2017 15:02:17 -0400 Subject: [PATCH 417/771] cleanup --- models/clm45/R/met2model.CLM45.R | 4 +--- models/dalec/R/met2model.DALEC.R | 29 ++++++++++++++--------------- 2 files changed, 15 insertions(+), 18 deletions(-) diff --git a/models/clm45/R/met2model.CLM45.R b/models/clm45/R/met2model.CLM45.R index 34c6d46577e..69453a797da 100644 --- a/models/clm45/R/met2model.CLM45.R +++ b/models/clm45/R/met2model.CLM45.R @@ -29,8 +29,6 @@ met2model.CLM45 <- function(in.path,in.prefix,outfolder,start_date, end_date, ls #close #defining temporal dimension needs to be figured out. If we configure clm to use same tstep then we may not need to change dimensions -# library("PEcAn.data.atmosphere") -# library("PEcAn.utils") # # #Process start and end dates # start_date<-as.POSIXlt(start.date,tz="UTC") @@ -61,7 +59,7 @@ met2model.CLM45 <- function(in.path,in.prefix,outfolder,start_date, end_date, ls # # ##build day and year # -# ifelse(leap_year(year)==TRUE, +# ifelse(lubridate::leap_year(year)==TRUE, # dt <- (366*24*60*60)/length(sec), #leap year # dt <- (365*24*60*60)/length(sec)) #non-leap year # tstep = round(timestep.s/dt) #time steps per day diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index d346b651db8..2e8a44f3526 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -24,7 +24,6 @@ ##' @param end_date the end date of the data to be downloaded (will only use the year part of the date) ##' @param overwrite should existing files be overwritten ##' @param verbose should the function be very verbose -##' @importFrom ncdf4 ncvar_get met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, spin_nyear=NULL,spin_nsample=NULL,spin_resample=NULL, ...) { @@ -38,7 +37,6 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, ## (MPa.m2.s/mmol-1); average foliar nitorgen (gC/m2 leaf area). Calculate these from ## air_temperature (K), surface_downwelling_shortwave_flux_in_air (W/m2), CO2 (ppm) - library(PEcAn.utils) start_date <- as.POSIXlt(start_date, tz = "UTC") start_date_string <- as.character(strptime(start_date, "%Y-%m-%d")) @@ -65,7 +63,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, out.file.full <- file.path(outfolder, out.file) results <- data.frame(file = c(out.file.full), - host = c(fqdn()), + host = c(PEcAn.utils::fqdn()), mimetype = c("text/plain"), formatname = c("DALEC meteorology"), startdate = c(start_date), @@ -80,7 +78,6 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, return(invisible(results)) } - library(PEcAn.data.atmosphere) ## check to see if the outfolder is defined, if not create directory for output if (!file.exists(outfolder)) { @@ -116,12 +113,20 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, tstep <- round(timestep.s / dt) dt <- timestep.s / tstep #dt is now an integer + ## build day of year + doy <- rep(1:365, each = timestep.s / dt)[1:length(sec)] + + if (lubridate::leap_year(year)) { + ## is leap + doy <- rep(1:366, each = timestep.s / dt)[1:length(sec)] + } + ## extract variables - lat <- ncvar_get(nc, "latitude") - lon <- ncvar_get(nc, "longitude") - Tair <- ncvar_get(nc, "air_temperature") ## in Kelvin - SW <- ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") ## in W/m2 - CO2 <- try(ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air")) + lat <- ncdf4::ncvar_get(nc, "latitude") + lon <- ncdf4::ncvar_get(nc, "longitude") + Tair <- ncdf4::ncvar_get(nc, "air_temperature") ## in Kelvin + SW <- ncdf4::ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") ## in W/m2 + CO2 <- try(ncdf4::ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air")) ncdf4::nc_close(nc) useCO2 <- is.numeric(CO2) @@ -149,12 +154,6 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, LeafWaterPot <- rep(LeafWaterPot, length(Tair)) } - ## build day of year - doy <- rep(1:365, each = timestep.s / dt)[1:length(sec)] - if (year %% 4 == 0) { - ## is leap - doy <- rep(1:366, each = timestep.s / dt)[1:length(sec)] - } ## Aggregate variables up to daily Tmean <- udunits2::ud.convert(tapply(Tair, doy, mean, na.rm = TRUE), "Kelvin", "Celsius") From ab5b9c83389df40301ba48128c0a376132fd3fac Mon Sep 17 00:00:00 2001 From: araiho Date: Fri, 25 Aug 2017 14:17:38 -0400 Subject: [PATCH 418/771] taking out overwrite because idea wasn't fully formed. Maybe bring back for another pull request --- models/linkages/R/model2netcdf.LINKAGES.R | 2 +- models/sipnet/R/model2netcdf.SIPNET.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/models/linkages/R/model2netcdf.LINKAGES.R b/models/linkages/R/model2netcdf.LINKAGES.R index 79930c7ed67..d116fa1872a 100644 --- a/models/linkages/R/model2netcdf.LINKAGES.R +++ b/models/linkages/R/model2netcdf.LINKAGES.R @@ -39,7 +39,7 @@ model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, e ### Loop over years in linkages output to create separate netCDF outputs for (y in seq_along(years)) { - # if (file.exists(file.path(outdir, paste(years[y], "nc", sep = "."))) & overwrite ==FALSE) { + # if (file.exists(file.path(outdir, paste(years[y], "nc", sep = ".")))) { # next # } print(paste("---- Processing year: ", years[y])) # turn on for debugging diff --git a/models/sipnet/R/model2netcdf.SIPNET.R b/models/sipnet/R/model2netcdf.SIPNET.R index 8e6e1ae5db5..78edb36e3d9 100644 --- a/models/sipnet/R/model2netcdf.SIPNET.R +++ b/models/sipnet/R/model2netcdf.SIPNET.R @@ -36,7 +36,7 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, ### Loop over years in SIPNET output to create separate netCDF outputs for (y in years) { - # if (file.exists(file.path(outdir, paste(y, "nc", sep = "."))) & overwrite == FALSE) { + # if (file.exists(file.path(outdir, paste(y, "nc", sep = ".")))) { # next # } print(paste("---- Processing year: ", y)) # turn on for debugging From 023ae89905ee61a3f7f8d403fe4661e453baccba Mon Sep 17 00:00:00 2001 From: araiho Date: Fri, 25 Aug 2017 14:38:44 -0400 Subject: [PATCH 419/771] taking out scaling stuff for now because the plan wasn't fully formed. Put the code in RaihoExtras on test-pecan --- modules/assim.sequential/R/sda.enkf.R | 32 +++++---------------------- 1 file changed, 5 insertions(+), 27 deletions(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index b310c0775b2..86cd7f5d52f 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -460,35 +460,13 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { Pf <- Pf + Q } - mu.f.scale <- mu.f / mu.f - mu.f.scale[is.na(mu.f.scale)]<-0 - map.mu.f <- H%*%mu.f - Y.scale <- Y/map.mu.f ##need H in here to match mu.f's to Y's - Pf.scale <- t(t(Pf/mu.f)/mu.f) - Pf.scale[is.na(Pf.scale)]<-0 - R.scale <- t(t(R/as.vector(map.mu.f))/as.vector(map.mu.f)) - - # mu.f.scale <- scale(mu.f,center = FALSE, scale = mean(mu.f)) - # Pf.scale <- mu.f*Pf%*%t(t(mu.f)) - # Pf.scale[is.na(Pf.scale)]<-0 - # R.scale <- matrix(scale(as.vector(R), center = mean(mu.f), scale = 1),2,2) - # Y.scale <- scale(Y, center = mean(mu.f[1:2]), scale = 1) - - ## Kalman Gain - K <- Pf.scale %*% t(H) %*% solve((R.scale + H %*% Pf.scale %*% t(H))) - ## Analysis - mu.a.scale <- mu.f.scale + K %*% (Y.scale - H %*% mu.f.scale) - Pa.scale <- (diag(ncol(X)) - K %*% H) %*% Pf.scale - - Pa <- t(t(Pa.scale*mu.f)*mu.f) - mu.a <- mu.a.scale * mu.f - ## Kalman Gain - #K <- Pf %*% t(H) %*% solve((R + H %*% Pf %*% t(H))) - ## Analysis - #mu.a <- mu.f + K %*% (Y - H %*% mu.f) - #Pa <- (diag(ncol(X)) - K %*% H) %*% Pf + K <- Pf %*% t(H) %*% solve((R + H %*% Pf %*% t(H))) + # Analysis + mu.a <- mu.f + K %*% (Y - H %*% mu.f) + Pa <- (diag(ncol(X)) - K %*% H) %*% Pf enkf.params[[t]] <- list(mu.f = mu.f, Pf = Pf, mu.a = mu.a, Pa = Pa) + } else { ### create matrix the describes the support for each observed state variable at time t From 40a018fa318bad6e41d23adf6140dd0d514fe340 Mon Sep 17 00:00:00 2001 From: Aman Skywalker Date: Sun, 27 Aug 2017 08:27:17 -0500 Subject: [PATCH 420/771] Added log files modified: web/setups/synccorn.php --- web/setups/synccorn.php | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/web/setups/synccorn.php b/web/setups/synccorn.php index 8fa62226903..eda8b32353a 100644 --- a/web/setups/synccorn.php +++ b/web/setups/synccorn.php @@ -14,4 +14,18 @@ include 'sync.php'; } +$tempfile = tmpfile(); +$line = date("Y-m-d H:i:s") . "Corn Hit"; +fwrite($tempfile, $line); + +$configfile = fopen("syscron.log", "a+"); + +rewind($tempfile); + +while (($buffer=fgets($tempfile))!== false) { + fwrite($configfile,$buffer); +} + +fclose($tempfile); // remove tempfile + ?> From 4187b79b8109b2a8bcc2f695b0a2784ff8e27b09 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Sun, 27 Aug 2017 15:33:00 -0400 Subject: [PATCH 421/771] Proof of concept (pass value from UI to server) --- shiny/Data-Ingest/app.R | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/shiny/Data-Ingest/app.R b/shiny/Data-Ingest/app.R index 676b294bd56..4d11ce3a2ac 100644 --- a/shiny/Data-Ingest/app.R +++ b/shiny/Data-Ingest/app.R @@ -10,28 +10,35 @@ library(shiny) library(PEcAn.data.land) library(shinyDND) -# source("dataone_download.R", local = FALSE) # Define UI for application + ui <- fluidPage( - # Application title titlePanel("Data Ingest"), - textInput(inputId = "id", label = "Import From DataONE", value = "doi or identifier"), - textOutput(outputId = "identifier") + textInput("id", label = h3("Import From DataONE"), placeholder = "Enter doi or id here"), + actionButton(inputId = "D1Button", label = "Upload"), - + hr(), + fluidRow(column(3, verbatimTextOutput("identifier"))) ) -# Define server logic server <- function(input, output) { - output$identifier <- renderText({ PEcAn.data.land::dataone_download(input$id) }) + d1d <- eventReactive(input$D1Button, { + input$id + }) + + output$identifier <- renderText({ + d1d() + }) + } # Run the application shinyApp(ui = ui, server = server) +# example data: doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87 \ No newline at end of file From 3eddce3f7c40ac5198b2ce015dc9d1d96da30669 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Sun, 27 Aug 2017 16:10:31 -0400 Subject: [PATCH 422/771] Added dataone_download functionality (unable to test yet) --- shiny/Data-Ingest/app.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/shiny/Data-Ingest/app.R b/shiny/Data-Ingest/app.R index 4d11ce3a2ac..cd6f109a3e1 100644 --- a/shiny/Data-Ingest/app.R +++ b/shiny/Data-Ingest/app.R @@ -27,15 +27,15 @@ ui <- fluidPage( server <- function(input, output) { - d1d <- eventReactive(input$D1Button, { - input$id - }) + d1d <- eventReactive(input$D1Button, { input$id }) #print doi on click + + # d1d <- eventReactive(input$D1Button, { PEcAn.data.land::dataone_download(input$id) }) #run dataone_download on click output$identifier <- renderText({ d1d() }) - + } # Run the application From 04dbe13b02753b99edb50790bb9cc69e19186641 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 11:54:04 -0400 Subject: [PATCH 423/771] Add more debug statements --- modules/data.remote/inst/modisWSDL.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index fb4def572d5..3785c75456b 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -246,7 +246,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start while i < dateList.__len__( )-1: i=i+1 - #__debugPrint( 'i=%d'%i ) + __debugPrint( 'i=%d'%i ) thisDate=mkIntDate( dateList[i] ) @@ -280,6 +280,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start __debugPrint( 'i=%d, j=%d, dateList__len__()=%d'%(i,j,dateList.__len__( )) ) while mkIntDate( dateList[i+j-1] ) > endDate: + __debugPrint( 'j=%d'%j ) j=j-1 From 40011266d728dfc9510c4ee8a5613783b86ccb3e Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 12:16:24 -0400 Subject: [PATCH 424/771] Fix indent --- modules/data.remote/inst/modisWSDL.py | 1 + 1 file changed, 1 insertion(+) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 3785c75456b..2ee3d522c86 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -281,6 +281,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start __debugPrint( 'i=%d, j=%d, dateList__len__()=%d'%(i,j,dateList.__len__( )) ) while mkIntDate( dateList[i+j-1] ) > endDate: __debugPrint( 'j=%d'%j ) + j=j-1 From 7947b07002c98f169014ddc59f8fddc36a16bc3c Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 12:38:14 -0400 Subject: [PATCH 425/771] Why doesn't python like the indent --- modules/data.remote/inst/modisWSDL.py | 2 -- 1 file changed, 2 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 2ee3d522c86..b1c9102d662 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -280,8 +280,6 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start __debugPrint( 'i=%d, j=%d, dateList__len__()=%d'%(i,j,dateList.__len__( )) ) while mkIntDate( dateList[i+j-1] ) > endDate: - __debugPrint( 'j=%d'%j ) - j=j-1 From 11bd7c676de03c2e104acbc452886a87f830fcc7 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 12:49:46 -0400 Subject: [PATCH 426/771] More debugging --- modules/data.remote/inst/modisWSDL.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index b1c9102d662..2cd7adec836 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -246,7 +246,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start while i < dateList.__len__( )-1: i=i+1 - __debugPrint( 'i=%d'%i ) + #__debugPrint( 'i=%d'%i ) thisDate=mkIntDate( dateList[i] ) @@ -287,7 +287,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start requestEnd=dateList[i+j-1] i=i+j-1 - #print >> sys.stderr, requestStart, requestEnd + print >> sys.stderr, requestStart, requestEnd data = client.service.getsubset( lat, lon, product, band, requestStart, requestEnd, kmAboveBelow, kmLeftRight ) From 36916818a2bcb81b875cd5880c9ff525b546fb01 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 12:54:15 -0400 Subject: [PATCH 427/771] More debugging 2 --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 2cd7adec836..3662d96d514 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -290,7 +290,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start print >> sys.stderr, requestStart, requestEnd data = client.service.getsubset( lat, lon, product, band, requestStart, requestEnd, kmAboveBelow, kmLeftRight ) - + __debugPrint("Passed download step") # now fill up the data structure with the returned data... From 02392aa768b6f411ffe1bf99bf8c527a91b28919 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 13:06:51 -0400 Subject: [PATCH 428/771] More debugging 3 --- modules/data.remote/inst/modisWSDL.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 3662d96d514..c793a78bc71 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -305,7 +305,8 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start m.xllcorner=data.xllcorner m.data=np.zeros( (nDates,m.nrows*m.ncols) ) - + + __debugPrint( data.subset.__len__() ) for j in xrange( data.subset.__len__( ) ): kn=0 __debugPrint( data.subset ) From 1228cbf3578ea240a5d54e70a6b22569d2af9d42 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 13:21:33 -0400 Subject: [PATCH 429/771] More debugging 3 --- modules/data.remote/inst/modisWSDL.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index c793a78bc71..1d3d0266376 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -303,7 +303,8 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start m.units=data.units m.yllcorner=data.yllcorner m.xllcorner=data.xllcorner - + + __debugPrint( 'm.nrows=%d, m.ncols=%d, m.units=%d'%(m.nrows,m.ncols,m.units) ) m.data=np.zeros( (nDates,m.nrows*m.ncols) ) __debugPrint( data.subset.__len__() ) From e0b7f6af089d249378c2d52fd74868aed3172345 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 13:24:44 -0400 Subject: [PATCH 430/771] More debugging 5 --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 1d3d0266376..14e86d1f365 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -293,7 +293,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start __debugPrint("Passed download step") # now fill up the data structure with the returned data... - + __debugPrint(n) if n == 0: m.nrows=data.nrows From c4cdefda1cbc7e9f5130b4c7db55fefa4677f713 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 13:28:32 -0400 Subject: [PATCH 431/771] More debugging 6 --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 14e86d1f365..c1696f11062 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -304,7 +304,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start m.yllcorner=data.yllcorner m.xllcorner=data.xllcorner - __debugPrint( 'm.nrows=%d, m.ncols=%d, m.units=%d'%(m.nrows,m.ncols,m.units) ) + __debugPrint( m.nrows ) m.data=np.zeros( (nDates,m.nrows*m.ncols) ) __debugPrint( data.subset.__len__() ) From 2b54252533f2122dd2613fb237e306b906553a4e Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Mon, 28 Aug 2017 13:28:48 -0400 Subject: [PATCH 432/771] minor update to modules/assim.batch/R/gelman_diag.R to fix issue where gelman diagnostic function crashes when using png(file = NULL) on some machines, like MacOSX (https://stackoverflow.com/questions/24759130/disable-plot-display-in-r) --- modules/assim.batch/R/gelman_diag.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/modules/assim.batch/R/gelman_diag.R b/modules/assim.batch/R/gelman_diag.R index f1efd47b6b6..5c72ec7bf1a 100644 --- a/modules/assim.batch/R/gelman_diag.R +++ b/modules/assim.batch/R/gelman_diag.R @@ -70,7 +70,8 @@ gelman_diag_mw <- function(x, #' more conservative approach than the moving-window method. #' @export gelman_diag_gelmanPlot <- function(x, ...) { - png("/dev/null") + #png("/dev/null") + pdf(file = NULL) GBR_raw <- coda::gelman.plot(x) dev.off() GBR <- array(numeric(), dim(GBR_raw$shrink) + c(0, 2, 0)) From b2ee5d80b095e308de6c5c7716e3bd9b99c9e23b Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Mon, 28 Aug 2017 13:37:07 -0400 Subject: [PATCH 433/771] removed commented line --- modules/assim.batch/R/gelman_diag.R | 1 - 1 file changed, 1 deletion(-) diff --git a/modules/assim.batch/R/gelman_diag.R b/modules/assim.batch/R/gelman_diag.R index 5c72ec7bf1a..cfce93b701f 100644 --- a/modules/assim.batch/R/gelman_diag.R +++ b/modules/assim.batch/R/gelman_diag.R @@ -70,7 +70,6 @@ gelman_diag_mw <- function(x, #' more conservative approach than the moving-window method. #' @export gelman_diag_gelmanPlot <- function(x, ...) { - #png("/dev/null") pdf(file = NULL) GBR_raw <- coda::gelman.plot(x) dev.off() From 25e491991a3142ce445975895118fe97704f9d1f Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 13:40:22 -0400 Subject: [PATCH 434/771] More debugging 7 --- modules/data.remote/inst/modisWSDL.py | 2 ++ 1 file changed, 2 insertions(+) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index c1696f11062..20568226aa7 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -294,6 +294,8 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start # now fill up the data structure with the returned data... __debugPrint(n) + __debugPrint( data.subset.__len__() ) + if n == 0: m.nrows=data.nrows From 13a41d6d8e01e6820a8e1b0c1b1b296cf01f6b07 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 13:47:35 -0400 Subject: [PATCH 435/771] More debugging 8 --- modules/data.remote/inst/modisWSDL.py | 3 +++ 1 file changed, 3 insertions(+) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 20568226aa7..ac1dded207b 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -307,7 +307,10 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start m.xllcorner=data.xllcorner __debugPrint( m.nrows ) + __debugPrint( m.ncols ) + __debugPrint( nDates ) m.data=np.zeros( (nDates,m.nrows*m.ncols) ) + __debugPrint( data.subset.__len__() ) for j in xrange( data.subset.__len__( ) ): From d9ed833c79e747ee068a49948525b1dfd8a6400c Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 13:58:29 -0400 Subject: [PATCH 436/771] More debugging 9 --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index ac1dded207b..42e87f83d00 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -306,7 +306,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start m.yllcorner=data.yllcorner m.xllcorner=data.xllcorner - __debugPrint( m.nrows ) + print m.nrows, type(m.nrows) __debugPrint( m.ncols ) __debugPrint( nDates ) m.data=np.zeros( (nDates,m.nrows*m.ncols) ) From d019d1689c1630b8c08d4a058706b3895ef4c7fd Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 14:00:31 -0400 Subject: [PATCH 437/771] Whitespace error --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 42e87f83d00..f85a50b6e87 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -306,7 +306,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start m.yllcorner=data.yllcorner m.xllcorner=data.xllcorner - print m.nrows, type(m.nrows) + print m.nrows, type(m.nrows) __debugPrint( m.ncols ) __debugPrint( nDates ) m.data=np.zeros( (nDates,m.nrows*m.ncols) ) From 0d30cc7d6bffe781a93d60eb68beb3532a5ff84f Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 14:07:09 -0400 Subject: [PATCH 438/771] Fix input data type for numpy.zeros --- modules/data.remote/inst/modisWSDL.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index f85a50b6e87..7411401480d 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -306,9 +306,9 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start m.yllcorner=data.yllcorner m.xllcorner=data.xllcorner + m.nrows = int(m.nrows) + m.nrows = int(m.ncols) print m.nrows, type(m.nrows) - __debugPrint( m.ncols ) - __debugPrint( nDates ) m.data=np.zeros( (nDates,m.nrows*m.ncols) ) From c0c68250f5a366b1ed99494b71fd464dcd8fd7f5 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 14:11:53 -0400 Subject: [PATCH 439/771] Fix misname --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 7411401480d..ae14bd56695 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -307,7 +307,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start m.xllcorner=data.xllcorner m.nrows = int(m.nrows) - m.nrows = int(m.ncols) + m.ncols = int(m.ncols) print m.nrows, type(m.nrows) m.data=np.zeros( (nDates,m.nrows*m.ncols) ) From a2cb481d64d10bb045cd5fb47cc4485c9433beda Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 15:34:08 -0400 Subject: [PATCH 440/771] Debugging continued --- modules/data.remote/inst/modisWSDL.py | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index ae14bd56695..5367a406cf3 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -373,13 +373,13 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, client=setClient( ) prodList = modisClient( client ) -# printList( prodList ) + printList( prodList ) bandList = modisClient( client, product=product ) -# printList( bandList ) + printList( bandList ) dateList = modisClient( client, product=product, band=band, lat=la, lon=lo ) -# printList( dateList ) + printList( dateList ) m = modisClient( client, product=product, band=band, lat=la, lon=lo, startDate=start_date, endDate=end_date, kmAboveBelow=kmAB, kmLeftRight=kmLR) if len(m.dateInt) == 0: From 22a2ea4acfd59819c4ccf9fe88f389a99918e3a3 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 15:46:18 -0400 Subject: [PATCH 441/771] Sweeping debug --- modules/data.remote/inst/modisWSDL.py | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 5367a406cf3..d7a6523bbf4 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -293,8 +293,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start __debugPrint("Passed download step") # now fill up the data structure with the returned data... - __debugPrint(n) - __debugPrint( data.subset.__len__() ) + #__debugPrint( data.subset.__len__() ) if n == 0: @@ -308,15 +307,15 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start m.nrows = int(m.nrows) m.ncols = int(m.ncols) - print m.nrows, type(m.nrows) + print "nrows", m.nrows, type(m.nrows) m.data=np.zeros( (nDates,m.nrows*m.ncols) ) - __debugPrint( data.subset.__len__() ) for j in xrange( data.subset.__len__( ) ): kn=0 __debugPrint( data.subset ) for k in data.subset[j].split(",")[5:]: + print "k" __debugPrint( k ) try: m.data[ n*chunkSize+j,kn] = int( k ) @@ -373,13 +372,13 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, client=setClient( ) prodList = modisClient( client ) - printList( prodList ) +# printList( prodList ) bandList = modisClient( client, product=product ) - printList( bandList ) +# printList( bandList ) dateList = modisClient( client, product=product, band=band, lat=la, lon=lo ) - printList( dateList ) +# printList( dateList ) m = modisClient( client, product=product, band=band, lat=la, lon=lo, startDate=start_date, endDate=end_date, kmAboveBelow=kmAB, kmLeftRight=kmLR) if len(m.dateInt) == 0: @@ -388,12 +387,16 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, date = m.dateInt m.applyScale() if qcband is not None: + print "getting quality assurance for qcband" modisGetQA(m, qcband, client=client ) + print "filter QA" m.filterQA( range(0,2**16,2), fill=-1 ) if sdband is not None: + print "getting sdband" k = modisClient( client, product=product, band=sdband, lat=la, lon=lo, startDate=start_date, endDate=end_date, kmAboveBelow=kmAB, kmLeftRight=kmLR) if qcband is not None: + print "getting QA band for sdband" modisGetQA(k, qcband, client=client ) else: k = None From afdb0d1f557133cef006b0dac944a05717b6cc91 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Mon, 28 Aug 2017 15:54:53 -0400 Subject: [PATCH 442/771] RTM: Minor bugfixes to `invert_bt` - Fix wrong default `lag.max` in `rtm_loglike` - Add more informative messages to `rtm_loglike` - Change default `min_samp` to 5000, becuase the results are a lot more robust and don't take that long. It can always be lowered by the user if desired. --- modules/rtm/R/bayestools.R | 23 +++++++++++++++---- modules/rtm/man/invert_bt.Rd | 2 +- modules/rtm/man/rtm_loglike.Rd | 2 +- .../tests/testthat/test.invert_bayestools.R | 15 ++++++------ 4 files changed, 28 insertions(+), 14 deletions(-) diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R index e356fde2175..ac758a5aaa6 100644 --- a/modules/rtm/R/bayestools.R +++ b/modules/rtm/R/bayestools.R @@ -1,5 +1,5 @@ #' Generic log-likelihood generator for RTMs -rtm_loglike <- function(nparams, model, observed, lag.max = 0.01, ...) { +rtm_loglike <- function(nparams, model, observed, lag.max = NULL, ...) { fail_ll <- -1e10 stopifnot(nparams >= 1, nparams %% 1 == 0, is.function(model), is.numeric(observed)) n_obs <- length(observed) @@ -7,14 +7,26 @@ rtm_loglike <- function(nparams, model, observed, lag.max = 0.01, ...) { rtm_params <- x[seq_len(nparams)] rsd <- x[nparams + 1] mod <- model(rtm_params, ...) - if (any(is.na(mod))) return(fail_ll) + if (any(is.na(mod))) { + message(sum(is.na(mod)), " NA values in model output. Returning loglike = ", fail_ll) + return(fail_ll) + } err <- mod - observed ss <- sum(err * err) sigma2 <- rsd * rsd n_eff <- neff(err, lag.max = lag.max) sigma2eff <- sigma2 * n_obs / n_eff ll <- -0.5 * (n_obs * log(sigma2eff) + ss / sigma2eff) - if (is.na(ll)) return(fail_ll) + if (is.na(ll)) { + message("Log likelihood is NA. Returning loglike = ", fail_ll) + message("Mean error: ", mean(err)) + message("Sum of squares: ", ss) + message("Sigma2 = ", sigma2) + message("n_eff = ", n_eff) + message("sigma2eff = ", sigma2eff) + message("LL = ", ll) + return(fail_ll) + } return(ll) } return(out) @@ -91,7 +103,7 @@ prospect_bt_prior <- function(version, custom_prior = list()) { #' Default is `FALSE` because it may be an excessively conservative #' diagnostic. #' - `min_samp` -- Minimum number of samples after burnin before stopping. -#' Default is 1000. +#' Default is 5000. #' - `max_iter` -- Maximum total number of iterations. Default is 1e6. #' - `lag.max` -- Maximum lag to use for autocorrelation normalization. #' Default is `10 * log10(n)` (same as `stats::acf` function). @@ -113,7 +125,7 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { loop = list(iterations = 2000), other = list(sampler = 'DEzs', use_mpsrf = FALSE, - min_samp = 1000, + min_samp = 5000, max_iter = 1e6, lag.max = NULL, save_progress = NULL, @@ -205,6 +217,7 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { if (burned_samples$burnin == 1) { message('PEcAn.assim.batch::autoburnin reports convergence has not been achieved. ', 'Resuming sampling.') + converged <- FALSE next } n_samples <- coda::niter(burned_samples$samples) diff --git a/modules/rtm/man/invert_bt.Rd b/modules/rtm/man/invert_bt.Rd index 8742db4b0a7..5b931d403db 100644 --- a/modules/rtm/man/invert_bt.Rd +++ b/modules/rtm/man/invert_bt.Rd @@ -39,7 +39,7 @@ iteration count than in \code{init}. Default is \code{FALSE} because it may be an excessively conservative diagnostic. \item \code{min_samp} -- Minimum number of samples after burnin before stopping. -Default is 1000. +Default is 5000. \item \code{max_iter} -- Maximum total number of iterations. Default is 1e6. \item \code{lag.max} -- Maximum lag to use for autocorrelation normalization. Default is \code{10 * log10(n)} (same as \code{stats::acf} function). diff --git a/modules/rtm/man/rtm_loglike.Rd b/modules/rtm/man/rtm_loglike.Rd index 2eea76e9edd..c0aee84ca19 100644 --- a/modules/rtm/man/rtm_loglike.Rd +++ b/modules/rtm/man/rtm_loglike.Rd @@ -4,7 +4,7 @@ \alias{rtm_loglike} \title{Generic log-likelihood generator for RTMs} \usage{ -rtm_loglike(nparams, model, observed, lag.max = 0.01, ...) +rtm_loglike(nparams, model, observed, lag.max = NULL, ...) } \description{ Generic log-likelihood generator for RTMs diff --git a/modules/rtm/tests/testthat/test.invert_bayestools.R b/modules/rtm/tests/testthat/test.invert_bayestools.R index 5073177928c..6e08c934634 100644 --- a/modules/rtm/tests/testthat/test.invert_bayestools.R +++ b/modules/rtm/tests/testthat/test.invert_bayestools.R @@ -1,4 +1,4 @@ -#devtools::load_all('.') +# devtools::load_all('.') library(PEcAnRTM) library(testthat) context('Inversion using BayesianTools') @@ -11,15 +11,16 @@ if (Sys.getenv('CI') == 'true') { model <- function(x) prospect(x, 5)[,1] observed <- model(true_params) + generate.noise() prior <- prospect_bt_prior(5) - custom_settings <- list() + threshold <- 1.3 + custom_settings <- list(init = list(iterations = 2000), + loop = list(iterations = 1000), + other = list(threshold = threshold)) samples <- invert_bt(observed = observed, model = model, prior = prior, - custom_settings = list(init = list(iterations = 2000), - loop = list(iterations = 1000), - other = list(max_iter = 20000, threshold = 1.3))) + custom_settings = custom_settings) - samples_burned <- PEcAn.assim.batch::autoburnin(BayesianTools::getSample(samples, coda = TRUE), method = 'gelman.plot') + samples_burned <- PEcAn.assim.batch::autoburnin(BayesianTools::getSample(samples, coda = TRUE), method = 'gelman.plot', threshold = threshold) mean_estimates <- do.call(cbind, summary(samples_burned)[c('statistics', 'quantiles')]) test_that('Mean estimates are within 10% of true values', - expect_equal(true_params, mean_estimates[seq_along(true_params),'Mean'], tol = 0.1)) + expect_equal(true_params, mean_estimates[names(true_params),'Mean'], tol = 0.1)) } From 2e3313c5d03a160a37b09674033d69adfc937687 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 16:04:23 -0400 Subject: [PATCH 443/771] 64-bit integer in netcdf --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index d7a6523bbf4..1bf4dbf57ce 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -350,7 +350,7 @@ def m_data_to_netCDF(filename, m, k): rootgrp.createDimension('dates', len(m.dateInt)) m_data = rootgrp.createVariable('LAI', 'f8', ('nrow', 'ncol')) m_std = rootgrp.createVariable('LAIStd', 'f8', ('nrow', 'ncol')) - m_date = rootgrp.createVariable('Dates', 'i7', ('dates')) + m_date = rootgrp.createVariable('Dates', 'i8', ('dates')) m_data[:] = m.data if k is not None: m_std[:] = 0.1*k.data From 91f578d56553bb6504784edad1c1ad13a5d1244b Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 16:21:58 -0400 Subject: [PATCH 444/771] Netcdf debugging --- modules/data.remote/inst/modisWSDL.py | 3 +++ 1 file changed, 3 insertions(+) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 1bf4dbf57ce..c449c7c3421 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -352,9 +352,12 @@ def m_data_to_netCDF(filename, m, k): m_std = rootgrp.createVariable('LAIStd', 'f8', ('nrow', 'ncol')) m_date = rootgrp.createVariable('Dates', 'i8', ('dates')) m_data[:] = m.data + print "populated LAI data in netcdf" if k is not None: m_std[:] = 0.1*k.data + print "populated LAIstd data in netcdf" m_date[:] = m.dateInt + print "populated dates in netcdf" rootgrp.close() #def m_date_to_netCDF(filename, varname, data): From f4234d29ad12bbcc226f0ef0dfc8fda0bb8ed024 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 16:28:08 -0400 Subject: [PATCH 445/771] Netcdf debugging 2 --- modules/data.remote/inst/modisWSDL.py | 1 + 1 file changed, 1 insertion(+) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index c449c7c3421..59cd71d9b38 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -351,6 +351,7 @@ def m_data_to_netCDF(filename, m, k): m_data = rootgrp.createVariable('LAI', 'f8', ('nrow', 'ncol')) m_std = rootgrp.createVariable('LAIStd', 'f8', ('nrow', 'ncol')) m_date = rootgrp.createVariable('Dates', 'i8', ('dates')) + print type(m.data[1]) m_data[:] = m.data print "populated LAI data in netcdf" if k is not None: From ea4179e650f166af38547b63e762aa01c6e28555 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 16:31:34 -0400 Subject: [PATCH 446/771] Netcdf debugging 3 --- modules/data.remote/inst/modisWSDL.py | 1 + 1 file changed, 1 insertion(+) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 59cd71d9b38..4a9b86d3087 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -350,6 +350,7 @@ def m_data_to_netCDF(filename, m, k): rootgrp.createDimension('dates', len(m.dateInt)) m_data = rootgrp.createVariable('LAI', 'f8', ('nrow', 'ncol')) m_std = rootgrp.createVariable('LAIStd', 'f8', ('nrow', 'ncol')) + print("dates len ", len(m.dateInt))) m_date = rootgrp.createVariable('Dates', 'i8', ('dates')) print type(m.data[1]) m_data[:] = m.data From 9f28ac291459d15b4b9b0bba6f823d7761c69e65 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 16:33:23 -0400 Subject: [PATCH 447/771] Fix typo --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 4a9b86d3087..37e993c047b 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -350,7 +350,7 @@ def m_data_to_netCDF(filename, m, k): rootgrp.createDimension('dates', len(m.dateInt)) m_data = rootgrp.createVariable('LAI', 'f8', ('nrow', 'ncol')) m_std = rootgrp.createVariable('LAIStd', 'f8', ('nrow', 'ncol')) - print("dates len ", len(m.dateInt))) + print("dates len ", len(m.dateInt)) m_date = rootgrp.createVariable('Dates', 'i8', ('dates')) print type(m.data[1]) m_data[:] = m.data From e2ce4cf7f39457f2ede2cb3341e5b289fe12ac2a Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 16:47:34 -0400 Subject: [PATCH 448/771] Fix netcdf format --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 37e993c047b..bc8e526d00e 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -344,7 +344,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start def m_data_to_netCDF(filename, m, k): - rootgrp = netCDF4.Dataset(filename, 'w', format='NETCDF3_64BIT') + rootgrp = netCDF4.Dataset(filename, 'w', format='NETCDF3_64BIT_DATA') rootgrp.createDimension('ncol', m.data.shape[1]) rootgrp.createDimension('nrow', m.data.shape[0]) rootgrp.createDimension('dates', len(m.dateInt)) From 18eb812aa68846c4c963dc14a63250c32a88d573 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 17:04:26 -0400 Subject: [PATCH 449/771] Print Modis data --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index bc8e526d00e..e54b1aaf5df 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -406,7 +406,7 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, else: k = None - + printModisData( m ) m_data_to_netCDF(fname, m, k) # print(len(m.data)) From 10ddd0e052401a8e07bb24e605712eead89dc693 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 17:10:19 -0400 Subject: [PATCH 450/771] Print Modis data earlier --- modules/data.remote/inst/modisWSDL.py | 1 + 1 file changed, 1 insertion(+) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index e54b1aaf5df..2b31ac05df2 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -394,6 +394,7 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, if qcband is not None: print "getting quality assurance for qcband" modisGetQA(m, qcband, client=client ) + printModisData(m) print "filter QA" m.filterQA( range(0,2**16,2), fill=-1 ) From 5e25849410de53e23128136c3b811a3ae2f126d2 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 17:18:59 -0400 Subject: [PATCH 451/771] Fix bit scale --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 2b31ac05df2..0d0bef66a3e 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -396,7 +396,7 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, modisGetQA(m, qcband, client=client ) printModisData(m) print "filter QA" - m.filterQA( range(0,2**16,2), fill=-1 ) + m.filterQA( range(0,2**8,2), fill=-1 ) if sdband is not None: print "getting sdband" From 2a9f7d1c71d908fffac910dc5fc6c89ba870e683 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Mon, 28 Aug 2017 17:27:38 -0400 Subject: [PATCH 452/771] Make: Return document and install dependencies This fixes Travis and other fresh installs, at the cost of making more frequent, local installs take longer. --- Makefile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Makefile b/Makefile index 5dd4456283b..ab51343c0e5 100644 --- a/Makefile +++ b/Makefile @@ -42,7 +42,7 @@ all: install document document: $(ALL_PKGS_D) .doc/base/all install: $(ALL_PKGS_I) .install/base/all check: $(ALL_PKGS_C) .check/base/all -test: $(ALL_PKGS_T) .test/base/all +test: $(ALL_PKGS_T) .test/base/all ### Dependencies .doc/base/all: $(ALL_PKGS_D) @@ -50,7 +50,7 @@ test: $(ALL_PKGS_T) .test/base/all .check/base/all: $(ALL_PKGS_C) .test/base/all: $(ALL_PKGS_T) -depends = .check/$(1) .test/$(1) +depends = .doc/$(1) .install/$(1) .check/$(1) .test/$(1) $(call depends,base/db): .install/base/logger .install/base/utils $(call depends,base/settings): .install/base/logger .install/base/utils .install/base/db @@ -59,7 +59,7 @@ $(call depends,modules/data.atmosphere): .install/base/logger .install/base/util $(call depends,modules/data.land): .install/base/logger .install/base/db .install/base/utils $(call depends,modules/meta.analysis): .install/base/logger .install/base/utils .install/base/db $(call depends,modules/priors): .install/base/logger .install/base/utils -$(call depends,modules/assim.batch): .install/base/logger .install/base/utils .install/base/db .install/modules/meta.analysis +$(call depends,modules/assim.batch): .install/base/logger .install/base/utils .install/base/db .install/modules/meta.analysis $(call depends,modules/rtm): .install/base/logger .install/modules/assim.batch $(call depends,modules/uncertainty): .install/base/logger .install/base/utils .install/modules/priors $(call depends,models/template): .install/base/logger .install/base/utils From 24dfa89873bf76a315771ccc69d1e65de9049dd0 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 18:53:44 -0400 Subject: [PATCH 453/771] Try netcdf4 format --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 0d0bef66a3e..f40c8c70da2 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -344,7 +344,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start def m_data_to_netCDF(filename, m, k): - rootgrp = netCDF4.Dataset(filename, 'w', format='NETCDF3_64BIT_DATA') + rootgrp = netCDF4.Dataset(filename, 'w', format='NETCDF4') rootgrp.createDimension('ncol', m.data.shape[1]) rootgrp.createDimension('nrow', m.data.shape[0]) rootgrp.createDimension('dates', len(m.dateInt)) From 8eba0b6634b527780d11b4e004ca81703244b70b Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Mon, 28 Aug 2017 19:21:24 -0400 Subject: [PATCH 454/771] fixed parens error --- shiny/Data-Ingest/app.R | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/shiny/Data-Ingest/app.R b/shiny/Data-Ingest/app.R index cd6f109a3e1..eab9229bc69 100644 --- a/shiny/Data-Ingest/app.R +++ b/shiny/Data-Ingest/app.R @@ -10,8 +10,6 @@ library(shiny) library(PEcAn.data.land) library(shinyDND) - - # Define UI for application ui <- fluidPage( @@ -22,7 +20,12 @@ ui <- fluidPage( actionButton(inputId = "D1Button", label = "Upload"), hr(), - fluidRow(column(3, verbatimTextOutput("identifier"))) + fluidRow(column(3, verbatimTextOutput("identifier"))), + + # https://github.com/rstudio/shiny-examples/blob/master/009-upload/app.R + fileInput(inputId = "file", label = h3("Select Local Files for Upload"), accept = NULL, multiple = TRUE), + p("One or more files") + ) server <- function(input, output) { @@ -35,7 +38,6 @@ server <- function(input, output) { d1d() }) - } # Run the application From 06a94d7860afd20172c09563e1483931777dd3bb Mon Sep 17 00:00:00 2001 From: araiho Date: Mon, 28 Aug 2017 20:30:36 -0400 Subject: [PATCH 455/771] found bug causing linkages to run with the same met every year --- models/linkages/R/write.config.LINKAGES.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/models/linkages/R/write.config.LINKAGES.R b/models/linkages/R/write.config.LINKAGES.R index 67a965ac4dc..024554e4fa1 100644 --- a/models/linkages/R/write.config.LINKAGES.R +++ b/models/linkages/R/write.config.LINKAGES.R @@ -96,8 +96,10 @@ write.config.LINKAGES <- function(defaults = NULL, trait.values, settings, run.i climate_file <- settings$run$inputs$met$path load(climate_file) - temp.mat <- temp.mat[start.year:end.year - start.year + 1, ] - precip.mat <- precip.mat[start.year:end.year - start.year + 1, ] + #temp.mat <- temp.mat[start.year:end.year - start.year + 1, ] + temp.mat <- temp.mat[which(temp.mat[,13]%in%start.year:end.year),] + precip.mat <- precip.mat[which( precip.mat[,13]%in%start.year:end.year),] + #precip.mat <- precip.mat[start.year:end.year - start.year + 1, ] basesc <- 74 basesn <- 1.64 From f15f85bc42a15e6cd5975e14fa7071c7e3eeedd4 Mon Sep 17 00:00:00 2001 From: Ann Raiho Date: Mon, 28 Aug 2017 20:35:48 -0400 Subject: [PATCH 456/771] saving some load changes --- modules/assim.sequential/R/load_data_paleon_sda.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/assim.sequential/R/load_data_paleon_sda.R b/modules/assim.sequential/R/load_data_paleon_sda.R index e35e4d2112a..3dba9c238ff 100644 --- a/modules/assim.sequential/R/load_data_paleon_sda.R +++ b/modules/assim.sequential/R/load_data_paleon_sda.R @@ -77,7 +77,7 @@ load_data_paleon_sda <- function(settings){ if(format_id[[i]] == '1000000040'){ obvs[[i]] <- obvs[[i]][obvs[[i]]$model_type=='Model RW + Census',] obvs[[i]]$AbvGrndWood <- obvs[[i]]$AbvGrndWood * biomass2carbon - obvs[[i]]$NPP <- obvs[[i]]$NPP #* biomass2carbon + obvs[[i]]$NPP <- obvs[[i]]$NPP #* biomass2carbon #kg/m^2/s arguments <- list(.(year, MCMC_iteration, site_id), .(variable)) arguments2 <- list(.(year), .(variable)) arguments3 <- list(.(MCMC_iteration), .(variable), .(year)) @@ -111,8 +111,8 @@ load_data_paleon_sda <- function(settings){ melt.test <- reshape2::melt(dataset, id = melt_id, na.rm = TRUE) cast.test <- reshape2::dcast(melt.test, arguments, sum, margins = variable) - melt_id <- colnames(cast.test)[-which(colnames(cast.test) %in% variable)] - melt.next <- reshape2::melt(cast.test, id = melt_id) + melt_id_next <- colnames(cast.test)[-which(colnames(cast.test) %in% variable)] + melt.next <- reshape2::melt(cast.test, id = melt_id_next) mean_mat <- reshape2::dcast(melt.next, arguments2, mean) iter_mat <- reshape2::acast(melt.next, arguments3, mean) From 2e1dd85a192944f7ec26fc5a48568dc2101d8bab Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 21:35:28 -0400 Subject: [PATCH 457/771] Why is QA a different length --- modules/data.remote/inst/modisWSDL.py | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index f40c8c70da2..49f6fd54d4d 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -189,6 +189,10 @@ def modisGetQA( m, QAname, client=None, chunkSize=8 ): startDate=m.dateInt[0] endDate=m.dateInt[-1] + print "startDate:",startDate + print "endDate:", endDate + print "kmLR:",m.kmLeftRight + q = modisClient( client, product=m.product, band=QAname, lat=m.latitude, lon=m.longitude, startDate=startDate, endDate=endDate, chunkSize=chunkSize, kmAboveBelow=m.kmAboveBelow, kmLeftRight=m.kmLeftRight ) @@ -315,8 +319,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start kn=0 __debugPrint( data.subset ) for k in data.subset[j].split(",")[5:]: - print "k" - __debugPrint( k ) + __debugPrint("k:", k ) try: m.data[ n*chunkSize+j,kn] = int( k ) except ValueError: @@ -391,6 +394,7 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, return np.array([[]]), np.array([[]]) date = m.dateInt m.applyScale() + print m.kmLeftRight if qcband is not None: print "getting quality assurance for qcband" modisGetQA(m, qcband, client=client ) From 7599f1fb7f2cac9481afd49bf2821f94881deae5 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 21:40:29 -0400 Subject: [PATCH 458/771] debugPrint can't take 2 arguments --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 49f6fd54d4d..ed31027742d 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -319,7 +319,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start kn=0 __debugPrint( data.subset ) for k in data.subset[j].split(",")[5:]: - __debugPrint("k:", k ) + __debugPrint( k ) try: m.data[ n*chunkSize+j,kn] = int( k ) except ValueError: From 5b94df04dea11b8a4c5e7405cf0cc91241311264 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 21:45:14 -0400 Subject: [PATCH 459/771] Of course I didn't print the right thing --- modules/data.remote/inst/modisWSDL.py | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index ed31027742d..5338694713b 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -192,6 +192,7 @@ def modisGetQA( m, QAname, client=None, chunkSize=8 ): print "startDate:",startDate print "endDate:", endDate print "kmLR:",m.kmLeftRight + print "kmAB:",m.kmAboveBelow q = modisClient( client, product=m.product, band=QAname, lat=m.latitude, lon=m.longitude, startDate=startDate, endDate=endDate, chunkSize=chunkSize, kmAboveBelow=m.kmAboveBelow, kmLeftRight=m.kmLeftRight ) @@ -292,7 +293,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start i=i+j-1 print >> sys.stderr, requestStart, requestEnd - + print "km:"kmAboveBelow, kmLeftRight data = client.service.getsubset( lat, lon, product, band, requestStart, requestEnd, kmAboveBelow, kmLeftRight ) __debugPrint("Passed download step") @@ -394,7 +395,7 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, return np.array([[]]), np.array([[]]) date = m.dateInt m.applyScale() - print m.kmLeftRight + print "kmab", m.kmAboveBelow if qcband is not None: print "getting quality assurance for qcband" modisGetQA(m, qcband, client=client ) From a3e68b61d7ce3e0a672c317db020e6c378a21682 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 21:51:05 -0400 Subject: [PATCH 460/771] forgot a comma --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 5338694713b..f5d9130afd5 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -293,7 +293,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start i=i+j-1 print >> sys.stderr, requestStart, requestEnd - print "km:"kmAboveBelow, kmLeftRight + print "km:",kmAboveBelow, kmLeftRight data = client.service.getsubset( lat, lon, product, band, requestStart, requestEnd, kmAboveBelow, kmLeftRight ) __debugPrint("Passed download step") From 85aa7a877df99ebb360042ff93fc752271916bd9 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 22:04:51 -0400 Subject: [PATCH 461/771] SERIOUSLY? One extra capitalized letter --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index f5d9130afd5..d0a9cac645c 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -209,7 +209,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start m=modisData() - m.kmABoveBelow=kmAboveBelow + m.kmAboveBelow=kmAboveBelow m.kmLeftRight=kmLeftRight if client==None: From 1cb52978d88cc7af5523db6a45ce94f6d90360de Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 22:10:40 -0400 Subject: [PATCH 462/771] Switch back to 16 bit QA just in case --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index d0a9cac645c..ac99b3b00ac 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -401,7 +401,7 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, modisGetQA(m, qcband, client=client ) printModisData(m) print "filter QA" - m.filterQA( range(0,2**8,2), fill=-1 ) + m.filterQA( range(0,2**16,2), fill=-1 ) if sdband is not None: print "getting sdband" From 42bc1f2ac1192f5ae02db1cb8d72a31ad410c535 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 23:11:50 -0400 Subject: [PATCH 463/771] Clean up debugging messages --- modules/data.remote/inst/modisWSDL.py | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index ac99b3b00ac..f1bdf646d01 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -174,7 +174,7 @@ def printModisData( m ): print 'dates:', m.dateStr print 'QA:', m.QA - print m.data + print 'data:',m.data def __debugPrint( o ): @@ -189,10 +189,6 @@ def modisGetQA( m, QAname, client=None, chunkSize=8 ): startDate=m.dateInt[0] endDate=m.dateInt[-1] - print "startDate:",startDate - print "endDate:", endDate - print "kmLR:",m.kmLeftRight - print "kmAB:",m.kmAboveBelow q = modisClient( client, product=m.product, band=QAname, lat=m.latitude, lon=m.longitude, startDate=startDate, endDate=endDate, chunkSize=chunkSize, kmAboveBelow=m.kmAboveBelow, kmLeftRight=m.kmLeftRight ) @@ -293,7 +289,6 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start i=i+j-1 print >> sys.stderr, requestStart, requestEnd - print "km:",kmAboveBelow, kmLeftRight data = client.service.getsubset( lat, lon, product, band, requestStart, requestEnd, kmAboveBelow, kmLeftRight ) __debugPrint("Passed download step") @@ -312,7 +307,6 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start m.nrows = int(m.nrows) m.ncols = int(m.ncols) - print "nrows", m.nrows, type(m.nrows) m.data=np.zeros( (nDates,m.nrows*m.ncols) ) @@ -354,9 +348,7 @@ def m_data_to_netCDF(filename, m, k): rootgrp.createDimension('dates', len(m.dateInt)) m_data = rootgrp.createVariable('LAI', 'f8', ('nrow', 'ncol')) m_std = rootgrp.createVariable('LAIStd', 'f8', ('nrow', 'ncol')) - print("dates len ", len(m.dateInt)) m_date = rootgrp.createVariable('Dates', 'i8', ('dates')) - print type(m.data[1]) m_data[:] = m.data print "populated LAI data in netcdf" if k is not None: @@ -395,11 +387,10 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, return np.array([[]]), np.array([[]]) date = m.dateInt m.applyScale() - print "kmab", m.kmAboveBelow if qcband is not None: - print "getting quality assurance for qcband" + print "getting QA (quality assurance) for qcband" modisGetQA(m, qcband, client=client ) - printModisData(m) + # printModisData(m) print "filter QA" m.filterQA( range(0,2**16,2), fill=-1 ) From 2f7a4cc07fc4d8cd7f73571c3204385fdac0da91 Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 28 Aug 2017 23:15:28 -0400 Subject: [PATCH 464/771] One fewer debug message --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index f1bdf646d01..6c476c3ffe8 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -314,7 +314,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start kn=0 __debugPrint( data.subset ) for k in data.subset[j].split(",")[5:]: - __debugPrint( k ) + #__debugPrint( k ) try: m.data[ n*chunkSize+j,kn] = int( k ) except ValueError: From 38fbb10472f8a4dc05078495ffb48850e1b61302 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 10:47:02 -0400 Subject: [PATCH 465/771] clean up call_MODIS --- modules/data.remote/R/call_MODIS.R | 89 ++++++++++++++++-------------- 1 file changed, 47 insertions(+), 42 deletions(-) diff --git a/modules/data.remote/R/call_MODIS.R b/modules/data.remote/R/call_MODIS.R index 796512640ca..2a83dd90a6b 100644 --- a/modules/data.remote/R/call_MODIS.R +++ b/modules/data.remote/R/call_MODIS.R @@ -3,10 +3,17 @@ ##' @name call_MODIS ##' @title call_MODIS ##' @export +##' @param outfolder where the output file will be stored +##' @param fname name of netcdf file to output ##' @param start first date in year and day-of-year. For example May 1 2010 would be 2010121 ##' @param end laste date in year and day-of-year. For example May 1 2010 would be 2010121 ##' @param lat Latitude of the pixel ##' @param lon Longitude of the pixel +##' @param size NS and WE distance in km to be included +##' @param product MODIS product number +##' @param band which measurement to extract +##' @param qcband which quality control band (optional) +##' @param sdband which standard deviation band (optional) ##' ##' depends on a number of Python libraries. sudo -H pip install numpy suds netCDF4 ##' @@ -18,83 +25,81 @@ call_MODIS <- function(outfolder = ".", fname = "m_data.nc", start, end, lat, lon, size = 0, product = "MOD15A2", band = "Lai_1km", qc_band = NA, sd_band = NA) { - library(MODISTools) - - dat <- MODISTools::GetSubset(Lat=lat, Long=lon, Product=product, Band=band, - StartDate=as.integer(start), EndDate=as.integer(end), KmAboveBelow=size, KmLeftRight=size) - if(!is.na(qc_band)){ - qc <- MODISTools::GetSubset(Lat=lat, Long=lon, Product=product, Band=qc_band, - StartDate=as.integer(start), EndDate=as.integer(end), KmAboveBelow=size, KmLeftRight=size) - } else { - qc <- NULL - } - if(!is.na(sd_band)){ - sd <- MODISTools::GetSubset(Lat=lat, Long=lon, Product=product, Band=sd_band, - StartDate=as.integer(start), EndDate=as.integer(end), KmAboveBelow=size, KmLeftRight=size) - } else { - sd <- NULL - } - - return(list(dat,qc,sd)) + # library(MODISTools) + # + # dat <- MODISTools::GetSubset(Lat=lat, Long=lon, Product=product, Band=band, + # StartDate=as.integer(start), EndDate=as.integer(end), KmAboveBelow=size, KmLeftRight=size) + # if(!is.na(qc_band)){ + # qc <- MODISTools::GetSubset(Lat=lat, Long=lon, Product=product, Band=qc_band, + # StartDate=as.integer(start), EndDate=as.integer(end), KmAboveBelow=size, KmLeftRight=size) + # } else { + # qc <- NULL + # } + # if(!is.na(sd_band)){ + # sd <- MODISTools::GetSubset(Lat=lat, Long=lon, Product=product, Band=sd_band, + # StartDate=as.integer(start), EndDate=as.integer(end), KmAboveBelow=size, KmLeftRight=size) + # } else { + # sd <- NULL + # } + # + # return(list(dat,qc,sd)) library(rPython) - # The name of the netCDF file. I've here given a constant name, but it can easily be - # changed to be an input + # The name of the netCDF file. fname <- paste0(outfolder, "/", fname) # Distance of the are both east-west and north-south from the center of the pixel. - # Similarly to the file name, I've left it also easily inputtable. kmNS <- as.integer(size) kmWE <- as.integer(size) # Here it assigns the run directory and given variables values within python - python.assign("cwd", getwd()) + rPython::python.assign("cwd", getwd()) - python.assign("start", as.integer(start)) - if (python.get("start") != start) { + rPython::python.assign("start", as.integer(start)) + if ( rPython::python.get("start") != start) { stop("call_MODIS start date sent incorrectly") } - python.assign("end", as.integer(end)) - if (python.get("end") != end) { + rPython::python.assign("end", as.integer(end)) + if (rPython::python.get("end") != end) { stop("call_MODIS end date sent incorrectly") } - python.assign("lat", lat) - python.assign("lon", lon) - python.assign("kmNS", kmNS) - python.assign("kmWE", kmWE) - python.assign("fn", fname) - python.assign("product", product) - python.assign("band", band) - python.assign("qcband", qc_band) - python.assign("sdband", sd_band) + rPython::python.assign("lat", lat) + rPython::python.assign("lon", lon) + rPython::python.assign("kmNS", kmNS) + rPython::python.assign("kmWE", kmWE) + rPython::python.assign("fn", fname) + rPython::python.assign("product", product) + rPython::python.assign("band", band) + rPython::python.assign("qcband", qc_band) + rPython::python.assign("sdband", sd_band) # Here we import the MODIS python script as a module for the python. That way we can # run the routines within the script as independent commands. script.path <- dirname(system.file("modisWSDL.py", package = "PEcAn.data.remote")) - python.exec(paste0("import sys; sys.path.append(\"", script.path, "\")")) - python.exec("import modisWSDL") + rPython::python.exec(paste0("import sys; sys.path.append(\"", script.path, "\")")) + rPython::python.exec("import modisWSDL") # This is overkill if you are not editing modisWSDL, but if you are developing this # will refresh the definition of the module - python.exec("reload(modisWSDL)") + rPython::python.exec("reload(modisWSDL)") # And here we execute the main MODIS run. Although it should be noted that while we get # values of the run here, the script also does write a netCDF output file. - python.exec("m, k, date = modisWSDL.run_main(start_date=start, end_date=end,la=lat,lo=lon,kmAB=kmNS,kmLR=kmWE,fname=fn,product=product,band=band,qcband=qcband,sdband=sdband)") + rPython::python.exec("m, k, date = modisWSDL.run_main(start_date=start, end_date=end,la=lat,lo=lon,kmAB=kmNS,kmLR=kmWE,fname=fn,product=product,band=band,qcband=qcband,sdband=sdband)") # m = The MODIS observed LAI for the given pixel k = The standard deviation of the # MODIS LAI. Be careful with this as it is at times very low date = Year and # day-of-year of the observation - m <- python.get("[ map(float, x) for x in m.data ]") + m <- rPython::python.get("[ map(float, x) for x in m.data ]") if (!is.na(sd_band)) { - k <- python.get("[ map(float, x) for x in k.data ]") + k <- rPython::python.get("[ map(float, x) for x in k.data ]") } else { k <- NA } - date <- python.get("date") + date <- rPython::python.get("date") return(invisible(list(m = m, k = k, date = date))) } # call_MODIS From f18960f6dee2b766ec0f3546d1cb4305366a37d8 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 10:57:25 -0400 Subject: [PATCH 466/771] Fix params --- modules/data.remote/R/call_MODIS.R | 4 ++-- modules/data.remote/man/call_MODIS.Rd | 16 +++++++++++++++- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/modules/data.remote/R/call_MODIS.R b/modules/data.remote/R/call_MODIS.R index 2a83dd90a6b..483044f45ff 100644 --- a/modules/data.remote/R/call_MODIS.R +++ b/modules/data.remote/R/call_MODIS.R @@ -12,8 +12,8 @@ ##' @param size NS and WE distance in km to be included ##' @param product MODIS product number ##' @param band which measurement to extract -##' @param qcband which quality control band (optional) -##' @param sdband which standard deviation band (optional) +##' @param qc_band which quality control band (optional) +##' @param sd_band which standard deviation band (optional) ##' ##' depends on a number of Python libraries. sudo -H pip install numpy suds netCDF4 ##' diff --git a/modules/data.remote/man/call_MODIS.Rd b/modules/data.remote/man/call_MODIS.Rd index cc736c40cd6..982fd155bf3 100644 --- a/modules/data.remote/man/call_MODIS.Rd +++ b/modules/data.remote/man/call_MODIS.Rd @@ -9,13 +9,27 @@ call_MODIS(outfolder = ".", fname = "m_data.nc", start, end, lat, lon, sd_band = NA) } \arguments{ +\item{outfolder}{where the output file will be stored} + +\item{fname}{name of netcdf file to output} + \item{start}{first date in year and day-of-year. For example May 1 2010 would be 2010121} \item{end}{laste date in year and day-of-year. For example May 1 2010 would be 2010121} \item{lat}{Latitude of the pixel} -\item{lon}{Longitude of the pixel +\item{lon}{Longitude of the pixel} + +\item{size}{NS and WE distance in km to be included} + +\item{product}{MODIS product number} + +\item{band}{which measurement to extract} + +\item{qcband}{which quality control band (optional)} + +\item{sdband}{which standard deviation band (optional) depends on a number of Python libraries. sudo -H pip install numpy suds netCDF4} } From c301792b6ee254001476daae829beabf10b1a3eb Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 10:58:27 -0400 Subject: [PATCH 467/771] modules/data.remote/man/call_MODIS.Rd --- modules/data.remote/man/call_MODIS.Rd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.remote/man/call_MODIS.Rd b/modules/data.remote/man/call_MODIS.Rd index 982fd155bf3..96bbe694994 100644 --- a/modules/data.remote/man/call_MODIS.Rd +++ b/modules/data.remote/man/call_MODIS.Rd @@ -27,9 +27,9 @@ call_MODIS(outfolder = ".", fname = "m_data.nc", start, end, lat, lon, \item{band}{which measurement to extract} -\item{qcband}{which quality control band (optional)} +\item{qc_band}{which quality control band (optional)} -\item{sdband}{which standard deviation band (optional) +\item{sd_band}{which standard deviation band (optional) depends on a number of Python libraries. sudo -H pip install numpy suds netCDF4} } From ab9be92a216ed6e9b215a20cbdc734c11d463b5a Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 11:21:43 -0400 Subject: [PATCH 468/771] Add debug switch functionality --- modules/data.remote/inst/modisWSDL.py | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 6c476c3ffe8..618575763e7 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -350,12 +350,12 @@ def m_data_to_netCDF(filename, m, k): m_std = rootgrp.createVariable('LAIStd', 'f8', ('nrow', 'ncol')) m_date = rootgrp.createVariable('Dates', 'i8', ('dates')) m_data[:] = m.data - print "populated LAI data in netcdf" + __debugPrint( "populated LAI data in netcdf" ) if k is not None: m_std[:] = 0.1*k.data - print "populated LAIstd data in netcdf" + __debugPrint( "populated LAIstd data in netcdf" ) m_date[:] = m.dateInt - print "populated dates in netcdf" + _debugPrint( "populated dates in netcdf" ) rootgrp.close() #def m_date_to_netCDF(filename, varname, data): @@ -368,7 +368,9 @@ def m_data_to_netCDF(filename, m, k): # rootgrp.close() -def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, kmLR=0, fname='m_data.nc',product='MOD15A2',band='Lai_1km',qcband='FparLai_QC',sdband='LaiStdDev_1km'): +def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, kmLR=0, fname='m_data.nc',product='MOD15A2',band='Lai_1km',qcband='FparLai_QC',sdband='LaiStdDev_1km',debug=True): + + DEBUG_PRINTING = debug client=setClient( ) @@ -388,22 +390,23 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, date = m.dateInt m.applyScale() if qcband is not None: - print "getting QA (quality assurance) for qcband" + __debugPrint( "getting QA (quality assurance) for qcband" ) modisGetQA(m, qcband, client=client ) # printModisData(m) - print "filter QA" + __debugPrint( "filter QA" ) m.filterQA( range(0,2**16,2), fill=-1 ) if sdband is not None: - print "getting sdband" + __debugPrint( "getting sdband" ) k = modisClient( client, product=product, band=sdband, lat=la, lon=lo, startDate=start_date, endDate=end_date, kmAboveBelow=kmAB, kmLeftRight=kmLR) if qcband is not None: - print "getting QA band for sdband" + __debugPrint( "getting QA band for sdband" ) modisGetQA(k, qcband, client=client ) else: k = None - - printModisData( m ) + if DEBUG_PRINTING: + printModisData( m ) + m_data_to_netCDF(fname, m, k) # print(len(m.data)) From 0af3b178784659e4a36ca168b9a189c7e6d1087e Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 11:25:51 -0400 Subject: [PATCH 469/771] Missing _ --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 618575763e7..73bef67befe 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -355,7 +355,7 @@ def m_data_to_netCDF(filename, m, k): m_std[:] = 0.1*k.data __debugPrint( "populated LAIstd data in netcdf" ) m_date[:] = m.dateInt - _debugPrint( "populated dates in netcdf" ) + __debugPrint( "populated dates in netcdf" ) rootgrp.close() #def m_date_to_netCDF(filename, varname, data): From 4f84adc7dbbee81ac4516d542804de6734ed377f Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 11:31:58 -0400 Subject: [PATCH 470/771] Debug debug switch --- modules/data.remote/inst/modisWSDL.py | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 73bef67befe..bd475a95344 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -370,8 +370,11 @@ def m_data_to_netCDF(filename, m, k): def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, kmLR=0, fname='m_data.nc',product='MOD15A2',band='Lai_1km',qcband='FparLai_QC',sdband='LaiStdDev_1km',debug=True): + print DEBUG_PRINTING DEBUG_PRINTING = debug - + print "debug", debug + print "DEBUG", DEBUG_PRINTING + client=setClient( ) prodList = modisClient( client ) From cae240dc5be13860f6c6c481b15d8040bae6d58a Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 11:35:18 -0400 Subject: [PATCH 471/771] Assign global debug variable --- modules/data.remote/inst/modisWSDL.py | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index bd475a95344..bb175fb645a 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -370,8 +370,7 @@ def m_data_to_netCDF(filename, m, k): def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, kmLR=0, fname='m_data.nc',product='MOD15A2',band='Lai_1km',qcband='FparLai_QC',sdband='LaiStdDev_1km',debug=True): - print DEBUG_PRINTING - DEBUG_PRINTING = debug + global DEBUG_PRINTING = debug print "debug", debug print "DEBUG", DEBUG_PRINTING @@ -393,7 +392,7 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, date = m.dateInt m.applyScale() if qcband is not None: - __debugPrint( "getting QA (quality assurance) for qcband" ) + __debugPrint( "getting QA (quality assurance) from qcband" ) modisGetQA(m, qcband, client=client ) # printModisData(m) __debugPrint( "filter QA" ) From 20ee3f522f445b3f310f2d04c87c993ebad6f641 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 11:38:06 -0400 Subject: [PATCH 472/771] Fix global assignment --- modules/data.remote/inst/modisWSDL.py | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index bb175fb645a..2328498fd13 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -370,7 +370,8 @@ def m_data_to_netCDF(filename, m, k): def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, kmLR=0, fname='m_data.nc',product='MOD15A2',band='Lai_1km',qcband='FparLai_QC',sdband='LaiStdDev_1km',debug=True): - global DEBUG_PRINTING = debug + global DEBUG_PRINTING + DEBUG_PRINTING = debug print "debug", debug print "DEBUG", DEBUG_PRINTING From 12cd862160f7eb6cb0179b99da5dcd88d4a36ec7 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 11:45:11 -0400 Subject: [PATCH 473/771] final debug cleanup --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 2328498fd13..37bbf92608a 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -288,7 +288,7 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start requestEnd=dateList[i+j-1] i=i+j-1 - print >> sys.stderr, requestStart, requestEnd + __debugPrint('start date = %s, end date = %s'%(requestStart, requestEnd)) data = client.service.getsubset( lat, lon, product, band, requestStart, requestEnd, kmAboveBelow, kmLeftRight ) __debugPrint("Passed download step") From ae273c30a0bbbc23bb01632befb0271283e2662d Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 11:47:26 -0400 Subject: [PATCH 474/771] Never mind one more debug cleanup --- modules/data.remote/inst/modisWSDL.py | 2 -- 1 file changed, 2 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 37bbf92608a..0f10435953d 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -372,8 +372,6 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, global DEBUG_PRINTING DEBUG_PRINTING = debug - print "debug", debug - print "DEBUG", DEBUG_PRINTING client=setClient( ) From 60db4ed5a16cb01862908f2e52d5856336932194 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 11:49:36 -0400 Subject: [PATCH 475/771] Finalize debug switch in call_MODIS --- modules/data.remote/R/call_MODIS.R | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/modules/data.remote/R/call_MODIS.R b/modules/data.remote/R/call_MODIS.R index 483044f45ff..d9ee499090f 100644 --- a/modules/data.remote/R/call_MODIS.R +++ b/modules/data.remote/R/call_MODIS.R @@ -23,7 +23,7 @@ ##' } ##' call_MODIS <- function(outfolder = ".", fname = "m_data.nc", start, end, lat, lon, size = 0, - product = "MOD15A2", band = "Lai_1km", qc_band = NA, sd_band = NA) { + product = "MOD15A2", band = "Lai_1km", qc_band = NA, sd_band = NA, verbose = TRUE) { # library(MODISTools) # @@ -75,6 +75,7 @@ call_MODIS <- function(outfolder = ".", fname = "m_data.nc", start, end, lat, lo rPython::python.assign("band", band) rPython::python.assign("qcband", qc_band) rPython::python.assign("sdband", sd_band) + python.assign("debug", verbose) # Here we import the MODIS python script as a module for the python. That way we can # run the routines within the script as independent commands. @@ -88,7 +89,7 @@ call_MODIS <- function(outfolder = ".", fname = "m_data.nc", start, end, lat, lo # And here we execute the main MODIS run. Although it should be noted that while we get # values of the run here, the script also does write a netCDF output file. - rPython::python.exec("m, k, date = modisWSDL.run_main(start_date=start, end_date=end,la=lat,lo=lon,kmAB=kmNS,kmLR=kmWE,fname=fn,product=product,band=band,qcband=qcband,sdband=sdband)") + rPython::python.exec("m, k, date = modisWSDL.run_main(start_date=start, end_date=end,la=lat,lo=lon,kmAB=kmNS,kmLR=kmWE,fname=fn,product=product,band=band,qcband=qcband,sdband=sdband,debug=debug)") # m = The MODIS observed LAI for the given pixel k = The standard deviation of the # MODIS LAI. Be careful with this as it is at times very low date = Year and From b74af3339bc6a705facda8366071effbb2c07a0b Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 11:50:33 -0400 Subject: [PATCH 476/771] One more param update --- modules/data.remote/R/call_MODIS.R | 1 + 1 file changed, 1 insertion(+) diff --git a/modules/data.remote/R/call_MODIS.R b/modules/data.remote/R/call_MODIS.R index d9ee499090f..8a73f9beef6 100644 --- a/modules/data.remote/R/call_MODIS.R +++ b/modules/data.remote/R/call_MODIS.R @@ -14,6 +14,7 @@ ##' @param band which measurement to extract ##' @param qc_band which quality control band (optional) ##' @param sd_band which standard deviation band (optional) +##' @param verbose tell python whether or not to print debug statements (all or nothing) ##' ##' depends on a number of Python libraries. sudo -H pip install numpy suds netCDF4 ##' From f1bddbf2fe5a79c2a290bf53e0ddb25ebb583631 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 11:55:47 -0400 Subject: [PATCH 477/771] Documentation --- modules/data.remote/man/call_MODIS.Rd | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/modules/data.remote/man/call_MODIS.Rd b/modules/data.remote/man/call_MODIS.Rd index 96bbe694994..87114d72046 100644 --- a/modules/data.remote/man/call_MODIS.Rd +++ b/modules/data.remote/man/call_MODIS.Rd @@ -6,7 +6,7 @@ \usage{ call_MODIS(outfolder = ".", fname = "m_data.nc", start, end, lat, lon, size = 0, product = "MOD15A2", band = "Lai_1km", qc_band = NA, - sd_band = NA) + sd_band = NA, verbose = TRUE) } \arguments{ \item{outfolder}{where the output file will be stored} @@ -29,7 +29,9 @@ call_MODIS(outfolder = ".", fname = "m_data.nc", start, end, lat, lon, \item{qc_band}{which quality control band (optional)} -\item{sd_band}{which standard deviation band (optional) +\item{sd_band}{which standard deviation band (optional)} + +\item{verbose}{tell python whether or not to print debug statements (all or nothing) depends on a number of Python libraries. sudo -H pip install numpy suds netCDF4} } From a780739cb23954b25868d07d00df619c4ee300b6 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 11:59:28 -0400 Subject: [PATCH 478/771] Update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index a33579bc384..556482aa396 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,6 +14,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Fixed jagify bug for raw field data - Fixed bug (order of dims in nc_create) introduced in model2netcdf.DALEC by standard_vars changes - Cleaned up NAMESPACE and source code of `PEcAn.DB` (#1520) +- Debugged python script in call_MODIS in data.remote to allow MODIS downloads ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) From 8b138ade4c5e7fff7ab94c41dc108dabb1aa88a7 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 29 Aug 2017 12:01:33 -0400 Subject: [PATCH 479/771] RTM: Fix likelihood calculation in invert_bt. Also... - Allow option to disable diagnostic messages - Add predictive interval plot when doing interactive tests of invert_bt. --- modules/rtm/R/bayestools.R | 30 +++++++------ modules/rtm/man/invert_bt.Rd | 1 + modules/rtm/man/rtm_loglike.Rd | 2 +- .../tests/testthat/test.invert_bayestools.R | 43 ++++++++++++++++++- 4 files changed, 62 insertions(+), 14 deletions(-) diff --git a/modules/rtm/R/bayestools.R b/modules/rtm/R/bayestools.R index ac758a5aaa6..3dab792e6bb 100644 --- a/modules/rtm/R/bayestools.R +++ b/modules/rtm/R/bayestools.R @@ -1,5 +1,5 @@ #' Generic log-likelihood generator for RTMs -rtm_loglike <- function(nparams, model, observed, lag.max = NULL, ...) { +rtm_loglike <- function(nparams, model, observed, lag.max = NULL, verbose = TRUE, ...) { fail_ll <- -1e10 stopifnot(nparams >= 1, nparams %% 1 == 0, is.function(model), is.numeric(observed)) n_obs <- length(observed) @@ -8,7 +8,7 @@ rtm_loglike <- function(nparams, model, observed, lag.max = NULL, ...) { rsd <- x[nparams + 1] mod <- model(rtm_params, ...) if (any(is.na(mod))) { - message(sum(is.na(mod)), " NA values in model output. Returning loglike = ", fail_ll) + if (verbose) message(sum(is.na(mod)), " NA values in model output. Returning loglike = ", fail_ll) return(fail_ll) } err <- mod - observed @@ -16,15 +16,17 @@ rtm_loglike <- function(nparams, model, observed, lag.max = NULL, ...) { sigma2 <- rsd * rsd n_eff <- neff(err, lag.max = lag.max) sigma2eff <- sigma2 * n_obs / n_eff - ll <- -0.5 * (n_obs * log(sigma2eff) + ss / sigma2eff) + ll <- -0.5 * (n_eff * log(sigma2eff) + ss / sigma2eff) if (is.na(ll)) { - message("Log likelihood is NA. Returning loglike = ", fail_ll) - message("Mean error: ", mean(err)) - message("Sum of squares: ", ss) - message("Sigma2 = ", sigma2) - message("n_eff = ", n_eff) - message("sigma2eff = ", sigma2eff) - message("LL = ", ll) + if (verbose) { + message("Log likelihood is NA. Returning loglike = ", fail_ll) + message("Mean error: ", mean(err)) + message("Sum of squares: ", ss) + message("Sigma2 = ", sigma2) + message("n_eff = ", n_eff) + message("sigma2eff = ", sigma2eff) + message("LL = ", ll) + } return(fail_ll) } return(ll) @@ -110,6 +112,7 @@ prospect_bt_prior <- function(version, custom_prior = list()) { #' - `save_progress` -- File name for saving samples between loop #' iterations. If `NULL` (default), do not save progress samples. #' - `threshold` -- Threshold for Gelman PSRF convergence diagnostic. Default is 1.1. +#' - `verbose_loglike` -- Diagnostic messages in log likelihood output. Default is TRUE. #' #' See the BayesianTools sampler documentation for what can go in the `BayesianTools` settings lists. #' @param observed Vector of observations @@ -129,7 +132,8 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { max_iter = 1e6, lag.max = NULL, save_progress = NULL, - threshold = 1.1)) + threshold = 1.1, + verbose_loglike = TRUE)) if (length(custom_settings) > 0) { settings <- list() @@ -152,6 +156,7 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { max_iter <- settings[['other']][['max_iter']] save_progress <- settings[['other']][['save_progress']] threshold <- settings[['other']][['threshold']] + verbose_loglike <- settings[['other']][['verbose_loglike']] if (!is.null(save_progress)) { # `file.create` returns FALSE if target directory doesn't exist. @@ -164,7 +169,8 @@ invert_bt <- function(observed, model, prior, custom_settings = list()) { loglike <- rtm_loglike(nparams = nparams, model = model, observed = observed, - lag.max = lag.max) + lag.max = lag.max, + verbose = verbose_loglike) setup <- BayesianTools::createBayesianSetup(likelihood = loglike, diff --git a/modules/rtm/man/invert_bt.Rd b/modules/rtm/man/invert_bt.Rd index 5b931d403db..b1ef06619b4 100644 --- a/modules/rtm/man/invert_bt.Rd +++ b/modules/rtm/man/invert_bt.Rd @@ -46,6 +46,7 @@ Default is \code{10 * log10(n)} (same as \code{stats::acf} function). \item \code{save_progress} -- File name for saving samples between loop iterations. If \code{NULL} (default), do not save progress samples. \item \code{threshold} -- Threshold for Gelman PSRF convergence diagnostic. Default is 1.1. +\item \code{verbose_loglike} -- Diagnostic messages in log likelihood output. Default is TRUE. } } diff --git a/modules/rtm/man/rtm_loglike.Rd b/modules/rtm/man/rtm_loglike.Rd index c0aee84ca19..1096808b354 100644 --- a/modules/rtm/man/rtm_loglike.Rd +++ b/modules/rtm/man/rtm_loglike.Rd @@ -4,7 +4,7 @@ \alias{rtm_loglike} \title{Generic log-likelihood generator for RTMs} \usage{ -rtm_loglike(nparams, model, observed, lag.max = NULL, ...) +rtm_loglike(nparams, model, observed, lag.max = NULL, verbose = TRUE, ...) } \description{ Generic log-likelihood generator for RTMs diff --git a/modules/rtm/tests/testthat/test.invert_bayestools.R b/modules/rtm/tests/testthat/test.invert_bayestools.R index 6e08c934634..480952414eb 100644 --- a/modules/rtm/tests/testthat/test.invert_bayestools.R +++ b/modules/rtm/tests/testthat/test.invert_bayestools.R @@ -10,17 +10,58 @@ if (Sys.getenv('CI') == 'true') { true_params <- defparam('prospect_5') model <- function(x) prospect(x, 5)[,1] observed <- model(true_params) + generate.noise() + true_rsd <- mean(sum((observed - model(true_params)) ^ 2)) + true_params['residual'] <- true_rsd prior <- prospect_bt_prior(5) threshold <- 1.3 custom_settings <- list(init = list(iterations = 2000), loop = list(iterations = 1000), - other = list(threshold = threshold)) + other = list(threshold = threshold, + verbose_loglike = FALSE)) samples <- invert_bt(observed = observed, model = model, prior = prior, custom_settings = custom_settings) samples_burned <- PEcAn.assim.batch::autoburnin(BayesianTools::getSample(samples, coda = TRUE), method = 'gelman.plot', threshold = threshold) + mean_estimates <- do.call(cbind, summary(samples_burned)[c('statistics', 'quantiles')]) test_that('Mean estimates are within 10% of true values', expect_equal(true_params, mean_estimates[names(true_params),'Mean'], tol = 0.1)) + + # Compare observation with predicted interval + if (interactive()) { + samp_mat <- as.matrix(samples_burned) + nsamp <- 2500 + prosp_mat <- matrix(0.0, nsamp, 2101) + message('Generating PROSPECT confidence interval') + pb <- txtProgressBar(style = 3) + for (i in seq_len(nsamp)) { + setTxtProgressBar(pb, i/nsamp) + samp_param <- samp_mat[sample.int(nrow(samp_mat), 1),] + prosp_mat[i,] <- rnorm(2101, model(samp_param[-6]), samp_param[6]) + } + mid <- colMeans(prosp_mat) + lo <- apply(prosp_mat, 2, quantile, 0.025) + hi <- apply(prosp_mat, 2, quantile, 0.975) + outside <- which(observed < lo | observed > hi) + plot(observed, type = 'l') + lines(mid, col = 'red') + lines(lo, col = 'red', lty = 'dashed') + lines(hi, col = 'red', lty = 'dashed') + orng <- rgb(1, 0.5, 0, 0.2) + abline(v = outside, col = orng) + legend( + 'topright', + c('observed', 'predictive interval', 'outside PI'), + lty = c('solid', 'dashed', 'solid'), + col = c('black', 'red', 'orange'), + lwd = c(1, 1, 2) + ) + print(paste0( + length(outside), '/', 2101, + ' = ', + format(length(outside) / 2101 * 100, digits = 2), + '% of values outside 95% CI' + )) + } } From 4bef15d7e233482b51a16014f380914f263874a0 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 16:45:23 -0400 Subject: [PATCH 480/771] Add LAI to output --- models/sipnet/R/model2netcdf.SIPNET.R | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/models/sipnet/R/model2netcdf.SIPNET.R b/models/sipnet/R/model2netcdf.SIPNET.R index d15af5379cd..d5012e29170 100644 --- a/models/sipnet/R/model2netcdf.SIPNET.R +++ b/models/sipnet/R/model2netcdf.SIPNET.R @@ -86,6 +86,14 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, output[[18]] <- (sub.sipnet.output$snow * 10) # SWE output[[19]] <- sub.sipnet.output$litter * 0.001 ## litter kgC/m2 + param <- read.table(file.path(gsub(pattern = "/out/", + replacement = "/run/", x = outdir), + "sipnet.param"), stringsAsFactors = FALSE) + id <- which(param[, 1] == "leafCSpWt") + leafC <- 0.48 + SLA <- 1000 * leafC / param[id, 2] #SLA, m2/kgC + output[[20]] <- output[[11]] * SLA # LAI + # ******************** Declare netCDF variables ********************# t <- ncdf4::ncdim_def(name = "time", @@ -95,6 +103,7 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, unlim = TRUE) lat <- ncdf4::ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") lon <- ncdf4::ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") + dims <- list(lon = lon, lat = lat, time = t) ## ***** Need to dynamically update the UTC offset here ***** @@ -126,6 +135,7 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, nc_var[[17]] <- mstmipvar("SoilMoistFrac", lat, lon, t, NA) nc_var[[18]] <- mstmipvar("SWE", lat, lon, t, NA) nc_var[[19]] <- mstmipvar("Litter", lat, lon, t, NA) + nc_var[[20]] <- to_ncvar("LAI", dims) # ******************** Declare netCDF variables ********************# From 9eff51f18ff2e799156a0bed26475a9beedadc7a Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 17:20:24 -0400 Subject: [PATCH 481/771] add wood_carbon_content option to prepare_pools --- modules/data.land/R/prepare_pools.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/modules/data.land/R/prepare_pools.R b/modules/data.land/R/prepare_pools.R index b7afe75af67..0838dee7558 100644 --- a/modules/data.land/R/prepare_pools.R +++ b/modules/data.land/R/prepare_pools.R @@ -22,6 +22,7 @@ prepare_pools <- function(nc.path, constants = NULL){ TotLivBiom <- IC.list$vals$TotLivBiom leaf <- IC.list$vals$leaf_carbon_content LAI <- IC.list$vals$LAI + wood <- wood_carbon_content AbvGrndWood <- IC.list$vals$AbvGrndWood roots <- IC.list$vals$root_carbon_content fine.roots <- IC.list$vals$fine_root_carbon_content @@ -78,7 +79,9 @@ prepare_pools <- function(nc.path, constants = NULL){ } # initial pool of woody carbon (kgC/m2) - if (is.valid(AbvGrndWood)) { + if (is.valid(wood)){ + IC.params[["wood"]] <- wood + } else if (is.valid(AbvGrndWood)) { if(is.valid(coarse.roots)){ IC.params[["wood"]] <- (AbvGrndWood + coarse.roots) } else{ From 3b62eb87df3513560e48a26e9c384f65bea3c910 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 17:43:59 -0400 Subject: [PATCH 482/771] Change mstmipvar to standard_vars and to_ncvar: --- models/sipnet/R/model2netcdf.SIPNET.R | 37 ++++++++++++++------------- 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/models/sipnet/R/model2netcdf.SIPNET.R b/models/sipnet/R/model2netcdf.SIPNET.R index d5012e29170..fa220093e9c 100644 --- a/models/sipnet/R/model2netcdf.SIPNET.R +++ b/models/sipnet/R/model2netcdf.SIPNET.R @@ -86,6 +86,7 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, output[[18]] <- (sub.sipnet.output$snow * 10) # SWE output[[19]] <- sub.sipnet.output$litter * 0.001 ## litter kgC/m2 + #calculate LAI for standard output param <- read.table(file.path(gsub(pattern = "/out/", replacement = "/run/", x = outdir), "sipnet.param"), stringsAsFactors = FALSE) @@ -116,26 +117,26 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, nc_var <- list() nc_var[[1]] <- mstmipvar("Year", lat, lon, t, NA) nc_var[[2]] <- mstmipvar("FracJulianDay", lat, lon, t, NA) - nc_var[[3]] <- mstmipvar("GPP", lat, lon, t, NA) - nc_var[[4]] <- mstmipvar("NPP", lat, lon, t, NA) - nc_var[[5]] <- mstmipvar("TotalResp", lat, lon, t, NA) - nc_var[[6]] <- mstmipvar("AutoResp", lat, lon, t, NA) - nc_var[[7]] <- mstmipvar("HeteroResp", lat, lon, t, NA) + nc_var[[3]] <- PEcAn.utils::to_ncvar("GPP", dims) + nc_var[[4]] <- PEcAn.utils::to_ncvar("NPP", dims) + nc_var[[5]] <- PEcAn.utils::to_ncvar("TotalResp", dims) + nc_var[[6]] <- PEcAn.utils::to_ncvar("AutoResp", dims) + nc_var[[7]] <- PEcAn.utils::to_ncvar("HeteroResp", dims) nc_var[[8]] <- ncdf4::ncvar_def("SoilResp", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, - longname = "Soil Respiration") - nc_var[[9]] <- mstmipvar("NEE", lat, lon, t, NA) + longname = "Soil Respiration") #need to figure out standard variable for this output + nc_var[[9]] <- PEcAn.utils::to_ncvar("NEE", dims) # nc_var[[9]] <- mstmipvar('CarbPools', lat, lon, t, NA) - nc_var[[10]] <- mstmipvar("AbvGrndWood", lat, lon, t, NA) - nc_var[[11]] <- mstmipvar("LeafC", lat, lon, t, NA) - nc_var[[12]] <- mstmipvar("TotLivBiom", lat, lon, t, NA) - nc_var[[13]] <- mstmipvar("TotSoilCarb", lat, lon, t, NA) - nc_var[[14]] <- mstmipvar("Qle", lat, lon, t, NA) - nc_var[[15]] <- mstmipvar("TVeg", lat, lon, t, NA) - nc_var[[16]] <- mstmipvar("SoilMoist", lat, lon, t, NA) - nc_var[[17]] <- mstmipvar("SoilMoistFrac", lat, lon, t, NA) - nc_var[[18]] <- mstmipvar("SWE", lat, lon, t, NA) - nc_var[[19]] <- mstmipvar("Litter", lat, lon, t, NA) - nc_var[[20]] <- to_ncvar("LAI", dims) + nc_var[[10]] <- PEcAn.utils::to_ncvar("AbvGrndWood", dims) + nc_var[[11]] <- PEcAn.utils::to_ncvar("leaf_carbon_content", dims) + nc_var[[12]] <- PEcAn.utils::to_ncvar("TotLivBiom", dims) + nc_var[[13]] <- PEcAn.utils::to_ncvar("TotSoilCarb", dims) + nc_var[[14]] <- PEcAn.utils::to_ncvar("Qle", dims) + nc_var[[15]] <- PEcAn.utils::to_ncvar("Transp", dims) + nc_var[[16]] <- PEcAn.utils::to_ncvar("SoilMoist", dims) + nc_var[[17]] <- PEcAn.utils::to_ncvar("SoilMoistFrac", dims) + nc_var[[18]] <- PEcAn.utils::to_ncvar("SWE", dims) + nc_var[[19]] <- PEcAn.utils::to_ncvar("litter_carbon_content", dims) + nc_var[[20]] <- PEcAn.utils::to_ncvar("LAI", dims) # ******************** Declare netCDF variables ********************# From af987167d17b1d8be82a603ed957f7e6d2797d75 Mon Sep 17 00:00:00 2001 From: annethomas Date: Tue, 29 Aug 2017 17:49:40 -0400 Subject: [PATCH 483/771] Stray rPython:: in call_modis --- modules/data.remote/R/call_MODIS.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/R/call_MODIS.R b/modules/data.remote/R/call_MODIS.R index 8a73f9beef6..8cd9de904c4 100644 --- a/modules/data.remote/R/call_MODIS.R +++ b/modules/data.remote/R/call_MODIS.R @@ -76,7 +76,7 @@ call_MODIS <- function(outfolder = ".", fname = "m_data.nc", start, end, lat, lo rPython::python.assign("band", band) rPython::python.assign("qcband", qc_band) rPython::python.assign("sdband", sd_band) - python.assign("debug", verbose) + rPython::python.assign("debug", verbose) # Here we import the MODIS python script as a module for the python. That way we can # run the routines within the script as independent commands. From bccb6394fa13d6e26b5bca09e393d7ee2d4fd87a Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Wed, 30 Aug 2017 12:33:35 -0400 Subject: [PATCH 484/771] changing output --- models/ed/R/model2netcdf.ED2.R | 9 ++++----- models/fates/R/model2netcdf.FATES.R | 1 - 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/models/ed/R/model2netcdf.ED2.R b/models/ed/R/model2netcdf.ED2.R index 4a3c097da90..94a9e7f7118 100644 --- a/models/ed/R/model2netcdf.ED2.R +++ b/models/ed/R/model2netcdf.ED2.R @@ -17,7 +17,6 @@ ##' @param sitelon Longitude of the site ##' @param start_date Start time of the simulation ##' @param end_date End time of the simulation -##' @importFrom ncdf4 ncdim_def ncatt_get ncvar_add ##' @export ##' ##' @author Michael Dietze, Shawn Serbin, Rob Kooper, Toni Viskari, Istem Fer @@ -517,12 +516,12 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { end <- (as.numeric(strftime(paste0(yrs[y], "-12-31"), "%j"))) * block - 1 } - t <- ncdim_def(name = "time", units = paste0("days since ", yrs[y], "-01-01 00:00:00"), vals = start:end/block, + t <- ncdf4::ncdim_def(name = "time", units = paste0("days since ", yrs[y], "-01-01 00:00:00"), vals = start:end/block, calendar = "standard", unlim = TRUE) - lat <- ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") - lon <- ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") + lat <- ncdf4::ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") + lon <- ncdf4::ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") - zg <- ncdim_def("SoilLayerMidpoint", "meters", c(slzdata[1:length(dz)] + dz/2, 0)) + zg <- ncdf4::ncdim_def("SoilLayerMidpoint", "meters", c(slzdata[1:length(dz)] + dz/2, 0)) ## Conversion factor for umol C -> kg C Mc <- 12.017 #molar mass of C, g/mol diff --git a/models/fates/R/model2netcdf.FATES.R b/models/fates/R/model2netcdf.FATES.R index 79ec21391de..09fb319ee2b 100644 --- a/models/fates/R/model2netcdf.FATES.R +++ b/models/fates/R/model2netcdf.FATES.R @@ -21,7 +21,6 @@ ##' @export ##' ##' @author Michael Dietze, Shawn Serbin -##' @importFrom ncdf4 ncdim_def ncvar_def ncatt_get ncvar_add model2netcdf.FATES <- function(outdir) { # var_update("AR","AutoResp","kgC m-2 s-1") From ff34c99bd081eff4aa35483966f7e2ad363cf184 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Wed, 30 Aug 2017 14:12:43 -0400 Subject: [PATCH 485/771] changes to fates reference build script --- models/fates/inst/create_1x1_ref_case.sh | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/models/fates/inst/create_1x1_ref_case.sh b/models/fates/inst/create_1x1_ref_case.sh index c4499a6494d..53c36f76740 100644 --- a/models/fates/inst/create_1x1_ref_case.sh +++ b/models/fates/inst/create_1x1_ref_case.sh @@ -18,15 +18,20 @@ # site_lat_c = 9.1543, 5.07389, -2.60909722, 1.4368, 4.1865, 15.6324 # site_lon_c = 280.1539, 8.85472, 299.7907, 28.5826, 114.017, 99.217 #============================================================================================= -#export NETCDF_HOME=/usr/local/ # is this nescessary? +export NETCDF_HOME=/usr/local/ #necessary +export NETCDF_PATH=${NETCDF_HOME} #necessary + +CIME_MODEL=cesm + MACH=eddi COMP=ICLM45ED GITHASH=`git log -n 1 --format=%h` CASE=ref1x1_${GITHASH} -CROOT=/home/carya/FATES_refrun/ +CROOT=/home/carya/FATES_refrun/ # Define path where run will be written to + +DIN_LOC_ROOT=/home/carya/FATESinput/ # Defiune path to input data -DIN_LOC_ROOT=/home/carya/FATESinput/ DOMAIN_PATH=${DIN_LOC_ROOT}/share/domains/ WORKDIR=`pwd` @@ -52,7 +57,7 @@ echo "*** Modifying xmls ***" ./xmlchange -file env_mach_pes.xml -id MAX_TASKS_PER_NODE -val 1 ./xmlchange -file env_mach_pes.xml -id TOTALPES -val 1 # Modifying : env_build.xml -./xmlchange -file env_build.xml -id CIME_OUTPUT_ROOT -val ${CASEROOT} +./xmlchange -file env_build.xml -id CESMSCRATCHROOT -val ${CASEROOT} ./xmlchange -file env_build.xml -id GMAKE -val make #./xmlchange -file env_build.xml -id MPILIB -val openmpi #./xmlchange -file env_build.xml -id OS -val Linux @@ -102,7 +107,7 @@ echo "*** Running case.setup ***" cat >> user_nl_clm << \EOF hist_empty_htapes = .true. -hist_fincl1='EFLX_LH_TOT','TSOI_10CM','QVEGT','NEP','GPP','AR','ED_bleaf','ED_biomass','NPP_column’,'NPP','MAINT_RESP','GROWTH_RESP' +hist_fincl1='EFLX_LH_TOT','TSOI_10CM','QVEGT','NEP','GPP','AR','ED_bleaf','ED_biomass','NPP_column','NPP','MAINT_RESP','GROWTH_RESP' hist_mfilt = 8760 hist_nhtfrq = -1 EOF From 5782676fcb02d0adc1264eafd1af72f50240e0d2 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Wed, 30 Aug 2017 14:33:10 -0400 Subject: [PATCH 486/771] get rid of comment --- models/fates/inst/create_1x1_ref_case.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/fates/inst/create_1x1_ref_case.sh b/models/fates/inst/create_1x1_ref_case.sh index 53c36f76740..980e5787266 100644 --- a/models/fates/inst/create_1x1_ref_case.sh +++ b/models/fates/inst/create_1x1_ref_case.sh @@ -18,8 +18,8 @@ # site_lat_c = 9.1543, 5.07389, -2.60909722, 1.4368, 4.1865, 15.6324 # site_lon_c = 280.1539, 8.85472, 299.7907, 28.5826, 114.017, 99.217 #============================================================================================= -export NETCDF_HOME=/usr/local/ #necessary -export NETCDF_PATH=${NETCDF_HOME} #necessary +export NETCDF_HOME=/usr/local/ +export NETCDF_PATH=${NETCDF_HOME} CIME_MODEL=cesm From 485ae89d23bc58c83cd7980735494536a2281c1f Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Wed, 30 Aug 2017 14:36:36 -0400 Subject: [PATCH 487/771] edit changelog --- CHANGELOG.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 556482aa396..1b95356f7b1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,6 +15,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Fixed bug (order of dims in nc_create) introduced in model2netcdf.DALEC by standard_vars changes - Cleaned up NAMESPACE and source code of `PEcAn.DB` (#1520) - Debugged python script in call_MODIS in data.remote to allow MODIS downloads +- Fixed FATES build script to work on ubuntu ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) @@ -34,7 +35,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha * Move `logger.*` functions out of the `PEcAn.utils` package and into the `pecan.logger` package - #1594 shiny/workflowPlot Refactoring of code. `get_workflow_ids` in db/R/query.dplyr.R changed with `ensemble = FALSE`. Also allowing to load all workflow IDs. `load_data_single_run` and `var_names_all` also moved from shiny/workflowPlot/server.R to query.dplyr.R -## [1.5.10] - Prerelease +## [1.5.0] - 2017-07-13 ### Added - Added PEcAn.utils::download.file() to allow for use of alternative FTP programs - Updated downloadAmeriflux and downloadNARR to make use of PEcAn.utils::download.file() From e22041b57c1098d8600c9c5e1efe8dce8b61b69a Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Wed, 30 Aug 2017 14:56:23 -0400 Subject: [PATCH 488/771] fixes to build script --- models/fates/inst/create_1x1_ref_case.sh | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/models/fates/inst/create_1x1_ref_case.sh b/models/fates/inst/create_1x1_ref_case.sh index 980e5787266..0b62bee0441 100644 --- a/models/fates/inst/create_1x1_ref_case.sh +++ b/models/fates/inst/create_1x1_ref_case.sh @@ -18,6 +18,8 @@ # site_lat_c = 9.1543, 5.07389, -2.60909722, 1.4368, 4.1865, 15.6324 # site_lon_c = 280.1539, 8.85472, 299.7907, 28.5826, 114.017, 99.217 #============================================================================================= + +#Optional netcdf explicit settings export NETCDF_HOME=/usr/local/ export NETCDF_PATH=${NETCDF_HOME} @@ -57,6 +59,7 @@ echo "*** Modifying xmls ***" ./xmlchange -file env_mach_pes.xml -id MAX_TASKS_PER_NODE -val 1 ./xmlchange -file env_mach_pes.xml -id TOTALPES -val 1 # Modifying : env_build.xml +#Updated variable of CESMSCRATCHROOT?#./xmlchange -file env_build.xml -id CIME_OUTPUT_ROOT -val ${CASEROOT} ./xmlchange -file env_build.xml -id CESMSCRATCHROOT -val ${CASEROOT} ./xmlchange -file env_build.xml -id GMAKE -val make #./xmlchange -file env_build.xml -id MPILIB -val openmpi @@ -107,7 +110,7 @@ echo "*** Running case.setup ***" cat >> user_nl_clm << \EOF hist_empty_htapes = .true. -hist_fincl1='EFLX_LH_TOT','TSOI_10CM','QVEGT','NEP','GPP','AR','ED_bleaf','ED_biomass','NPP_column','NPP','MAINT_RESP','GROWTH_RESP' +hist_fincl1='EFLX_LH_TOT','TSOI_10CM','QVEGT','GPP','AR','ED_bleaf','ED_biomass','NPP','MAINT_RESP','GROWTH_RESP' hist_mfilt = 8760 hist_nhtfrq = -1 EOF From e9740f701a586907ea8c18163f61333d3ed90c50 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Wed, 30 Aug 2017 15:13:11 -0400 Subject: [PATCH 489/771] switch cime output variable --- models/fates/inst/create_1x1_ref_case.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/fates/inst/create_1x1_ref_case.sh b/models/fates/inst/create_1x1_ref_case.sh index 0b62bee0441..16b2d412baf 100644 --- a/models/fates/inst/create_1x1_ref_case.sh +++ b/models/fates/inst/create_1x1_ref_case.sh @@ -59,8 +59,8 @@ echo "*** Modifying xmls ***" ./xmlchange -file env_mach_pes.xml -id MAX_TASKS_PER_NODE -val 1 ./xmlchange -file env_mach_pes.xml -id TOTALPES -val 1 # Modifying : env_build.xml -#Updated variable of CESMSCRATCHROOT?#./xmlchange -file env_build.xml -id CIME_OUTPUT_ROOT -val ${CASEROOT} -./xmlchange -file env_build.xml -id CESMSCRATCHROOT -val ${CASEROOT} +./xmlchange -file env_build.xml -id CIME_OUTPUT_ROOT -val ${CASEROOT} +#Outdated Var ./xmlchange -file env_build.xml -id CESMSCRATCHROOT -val ${CASEROOT} ./xmlchange -file env_build.xml -id GMAKE -val make #./xmlchange -file env_build.xml -id MPILIB -val openmpi #./xmlchange -file env_build.xml -id OS -val Linux From 4d7ab4c3b968c1dcdbc286225bcb10eab7ce7967 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Wed, 30 Aug 2017 15:35:24 -0400 Subject: [PATCH 490/771] delete scratchroot var --- models/fates/inst/create_1x1_ref_case.sh | 1 - 1 file changed, 1 deletion(-) diff --git a/models/fates/inst/create_1x1_ref_case.sh b/models/fates/inst/create_1x1_ref_case.sh index 16b2d412baf..3a9b36719b2 100644 --- a/models/fates/inst/create_1x1_ref_case.sh +++ b/models/fates/inst/create_1x1_ref_case.sh @@ -60,7 +60,6 @@ echo "*** Modifying xmls ***" ./xmlchange -file env_mach_pes.xml -id TOTALPES -val 1 # Modifying : env_build.xml ./xmlchange -file env_build.xml -id CIME_OUTPUT_ROOT -val ${CASEROOT} -#Outdated Var ./xmlchange -file env_build.xml -id CESMSCRATCHROOT -val ${CASEROOT} ./xmlchange -file env_build.xml -id GMAKE -val make #./xmlchange -file env_build.xml -id MPILIB -val openmpi #./xmlchange -file env_build.xml -id OS -val Linux From f9c425de8ec3367c234df0a0da617eb014102b4e Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Thu, 17 Aug 2017 16:30:55 -0500 Subject: [PATCH 491/771] Code outline for aligning met data Outline code for aligning training & to-be-downscaled met data so that it can be plugged into the downscaling workflow --- modules/data.atmosphere/R/align_met.R | 40 +++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 modules/data.atmosphere/R/align_met.R diff --git a/modules/data.atmosphere/R/align_met.R b/modules/data.atmosphere/R/align_met.R new file mode 100644 index 00000000000..8f263c24862 --- /dev/null +++ b/modules/data.atmosphere/R/align_met.R @@ -0,0 +1,40 @@ +##' Align meteorology datasets for debiasing +# ----------------------------------- +# Description +# ----------------------------------- +##' +##' @title align.met +##' @family debias - Debias & Align Meteorology Datasets into continuous time series +##' @author Christy Rollinson +##' @description This script aligns meteorology datasets in at temporal resolution for debiasing & +##' temporal downscaling. +##' Note: The output here is stored in memory! +##' Note: can probably at borrow from or adapt align_data.R in Benchmarking module, but +##' it's too much of a black box at the moment. +# ----------------------------------- +# Parameters +# ----------------------------------- +##' @param train.path - path to the dataset to be used to downscale the data +##' @param source.path - data to be bias-corrected aligned with training data (from align.met) +##' @param pair.mems - logical stating whether ensemble members should be paired +##' @param n.ens - number of ensemble members to generate and save +##' @param verbose +##' @export +# ----------------------------------- +# Workflow +# ----------------------------------- +# 1. Determine if training data is a single series or ensemble +# - note: assumes training data is at the temporal resolution you want to work with +# 2. If not already, coerce training data into the size of the desired output ensemble +# 3. Aggregate or coerce source data into temporal resolution of training data +# - note: source data should remain a single time series +# 4. export data (stored in memory) for input into the debiasing or temporal downscaling workflow +# ----------------------------------- + +#---------------------------------------------------------------------- +# Begin Function +#---------------------------------------------------------------------- +align.met <- function(train.path, source.path, pair.mems = TRUE, verbose = FALSE) { + # +} + \ No newline at end of file From ee0f968417bfb36e538342978983c235346d82be Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 22 Aug 2017 12:12:09 -0500 Subject: [PATCH 492/771] Initial De-biasing scripts MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Translation of PalEON debiasing (spatial downscaling & bias-correction) workflow into scripts that can be used throughout Pecan! align.met function takes a training dataset and makes the dataset to be downscaled on the same temporal resolution. This *should* work for both this bias correction step & the temporal downscaling. debias.met.regression is a beast of a function that does the bias correction and attempts to take into account the covariance among parameters by doing variables in a specific order and then adding predictors/complexity as we go along. There are special cases for if we’re working with two empirical(-ish) datasets where we can pair the anomalies as well as some additional flags for CRUNCEP. There are some improvements that can/will be made (e.g. possibly transforming zero-truncated variables when used as predictors & not just responses), but this is what I have so far. --- modules/data.atmosphere/R/align_met.R | 198 ++++- .../data.atmosphere/R/debias_met_regression.R | 742 ++++++++++++++++++ 2 files changed, 931 insertions(+), 9 deletions(-) create mode 100644 modules/data.atmosphere/R/debias_met_regression.R diff --git a/modules/data.atmosphere/R/align_met.R b/modules/data.atmosphere/R/align_met.R index 8f263c24862..6cb98eea82f 100644 --- a/modules/data.atmosphere/R/align_met.R +++ b/modules/data.atmosphere/R/align_met.R @@ -16,25 +16,205 @@ # ----------------------------------- ##' @param train.path - path to the dataset to be used to downscale the data ##' @param source.path - data to be bias-corrected aligned with training data (from align.met) -##' @param pair.mems - logical stating whether ensemble members should be paired +##' @param yrs.train - (optional) specify a specific years to be loaded for the training data; +##' prevents needing to load the entire dataset. If NULL, all available years +##' will be loaded. If not null, should be a vector of numbers (so you can skip +##' problematic years) ##' @param n.ens - number of ensemble members to generate and save +##' @param pair.mems - logical stating whether ensemble members should be paired +##' @param seed - specify seed so that random draws can be reproduced ##' @param verbose ##' @export # ----------------------------------- # Workflow # ----------------------------------- -# 1. Determine if training data is a single series or ensemble -# - note: assumes training data is at the temporal resolution you want to work with -# 2. If not already, coerce training data into the size of the desired output ensemble -# 3. Aggregate or coerce source data into temporal resolution of training data -# - note: source data should remain a single time series -# 4. export data (stored in memory) for input into the debiasing or temporal downscaling workflow +# 1. Read in & format the training data +# 1.1. Determine if training data is a single series or ensemble +# - note: assumes training data is at the temporal resolution you want to work with +# 1.2. If not already, coerce training data into the size of the desired output ensemble +# 2. Read in & format the source data to match the temporal resolution of training data +# - Note: for now this is only going to work with a single time series & not an ensemble of source data +# - Note: end dimensions should match that of the training data +# 3. export data (stored in memory) for input into the debiasing or temporal downscaling workflow +# +# Returns a list called met.out with 2 levels that are matched in temporal resolution & number of ensembles +# List Layers +# 1. dat.train +# 2. dat.source +# Sublist Layers: time, met variables +# ----------------------------------- +# Notes +# ----------------------------------- +# 1. This assumes that both the trian and source data are in *at least* daily resolution # ----------------------------------- #---------------------------------------------------------------------- # Begin Function #---------------------------------------------------------------------- -align.met <- function(train.path, source.path, pair.mems = TRUE, verbose = FALSE) { - # +align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=1, pair.mems = TRUE, seed=Sys.Date(), verbose = FALSE) { + # Load required libraries + library(ncdf4) + library(lubridate) + + met.out <- list() # where the aligned data will be stored + + # --------------- + # 1. Read in & organize training data + # --------------- + met.out[["dat.train"]] <- list() + # 1.a. Determine if we have an ensemble in the training path or if it's a single time series + if(length(dir(train.path, ".nc"))>0){ # we have a single time series + n.trn = 1 # Ignore how many input ensemble members we asked for, we only actually have 1 here + + files.train <- dir(train.path, ".nc") + + yrs.file <- strsplit(files.train, "[.]") + yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) + yrs.file <- as.numeric(yrs.file[,2]) + + if(!is.null(yrs.train)){ + files.train <- files.train[which(yrs.file %in% yrs.train)] + yrs.file <- yrs.file[which(yrs.file %in% yrs.train)] + } + + # Loop through the .nc files putting everything into a list + print("Processing Training Data") + pb <- txtProgressBar(min=0, max=length(files.train), style=3) + for(i in 1:length(files.train)){ + yr.now <- yrs.file[i] + + ncT <- nc_open(file.path(train.path, files.train[i])) + + # Set up the time data frame to help index + nday <- ifelse(leap_year(yr.now), 366, 365) + ntime <- length(ncT$dim$time$vals) + step.day <- nday/ntime + step.hr <- step.day*24 + stamps.hr <- seq(step.hr/2, by=step.hr, length.out=1/step.day) # Time stamps centered on period + + # Create a data frame with all the important time info + # center the hour step + df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/step.day), Hour=rep(stamps.hr, ntime)) + df.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") + met.out$dat.train[["time"]] <- rbind(met.out$dat.train$time, df.time) + + # Extract the met info, making matrices with the appropriate number of ensemble members + for(v in names(ncT$var)){ + df.tem <- matrix(rep(ncvar_get(ncT, v), n.trn), ncol=n.trn, byrow=F) + + met.out$dat.train[[v]] <- rbind(met.out$dat.train[[v]], df.tem) + } + + nc_close(ncT) + + setTxtProgressBar(pb, i) + } # End looping through training data files + } else { # we have an ensemble we need to deal with + stop("Training ensemble mode not implemented yet!") + } # End loading & formatting training data + print(" ") + # --------------- + + # --------------- + # Read in & format the source data + # --------------- + met.out[["dat.source"]] <- list() + if(length(dir(source.path, ".nc"))>0){ # we have a single time series + n.src = 1 # we only have 1 time series so + + # Get a list of the files we'll be downscaling + files.source <- dir(source.path, ".nc") + + # create a vector of the years + yrs.file <- strsplit(files.source, "[.]") + yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) + yrs.file <- as.numeric(yrs.file[,2]) + + # Getting the day & hour timesteps from the training data + day.train <- round(365/length(unique(met.out$dat.train$time$DOY))) + hr.train <- 24/length(unique(met.out$dat.train$time$Hour)) + + # Loop through the .nc files putting everything into a list + print("Processing Source Data") + pb <- txtProgressBar(min=0, max=length(files.train), style=3) + for(i in 1:length(files.source)){ + yr.now <- yrs.file[i] + + ncT <- nc_open(file.path(source.path, files.source[i])) + + # Set up the time data frame to help index + nday <- ifelse(leap_year(yr.now), 366, 365) + ntime <- length(ncT$dim$time$vals) + step.day <- nday/ntime + step.hr <- step.day*24 + + # ----- + # Making time stamps to match the training data + # For coarser time step than the training data, we'll duplicate in the loop + # ----- + # Making what the unique time stamps should be to match the training data + stamps.hr <- seq(hr.train/2, by=hr.train, length.out=1/day.train) + + if(step.hr < hr.train){ # Finer hour increment --> set it up to aggregate + align = "aggregate" + stamps.src <- rep(stamps.hr, each=24/step.hr) + } else if(step.hr > hr.train) { # Set the flag to duplicate the data + align = "repeat" + } else { # things are aligned, so we're fine + align = "aligned" + } + # ----- + + # Create a data frame with all the important time info + # center the hour step + df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/day.train), Hour=rep(stamps.hr, length.out=nday/day.train)) + df.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") + met.out$dat.source[["time"]] <- rbind(met.out$dat.source$time, df.time) + + src.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/step.day), Hour=rep(stamps.src, length.out=ntime)) + src.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") + + # Extract the met info, making matrices with the appropriate number of ensemble members + for(v in names(ncT$var)){ + dat.tem <- ncvar_get(ncT, v) + + if(align=="repeat"){ # if we need to coerce the time step to be repeated to match temporal resolution, do it here + dat.tem <- rep(dat.temp, each=stamps.hr) + } + df.tem <- matrix(rep(dat.tem, n.src), ncol=n.src, byrow=F) + + # If we need to aggregate the data to align it, do it now to save memory + if(align == "aggregate"){ + df.tem <- cbind(src.time, data.frame(df.tem)) + + df.agg <- aggregate(df.tem[,(4+1:n.src)], by=df.tem[,c("Year", "DOY", "Hour")], FUN=mean) + met.out$dat.source[[v]] <- rbind(met.out$dat.source[[v]], as.matrix(df.agg[,(3+1:n.src)])) + + # if workign wiht air temp, also find the max & min + if(v=="air_temperature"){ + tmin <- aggregate(df.tem[,(4+1:n.src)], by=df.tem[,c("Year", "DOY", "Hour")], FUN=min) + tmax <- aggregate(df.tem[,(4+1:n.src)], by=df.tem[,c("Year", "DOY", "Hour")], FUN=max) + + met.out$dat.source[["air_temperature_minimum"]] <- rbind(met.out$dat.source[["air_temperature_minimum"]], as.matrix(tmin[,(3+1:n.src)])) + met.out$dat.source[["air_temperature_maximum"]] <- rbind(met.out$dat.source[["air_temperature_maximum"]], as.matrix(tmax[,(3+1:n.src)])) + } + } + + # If met doesn't need to be aggregated, just copy it in + if(align %in% c("repeat", "align")) { + met.out$dat.source[[v]] <- rbind(met.out$dat.source[[v]], as.matrix(df.tem, ncol=n.src)) + } + } + nc_close(ncT) + setTxtProgressBar(pb, i) + } # End looping through source met files + print("") + } else { # we have an ensemble we need to deal with + stop("Source ensemble mode not implemented yet!") + } # End loading & formatting training data + # --------------- + + + return(met.out) } \ No newline at end of file diff --git a/modules/data.atmosphere/R/debias_met_regression.R b/modules/data.atmosphere/R/debias_met_regression.R new file mode 100644 index 00000000000..c696ed93ea7 --- /dev/null +++ b/modules/data.atmosphere/R/debias_met_regression.R @@ -0,0 +1,742 @@ +##' Debias Meteorology using Multiple Linear Regression +##' Statistically debias met datasets and generate ensembles based on the observed uncertainty +# ----------------------------------- +# Description +# ----------------------------------- +##' +##' @title debias.met.regression +##' @family debias - Debias & Align Meteorology Datasets into continuous time series +##' @author Christy Rollinson +##' @description This script debiases one dataset (e.g. GCM, re-analysis product) given another higher +##' resolution product or empirical observations. It assumes input are in annual CF standard +##' files that are generate from the pecan extract or download funcitons. +# ----------------------------------- +# Parameters +# ----------------------------------- +##' @param train.data - training data coming out of align.met +##' @param source.data - data to be bias-corrected aligned with training data (from align.met) +##' @param n.ens - number of ensemble members to generate and save for EACH source ensemble member +##' @param vars.debias - which met variables should be debiased? if NULL, all variables in train.data +##' @param CRUNCEP - flag for if the dataset being downscaled is CRUNCEP; if TRUE, special cases triggered for +##' met variables that have been naively gapfilled for certain time periods +##' @param pair.anoms - logical stating whether anomalies from the same year should be matched or not +##' @param pair.ens - logical stating whether ensembles from train and source data need to be paired together +##' (for uncertainty propogation) +##' @param uncert.prop - method for error propogation if only 1 ensemble member; options=c(random, mean); *Not Implemented yet +##' @param resids - logical stating whether to pass on residual data or not *Not implemented yet +##' @param seed - specify seed so that random draws can be reproduced +##' @param outfolder - directory where the data should go +##' @param yrs.save - what years from the source data should be saved; if NULL all years of the source data will be saved +##' @param ens.name - what is the name that should be attached to the debiased ensemble +##' @param ens.mems - what labels/numbers to attach to the ensemble members so we can gradually build bigger ensembles +##' without having to do do giant runs at once; if NULL will be numbered 1:n.ens +##' @param lat.in - latitude of site +##' @param lon.in - longitude of site +##' @param save.diagnostics - logical; save diagnostic plots of output? +##' @param path.diagnostics - path to where the diagnostic graphs should be saved +##' @param parallel - (experimental) logical stating whether to run temporal_downscale_functions.R in parallel *Not Implemented yet +##' @param n.cores - (experimental) how many cores to use in parallelization *Not implemented yet +##' @param overwrite - overwrite existing files? +##' @param verbose +##' @export +# ----------------------------------- +# Workflow +# ----------------------------------- +# The general workflow is as follows: +# 1. read in & format data (coerce to daily format) +# 2. set up the file structures for the output +# 3. define the training window +# 4. generate the bias-correction models to adjust the seasonal cycle +# 5. Model the anomalies +# 5. apply the climatology & anomaly models with covariance to generate a daily ensemble +# 6. Save specified years to file +# ----------------------------------- + +#---------------------------------------------------------------------- +# Begin Function +#---------------------------------------------------------------------- + + +debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NULL, CRUNCEP=FALSE, + pair.anoms = TRUE, pair.ens = FALSE, uncert.prop="mean", resids = FALSE, seed=Sys.Date(), + outfolder, yrs.save=NULL, ens.name, ens.mems=NULL, lat.in, lon.in, + save.diagnostics=TRUE, path.diagnostics=NULL, + parallel = FALSE, n.cores = NULL, overwrite = TRUE, verbose = FALSE) { + library(MASS) + library(mgcv) + library(ggplot2) + library(stringr) + library(lubridate) + library(ncdf4) + + set.seed(seed) + + if(parallel==TRUE) warning("Warning! Parallel processing not reccomended because of memory constraints") + if(ncol(source.data[[2]])>1) warning("Feeding an ensemble of source data is currently experimental! This could crash") + + # Variables need to be done in a specific order + vars.all <- c("air_temperature", "air_temperature_minimum", "air_temperature_maximum", "specific_humidity", "surface_downwelling_shortwave_flux_in_air", "air_pressure", "surface_downwelling_longwave_flux_in_air", "wind_speed", "precipitation_flux") + + if(is.null(vars.debias)) vars.debias <- vars.all[vars.all %in% names(train.data)] # Don't try to do vars that we don't have + if(is.null(yrs.save)) yrs.save <- unique(source.data$time$Year) + if(is.null(ens.mems)) ens.mems <- str_pad(1:n.ens, nchar(n.ens), "left", pad="0") + + # Set up outputs + vars.pred <- vector() + dat.out <- list() + dat.out[["time"]] <- source.data$time + + # Transforming zero-truncated variables where negative values are not possible (and zero is unlikely) + # - Tried a couple different things, but the sqaure root transformation seems to be working best + vars.transform <- c("surface_downwelling_shortwave_flux_in_air", "specific_humidity", "surface_downwelling_longwave_flux_in_air", "wind_speed") + + # --------- + # Setting up some cases about how to duplicate the training data in case we don't pass through the + # same number of ensembles as we want in our output + # - Referencing off of whatever the layer after "time" is + # --------- + # If we have fewer columns then we need, randomly duplicate some + if(ncol(train.data[[2]]) < n.ens){ + ens.train <- c(1:ncol(train.data[[2]]), sample(1:ncol(train.data[[2]]), n.ens-ncol(train.data[[2]]),replace=T)) + } + + # If we have more columns than we need, randomly subset + if(ncol(train.data[[2]]) > n.ens) { + ens.train <- sample(1:ncol(train.data[[2]]), ncol(train.data[[2]]),replace=T) + } + + # Setting up cases for dealing with an ensemble of source data to be biased + if(pair.ens==T & ncol(train.data[[2]]!=ncol(source.data[[2]]))){ + stop("Cannot pair ensembles of different size") + } else if(pair.ens==T) { + ens.src <- ens.train + } + + if(pair.ens==F & ncol(source.data[[2]])==1 ){ + ens.src=1 + } else if(pair.ens==F & ncol(source.data[[2]]) > n.ens) { + ens.src <- sample(1:ncol(source.data[[2]]), ncol(source.data[[2]]),replace=T) + } else if(pair.ens==F & ncol(source.data[[2]]) < n.ens){ + ens.src <- c(1:ncol(source.data[[2]]), sample(1:ncol(source.data[[2]]), n.ens-ncol(source.data[[2]]),replace=T)) + } + # --------- + + # Find the period of years to use to train the model + # This formulation should take + yrs.overlap <- unique(train.data$time$Year)[unique(train.data$time$Year) %in% unique(source.data$time$Year)] + + # If we don't have a year of overlap, take closest 20 years from each dataset + if(length(yrs.overlap)<1){ + yrs.overlap <- (max(min(train.data$time$Year), min(source.data$time$Year))-20):(min(max(train.data$time$Year), max(source.data$time$Year))+20) + pair.anoms=FALSE # we can't pair the anomalies no matter what we tried to specify before + } + + # Cut out training data down to just the calibration period + for(v in vars.debias){ + train.data[[v]] <- matrix(train.data[[v]][which(train.data$time$Year %in% yrs.overlap),], ncol=ncol(train.data[[v]])) + } + train.data$time <- train.data$time[which(train.data$time$Year %in% yrs.overlap),] + + + # ------------------------------------------- + # Loop through the variables + # ------------------------------------------- + print("") + print("Debiasing Meteorology") + pb <- txtProgressBar(min=0, max=length(vars.debias)*n.ens, style=3) + pb.ind=1 + for(v in vars.debias){ + # ------------- + # If we're dealing with precip, lets keep the training data handy & + # calculate the number of rainless time periods (days) in each year to + # make sure we don't get a constant drizzle + # ------------- + if(v=="precipitation_flux"){ + # rain.train <- met.bias[met.bias$dataset==dat.train.orig,] + rainless <- vector() + for(y in min(train.data$time$Year):max(train.data$time$Year)){ + for(i in 1:ncol(train.data$precipitation_flux)){ + rainless <- c(rainless, length(which(train.data$time$Year==y & train.data$precipitation_flux[,i]==0))) + } + } + + # Hard-coding in some sort of max for precipitaiton + rain.max <- max(train.data$precipitation_flux)*1.5 + } + # ------------- + + # ------------- + # Set up the datasets for training and prediction + # ------------- + # ----- + # 1. Grab the training data -- this will be called "Y" in our bias correction equations + # -- preserving the different simulations so we can look at a distribution of potential values + # -- This will get aggregated right off the bat so we so we're looking at the climatic means + # for the first part of bias-correction + # ----- + met.train <- data.frame(year=train.data$time$Year, + doy=train.data$time$DOY, + Y=stack(data.frame(train.data[[v]][,ens.train]))[,1], + ind=rep(paste0("X", 1:n.ens), each=nrow(train.data[[v]])) + ) + + # For precip, we want to adjust the total annual precipitation, and then calculate day of year + # adjustment & anomaly as fraction of total annual precipitation + if(v == "precipitation_flux"){ + # Find total annual preciptiation + precip.ann <- aggregate(met.train$Y, by=met.train[,c("year", "ind")], FUN=sum) + names(precip.ann)[3] <- "Y.tot" + + met.train <- merge(met.train, precip.ann, all=T) + met.train$Y <- met.train$Y/met.train$Y.tot # Y is now fraction of annual precip in each timestep + } + + # Aggregate to get rid of years so that we can compare climatic means + dat.clim <- aggregate(met.train$Y, by=met.train[,c("doy", "ind")], FUN=mean) + names(dat.clim)[3] <- "Y" + # ----- + + # ----- + # 2. Pull the raw ("source") data that needs to be bias-corrected -- this will be called "X" + # -- this gets aggregated to the climatological mean right off the bat + # ----- + met.src <- data.frame(year=source.data$time$Year, + doy=source.data$time$DOY, + X=stack(data.frame(source.data[[v]][,ens.src]))[,1], + ind.src=rep(paste0("X", 1:length(ens.src)), each=nrow(source.data[[v]])) + ) + + if(v=="precipitation_flux"){ + src.ann <- aggregate(met.src$X, by=met.src[,c("year", "ind.src")], FUN=sum) + names(src.ann)[3] <- "X.tot" + + met.src <- merge(met.src, src.ann, all.x=T) + + # Putting precip as fraction of the year again + met.src$X <- met.src$X/met.src$X.tot + + } + + # Aggregate to get rid of years so that we can compare climatic means + clim.src <- aggregate(met.src[met.src$year %in% yrs.overlap,"X"], + by=met.src[met.src$year %in% yrs.overlap,c("doy", "ind.src")], + FUN=mean) + names(clim.src)[3] <- "X" + # ----- + + # ----- + # 3. Merge the training & cource climate data together the two sets of daily means + # -- this ends up pairing each daily climatological mean of the raw data with each simulation from the training data + # ----- + dat.clim <- merge(dat.clim[,], clim.src, all=T) + + if(v=="precipitation_flux"){ + if(pair.anoms==F){ + dat.ann <- precip.ann + dat.ann$X.tot <- src.ann[src.ann$year %in% yrs.overlap,"X.tot"] + } else { + dat.ann <- merge(precip.ann, src.ann[src.ann$year %in% yrs.overlap,], all=T) + } + } + # ----- + + # ----- + # 4. Pulling the source and training data to model the anomalies + # - this includes pulling the covariates from what's already been done + # ----- + # The training data is already formatted, we just need to copy "Y" (our variable) to "X" as well + met.train$X <- met.train$Y + + # Lets deal with the source data first + # - Adding in the ensembles to be predicted + if(length(unique(met.src$ind.src))0){ # until we have our water year balanced + for(r in 1:length(dry)){ + # Pick a year with some rain and take the rain from it + # -- this *should* make sure we don't get an infinite loop by making one rainless day have negative rain + row.steal <- sample(rows.yr[which(sim1[rows.yr,j]>0)], 1) # The row we're stealing precip out of to balance the budget + sim1[row.steal,j] <- sim1[row.steal,j] + sim1[dry[r],j] + sim1[dry[r],j] <- 0 + } + dry <- rows.yr[which(sim1[rows.yr,j] < 0)] # update our dry days + } + + n.now <- round(rnorm(1, mean(rainless), sd(rainless)), 0) + cutoff <- quantile(sim1[rows.yr, j], n.now/366) + + # Figure out which days are currently below our cutoff and randomly distribute + # their precip to days that are not below the cutoff (this causes a more bi-modal + # distribution hwere dry days get drier), but other options ended up with either + # too few rainless days because of only slight redistribution (r+1) or buildup + # towards the end of the year (random day that hasn't happened) + dry <- rows.yr[which(sim1[rows.yr,j] < cutoff)] + + # Figure out where to put the extra rain; allow replacement for good measure + wet <- sample(rows.yr[!rows.yr %in% dry], length(dry), replace=T) + + # Go through and randomly redistribute the precipitation to days we're not designating as rainless + # Note, if we don't loop through, we might lose some of our precip + for(r in 1:length(dry)){ + sim1[wet[r],j] <- sim1[wet[r],j] + sim1[dry[r],j] + sim1[dry[r],j] <- 0 + } + } + } + } + + # Randomly pick one from this meta-ensemble to save + # this *should* be propogating uncertainty because we have the ind effects in all of the models and we're randomly adding as we go + sim.final[,ens] <- sim1[,sample(1:n.ens,1)] + + setTxtProgressBar(pb, pb.ind) + pb.ind <- pb.ind+1 + + rm(mod.bias, anom.train, anom.src, mod.anom, Xp, Xp.anom, sim1, sim1a, sim1b) + } + + # Store the output in our dat.out + dat.out[[v]] <- sim.final + # ------------- + + # ------------- + # Save some diagnostic graphs if useful + # ------------- + if(save.diagnostics==TRUE){ + dir.create(path.diagnostics, recursive=T, showWarnings=F) + + dat.pred <- source.data$time + dat.pred$obs <- apply(source.data[[v]], 1, mean) + dat.pred$mean <- apply(dat.out[[v]], 1, mean) + dat.pred$lwr <- apply(dat.out[[v]], 1, quantile, 0.025) + dat.pred$upr <- apply(dat.out[[v]], 1, quantile, 0.975) + + # Plotting the observed and the bias-corrected 95% CI + png(file.path(path.diagnostics, paste(ens.name, v, "day.png", sep="_"))) + print( + ggplot(data=dat.pred[dat.pred$Year>=mean(dat.pred$Year)-1 & dat.pred$Year<=mean(dat.pred$Year)+1,]) + + geom_ribbon(aes(x=Date, ymin=lwr, ymax=upr), fill="red", alpha=0.5) + + geom_line(aes(x=Date, y=mean), color="red", size=0.5) + + geom_line(aes(x=Date, y=obs), color='black', size=0.5) + + ggtitle(paste0(v, " - ensemble mean & 95% CI (daily slice)")) + + theme_bw() + ) + dev.off() + + # Plotting a few random series to get an idea for what an individual pattern looks liek + stack.sims <- stack(data.frame(dat.out[[v]][,sample(1:n.ens, min(3, n.ens))])) + stack.sims[,c("Year", "DOY", "Date")] <- dat.pred[,c("Year", "DOY", "Date")] + + png(file.path(path.diagnostics, paste(ens.name, v, "day2.png", sep="_"))) + print( + ggplot(data=stack.sims[stack.sims$Year>=mean(stack.sims$Year)-2 & stack.sims$Year<=mean(stack.sims$Year)+2,]) + + geom_line(aes(x=Date, y=values, color=ind), size=0.2, alpha=0.8) + + ggtitle(paste0(v, " - example ensemble members (daily slice)")) + + theme_bw() + ) + dev.off() + + # Looking tat the annual means over the whole time series to make sure we're getting decent interannual variability + dat.yr <- aggregate(dat.pred[,c("obs", "mean", "lwr", "upr")], + by=list(dat.pred$Year), + FUN=mean) + names(dat.yr)[1] <- "Year" + + png(file.path(path.diagnostics, paste(ens.name, v, "annual.png", sep="_"))) + print( + ggplot(data=dat.yr[,]) + + geom_ribbon(aes(x=Year, ymin=lwr, ymax=upr), fill="red", alpha=0.5) + + geom_line(aes(x=Year, y=mean), color="red", size=0.5) + + geom_line(aes(x=Year, y=obs), color='black', size=0.5) + + ggtitle(paste0(v, " - annual mean time series")) + + theme_bw() + ) + dev.off() + + } + # ------------- + + } # End looping through variables + # ------------------------------------------- + + + # Save the output + nc.info <- data.frame(CF.name = c("air_temperature", "air_temperature_minimum", "air_temperature_maximum", "precipitation_flux", + "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", + "air_pressure", "specific_humidity", "wind_speed"), + longname = c("2 meter air temperature", "2 meter minimum air temperature", "2 meter maximum air temperature", + "cumulative precipitation (water equivalent)", "incident (downwelling) showtwave radiation", + "incident (downwelling) longwave radiation", "air pressure at the surface", + "Specific humidity measured at the lowest level of the atmosphere", + "wind_speed speed"), + units = c("K", "K", "K", "kg m-2 s-1", "W m-2", "W m-2", "Pa", "kg kg-1", "m s-1") + ) + + # Define our lat/lon dims since those will be constant + dim.lat <- ncdim_def(name='latitude', units='degree_north', vals=lat.in, create_dimvar=TRUE) + dim.lon <- ncdim_def(name='longitude', units='degree_east', vals=lon.in, create_dimvar=TRUE) + + print("") + print("Saving Ensemble") + pb <- txtProgressBar(min=0, max=length(yrs.save)*n.ens, style=3) + pb.ind=1 + for(yr in yrs.save){ + # Doing some row/time indexing + rows.yr <- which(dat.out$time$Year==yr) + nday <- ifelse(leap_year(yr), 366, 365) + + # Finish defining our time variables (same for all ensemble members) + dim.time <- ncdim_def(name='time', units="sec", vals=seq(1*24*360, (nday+1-1/24)*24*360, length.out=length(rows.yr)), create_dimvar=TRUE, unlim=TRUE) + nc.dim=list(dim.lat,dim.lon,dim.time) + + # Setting up variables and dimensions + var.list = list() + dat.list = list() + + for(j in 1:length(vars.debias)){ + var.list[[j]] = ncvar_def(name=vars.debias[j], + units=as.character(nc.info[nc.info$CF.name==vars.debias[j], "units"]), + longname=as.character(nc.info[nc.info$CF.name==vars.debias[j], "longname"]), + dim=nc.dim, missval=-999, verbose=verbose) + } + names(var.list) <- vars.debias + + # Loop through & write each ensemble member + for(i in 1:n.ens){ + # Setting up file structure + ens.path <- file.path(outfolder, paste(ens.name, ens.mems[i], sep="_")) + dir.create(ens.path, recursive=T, showWarnings=F) + loc.file <- file.path(ens.path, paste(ens.name, ens.mems[i], str_pad(yr, width=4, side="left", pad="0"), "nc", sep = ".")) + + for(j in 1:length(vars.debias)){ + dat.list[[j]] = array(dat.out[[vars.debias[j]]][rows.yr,i], dim=c(length(lat.in), length(lon.in), length(rows.yr))) # Go ahead and make the arrays + } + names(dat.list) <- vars.debias + + ## put data in new file + loc <- nc_create(filename=loc.file, vars=var.list, verbose=verbose) + for(j in 1:length(vars.debias)){ + ncvar_put(nc=loc, varid=as.character(vars.debias[j]), vals=dat.list[[j]]) + } + nc_close(loc) + + setTxtProgressBar(pb, pb.ind) + pb.ind <- pb.ind+1 + } # End ensemble member loop + } # End year loop + print("") + print("Debiasing Completed!") +} # END FUNCTION! From 653140bd7a3afb9e0b1c8971b45e99a99bc55d36 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 22 Aug 2017 14:45:20 -0500 Subject: [PATCH 493/771] Align met w/ ensemble of training data Add functionality to the align.met script to be able to pull an ensemble of training data (important for uncertainty propagation when splicing many datasets together) --- modules/data.atmosphere/R/align_met.R | 74 +++++++++++++++++++++++++-- 1 file changed, 70 insertions(+), 4 deletions(-) diff --git a/modules/data.atmosphere/R/align_met.R b/modules/data.atmosphere/R/align_met.R index 6cb98eea82f..e8d9df7199a 100644 --- a/modules/data.atmosphere/R/align_met.R +++ b/modules/data.atmosphere/R/align_met.R @@ -51,7 +51,7 @@ #---------------------------------------------------------------------- # Begin Function #---------------------------------------------------------------------- -align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=1, pair.mems = TRUE, seed=Sys.Date(), verbose = FALSE) { +align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair.mems = TRUE, seed=Sys.Date(), verbose = FALSE) { # Load required libraries library(ncdf4) library(lubridate) @@ -70,7 +70,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=1, pair.mem yrs.file <- strsplit(files.train, "[.]") yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) - yrs.file <- as.numeric(yrs.file[,2]) + yrs.file <- as.numeric(yrs.file[,ncol(yrs.file)-1]) # Assumes year is always last thing before the file extension if(!is.null(yrs.train)){ files.train <- files.train[which(yrs.file %in% yrs.train)] @@ -110,7 +110,73 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=1, pair.mem setTxtProgressBar(pb, i) } # End looping through training data files } else { # we have an ensemble we need to deal with - stop("Training ensemble mode not implemented yet!") + # Figure out how many ensemble members we're working with + ens.train <- dir(train.path) + + if(is.null(n.ens)) n.ens <- length(ens.train) + if(length(ens.train)>n.ens) ens.train <- ens.train[sample(1:length(ens.train), n.ens)] + n.trn=n.ens + + # getting an estimate of how many files we need to process + n.files <- length(dir(file.path(train.path, ens.train[1]))) + + print("Processing Training Data") + pb <- txtProgressBar(min=0, max=length(ens.train)*n.files, style=3) + pb.ind=1 + for(j in 1:length(ens.train)){ + files.train <- dir(file.path(train.path, ens.train[j]), ".nc") + + yrs.file <- strsplit(files.train, "[.]") + yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) + yrs.file <- as.numeric(yrs.file[,ncol(yrs.file)-1]) # Assumes year is always last thing before the file extension + + if(!is.null(yrs.train)){ + files.train <- files.train[which(yrs.file %in% yrs.train)] + yrs.file <- yrs.file[which(yrs.file %in% yrs.train)] + } + + + # Loop through the .nc files putting everything into a list + dat.ens <- list() # Making a temporary storage bin for all the data from this ensemble member + for(i in 1:length(files.train)){ + yr.now <- yrs.file[i] + + ncT <- nc_open(file.path(train.path, ens.train[j], files.train[i])) + + # Set up the time data frame to help index + nday <- ifelse(leap_year(yr.now), 366, 365) + ntime <- length(ncT$dim$time$vals) + step.day <- nday/ntime + step.hr <- step.day*24 + stamps.hr <- seq(step.hr/2, by=step.hr, length.out=1/step.day) # Time stamps centered on period + + # Create a data frame with all the important time info + # center the hour step + # ** Only do this with the first ensemble member so we're not being redundant + if(j==1){ + df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/step.day), Hour=rep(stamps.hr, ntime)) + df.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") + met.out$dat.train[["time"]] <- rbind(met.out$dat.train$time, df.time) + } + + # Extract the met info, making matrices with the appropriate number of ensemble members + for(v in names(ncT$var)){ + dat.ens[[v]] <- append(dat.ens[[v]], ncvar_get(ncT, v)) + } + nc_close(ncT) + + setTxtProgressBar(pb, pb.ind) + pb.ind <- pb.ind+1 + } # End looping through training data files + + # Storing the ensemble member data in our output list + for(v in names(dat.ens)){ + met.out$dat.train[[v]] <- cbind(met.out$dat.train[[v]], dat.ens[[v]]) + } + } # End extracting ensemble members + for(v in 2:length(met.out$dat.train)){ + dimnames(met.out$dat.train[[v]])[[2]] <- ens.train + } } # End loading & formatting training data print(" ") # --------------- @@ -128,7 +194,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=1, pair.mem # create a vector of the years yrs.file <- strsplit(files.source, "[.]") yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) - yrs.file <- as.numeric(yrs.file[,2]) + yrs.file <- as.numeric(yrs.file[,ncol(yrs.file)-1]) # Assumes year is always last thing before the file extension # Getting the day & hour timesteps from the training data day.train <- round(365/length(unique(met.out$dat.train$time$DOY))) From 7954c1744f1315f1f65fa57c1e136b297fbe7771 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 22 Aug 2017 17:05:20 -0500 Subject: [PATCH 494/771] Bug fix: defining the ensemble members to pull Forgot to add a case so that if we have the right number of training ensemble members to propagate, we should take them all (in the order they were prescribed) --- modules/data.atmosphere/R/debias_met_regression.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/modules/data.atmosphere/R/debias_met_regression.R b/modules/data.atmosphere/R/debias_met_regression.R index c696ed93ea7..9ca0d5a7355 100644 --- a/modules/data.atmosphere/R/debias_met_regression.R +++ b/modules/data.atmosphere/R/debias_met_regression.R @@ -96,6 +96,8 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU # - Referencing off of whatever the layer after "time" is # --------- # If we have fewer columns then we need, randomly duplicate some + if(ncol(train.data[[2]])==n.ens) ens.train <- 1:n.ens + if(ncol(train.data[[2]]) < n.ens){ ens.train <- c(1:ncol(train.data[[2]]), sample(1:ncol(train.data[[2]]), n.ens-ncol(train.data[[2]]),replace=T)) } @@ -127,6 +129,7 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU # If we don't have a year of overlap, take closest 20 years from each dataset if(length(yrs.overlap)<1){ + warning("No overlap in years, so we cannot pair the anomalies") yrs.overlap <- (max(min(train.data$time$Year), min(source.data$time$Year))-20):(min(max(train.data$time$Year), max(source.data$time$Year))+20) pair.anoms=FALSE # we can't pair the anomalies no matter what we tried to specify before } From a668c593c171a450842b97faae27f6c41fad9f84 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Wed, 30 Aug 2017 15:46:15 -0500 Subject: [PATCH 495/771] Bug Fixes: align.met, CMIP5 extraction Bug fixes that get the bias correction flow working: align.met - forgot to add cases that get non-aggregation scenarios to work Extract.CMIP5 - add in additional possibilities for base wind data --- modules/data.atmosphere/R/align_met.R | 18 +- .../data.atmosphere/R/extract_local_CMIP5.R | 299 ++++++++++++++++++ 2 files changed, 314 insertions(+), 3 deletions(-) create mode 100644 modules/data.atmosphere/R/extract_local_CMIP5.R diff --git a/modules/data.atmosphere/R/align_met.R b/modules/data.atmosphere/R/align_met.R index e8d9df7199a..9e30e51f404 100644 --- a/modules/data.atmosphere/R/align_met.R +++ b/modules/data.atmosphere/R/align_met.R @@ -118,7 +118,16 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. n.trn=n.ens # getting an estimate of how many files we need to process - n.files <- length(dir(file.path(train.path, ens.train[1]))) + yrs.file <- strsplit(dir(file.path(train.path, ens.train[1])), "[.]") + yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) + yrs.file <- as.numeric(yrs.file[,ncol(yrs.file)-1]) # Assumes year is always last thing before the file extension + + if(!is.null(yrs.train)){ + n.files <- length(yrs.file[which(yrs.file %in% yrs.train)]) + } else { + n.files <- length(dir(file.path(train.path, ens.train[1]))) + } + print("Processing Training Data") pb <- txtProgressBar(min=0, max=length(ens.train)*n.files, style=3) @@ -202,7 +211,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. # Loop through the .nc files putting everything into a list print("Processing Source Data") - pb <- txtProgressBar(min=0, max=length(files.train), style=3) + pb <- txtProgressBar(min=0, max=length(files.source), style=3) for(i in 1:length(files.source)){ yr.now <- yrs.file[i] @@ -220,6 +229,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. # ----- # Making what the unique time stamps should be to match the training data stamps.hr <- seq(hr.train/2, by=hr.train, length.out=1/day.train) + stamps.src <- stamps.hr if(step.hr < hr.train){ # Finer hour increment --> set it up to aggregate align = "aggregate" @@ -264,7 +274,9 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. met.out$dat.source[["air_temperature_minimum"]] <- rbind(met.out$dat.source[["air_temperature_minimum"]], as.matrix(tmin[,(3+1:n.src)])) met.out$dat.source[["air_temperature_maximum"]] <- rbind(met.out$dat.source[["air_temperature_maximum"]], as.matrix(tmax[,(3+1:n.src)])) } - } + } else { + met.out$dat.source[[v]] <- rbind(met.out$dat.source[[v]], df.tem) + } # If met doesn't need to be aggregated, just copy it in if(align %in% c("repeat", "align")) { diff --git a/modules/data.atmosphere/R/extract_local_CMIP5.R b/modules/data.atmosphere/R/extract_local_CMIP5.R new file mode 100644 index 00000000000..9757bf7cbb6 --- /dev/null +++ b/modules/data.atmosphere/R/extract_local_CMIP5.R @@ -0,0 +1,299 @@ +##' Extract NLDAS from local download +##' Extract NLDAS meteorology for a poimt from a local download of the full grid +# ----------------------------------- +# Description +# ----------------------------------- +##' @title extract.local.CMIP5 +##' @family +##' @author Christy Rollinson, +##' @description This function extracts CMIP5 data from grids that have been downloaded and stored locally. +##' Files are saved as a netCDF file in CF conventions at *DAILY* resolution. Note: At this point +##' in time, variables that are only available at a native monthly resolution will be repeated to +##' give a pseudo-daily record (and can get dealt with in the downscaling workflow). These files +##' are ready to be used in the general PEcAn workflow or fed into the downscaling workflow. +# ----------------------------------- +# Parameters +# ----------------------------------- +##' @param outfolder - directory where output files will be stored +##' @param in.path - path to the raw full grids +##' @param start_date - first day for which you want to extract met (yyyy-mm-dd) +##' @param end_date - last day for which you want to extract met (yyyy-mm-dd) +##' @param site_id name to associate with extracted files +##' @param lat.in site latitude in decimal degrees +##' @param lon.in site longitude in decimal degrees +##' @param model which GCM to extract data from +##' @param scenario which experiment to pull (p1000, historical, ...) +##' @param ensemble_member which CMIP5 experiment ensemble member +##' @param overwrite logical. Download a fresh version even if a local file with the same name already exists? +##' @param verbose logical. to control printing of debug info +##' @param ... Other arguments, currently ignored +##' @export +##' @examples +# ----------------------------------- +extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_id, lat.in, lon.in, + model , scenario , ensemble_member = "r1i1p1", + overwrite = FALSE, verbose = FALSE, ...){ + library(lubridate) + library(ncdf4) + library(stringr) + + # Some GCMs don't do leap year; we'll have to deal with this separately + no.leap <- c("bcc-csm1-1", "CCSM4") + + # Days per month + dpm <- days_in_month(1:12) + + # Date stuff + start_date <- as.POSIXlt(start_date, tz = "GMT") + end_date <- as.POSIXlt(end_date, tz = "GMT") + start_year <- year(start_date) + end_year <- year(end_date) + + lat.in = as.numeric(lat.in) + lon.in = as.numeric(lon.in) + # dir.nldas="http://hydro1.sci.gsfc.nasa.gov/thredds/dodsC/NLDAS_FORA0125_H.002" + dir.create(outfolder, showWarnings=FALSE, recursive=TRUE) + + ylist <- seq(start_year,end_year,by=1) + rows = length(ylist) + results <- data.frame(file=character(rows), host=character(rows), + mimetype=character(rows), formatname=character(rows), + startdate=character(rows), enddate=character(rows), + dbfile.name = "NLDAS", + stringsAsFactors = FALSE + ) + + # The table of var name conversion + # psl; sfcWind; tasmax; tasmin; huss + var <- data.frame(DAP.name = c("tas", "tasmax", "tasmin", "rlds", "ps", "rsds", "uas", "vas", "sfcWind", "ua", "va", "huss", "pr"), + CF.name = c("air_temperature", "air_temperature_maximum", "air_temperature_minimum", + "surface_downwelling_longwave_flux_in_air", + "air_pressure", "surface_downwelling_shortwave_flux_in_air", + "eastward_wind", "northward_wind", "wind_speed", "eastward_wind", "northward_wind", + "specific_humidity", "precipitation_flux"), + units = c("Kelvin", "Kelvin", "Kelvin", "W/m2", "Pascal", "W/m2", "m/s", "m/s", "m/s", "m/s", "m/s", "g/g", "kg/m2/s")) + + # Figuring out what we have daily for and what we only have monthly for + vars.gcm.day <- dir(file.path(in.path, "day")) + vars.gcm.mo <- dir(file.path(in.path, "month")) + vars.gcm.mo <- vars.gcm.mo[!vars.gcm.mo %in% vars.gcm.day] + + vars.gcm <- c(vars.gcm.day, vars.gcm.mo) + + # Rewriting the dap name to get the closest variable that we have for the GCM (some only give uss stuff at sea level) + library(car) # having trouble gettins stuff to work otherwise + if(!("huss" %in% vars.gcm)) var$DAP.name <- recode(var$DAP.name, "'huss'='hus'") + if(!("ps" %in% vars.gcm )) var$DAP.name <- recode(var$DAP.name, "'ps'='psl'") + + # Making sure we're only trying to grab the variables we have (i.e. don't try sfcWind if we don't have it) + var <- var[var$DAP.name %in% vars.gcm,] + + # Native CMIP5 file structure is organized by variable and then with multiple years per file + # this means we need to do some funky things to get all variables for one year into a single file + var$DAP.name <- as.character(var$DAP.name) + + files.var <- list() + n.file=0 + for(v in var$DAP.name){ + files.var[[v]] <- list() + if(v %in% vars.gcm.day){ + # Get a list of file names + files.var[[v]][["files"]] <- dir(file.path(in.path, "day", v)) + } else { + files.var[[v]][["files"]] <- dir(file.path(in.path, "month", v)) + } + + # Set up an index to help us find out which file we'll need + files.var[[v]][["years"]] <- data.frame(first.year=NA, last.year=NA) + for(i in 1:length(files.var[[v]][["files"]])){ + yr.str <- str_split(str_split(files.var[[v]][["files"]][[i]], "_")[[1]][6], "-")[[1]] + + # Don't bother storing this file if we don't want those years + if(as.numeric(substr(yr.str[1], 1, 4)) > end_year | as.numeric(substr(yr.str[2], 1, 4))< start_year) next + files.var[[v]][["years"]][i, "first.year"] <- as.numeric(substr(yr.str[1], 1, 4)) + files.var[[v]][["years"]][i, "last.year" ] <- as.numeric(substr(yr.str[2], 1, 4)) + + n.file=n.file+1 + } # End file loop + } # end variable loop + + + # Querying large netcdf files 1,000 times is slow. So lets open the connection once and + # pull the full time series + # Loop through using the files using the first variable; shoudl be tair & should be highest res avail + # This will require quite a bit of memory, but it's doable + dat.all <- list() + dat.time <- seq(start_date, end_date, by="day") # Everything should end up being a day + + print("- Extracting files: ") + pb <- txtProgressBar(min=1, max=n.file, style=3) + pb.ind=1 + # Loop through each variable so that we don't have to open files more than once + for(v in 1:nrow(var)){ + + var.now <- var[v,"DAP.name"] + # print(var.now) + + dat.all[[v]] <- vector() # initialize the layer + # Figure out the temporal resolution of the variable + v.res <- ifelse(var.now %in% vars.gcm.day, "day", "month") + + # Figure out what file we need + # file.ind <- which(files.var[[var.now]][i]) + for(i in 1:length(files.var[[var.now]]$files)){ + setTxtProgressBar(pb, pb.ind) + pb.ind=pb.ind+1 + f.now <- files.var[[var.now]]$files[i] + # print(f.now) + + # Open up the file + ncT <- nc_open(file.path(in.path, v.res, var.now, f.now)) + + # Extract our dimensions + lat_bnd <- ncvar_get(ncT, "lat_bnds") + lon_bnd <- ncvar_get(ncT, "lon_bnds") + nc.time <- ncvar_get(ncT, "time") + + # splt.ind <- ifelse(GCM %in% c("MPI-ESM-P"), 4, 3) + # date.origin <- as.Date(str_split(ncT$dim$time$units, " ")[[1]][splt.ind]) + + # Find the closest grid cell for our site (using harvard as a protoype) + ind.lat <- which(lat_bnd[1,]<=lat.in & lat_bnd[2,]>=lat.in) + if(max(lon.in)>=180){ + ind.lon <- which(lon_bnd[1,]>=lon.in & lon_bnd[2,]<=lon.in) + } else { + ind.lon <- which(lon_bnd[1,]<=180+lon.in & lon_bnd[2,]>=180+lon.in) + } + + # Extract all of the available data + if(var.now %in% c("hus", "ua", "va")){ # These have multiple strata; we only want 1 + plev <- ncvar_get(ncT, "plev") + puse <- which(plev==max(plev)) # Get humidity at the place of highest pressure (closest to surface) + dat.temp <- ncvar_get(ncT, var.now, c(ind.lon, ind.lat, puse, 1), c(1,1,1,length(nc.time))) + # If dat.list has missing values, try the next layer + puse.orig <- puse + while(is.na(mean(dat.temp))){ + if(puse.orig==1) { puse = puse + 1 } else { puse = puse -1 } + dat.temp <- ncvar_get(ncT, var.now, c(ind.lon, ind.lat, puse, 1), c(1,1,1,length(nc.time))) + } + } else { + dat.temp <- ncvar_get(ncT, var.now, c(ind.lon, ind.lat, 1), c(1,1,length(nc.time))) + } + + # If we have monthly data, lets trick it into being daily + if(v.res == "month"){ + mo.ind <- rep(1:12, length.out=length(dat.temp)) + dat.trick <- vector() + for(j in 1:length(dat.temp)){ + dat.trick <- c(dat.trick, rep(dat.temp[j], dpm[mo.ind[j]])) + } + dat.temp <- dat.trick + } # End leap day trick + + dat.all[[v]] <- append(dat.all[[v]], dat.temp, length(dat.all[[v]])) + nc_close(ncT) + } # End file loop + } # End variable loop + + # Dealing with leap-year post-hoc because it was becoming a pain in the ass + # If we have daily data and we're dealing with a model that skips leap year, add it in + dpm <- days_in_month(1:12) + yrs.leap <- ylist[leap_year(ylist)] + for(y.now in yrs.leap){ + yr.ind <- which(year(dat.time)==y.now) + if(GCM %in% no.leap & v.res == "day"){ + for(v in 1:length(dat.all)){ + dat.all[[v]] <- append(dat.all[[v]], dat.all[[v]][yr.ind[sum(dpm[1:2])]], sum(yr.ind[dpm[1:2]])) + } + } + } + + + + print("") + print("- Writing to NetCDF: ") + pb <- txtProgressBar(min=1, max=rows, style=3) + for (i in 1:rows){ + setTxtProgressBar(pb, i) + + y.now = ylist[i] + yr.ind <- which(year(dat.time)==y.now) + + + dpm <- days_in_month(1:12) + if(leap_year(y.now)) dpm[2] <- dpm[2] + 1 # make sure Feb has 29 days if we're dealing with a leap year + + # figure out how many days we're working with + if(rows>1 & i!=1 & i!=rows){ # If we have multiple years and we're not in the first or last year, we're taking a whole year + nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + day1 = 1 + day2 = nday + days.use = day1:day2 + } else if(rows==1){ + # if we're working with only 1 year, lets only pull what we need to + nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + day1 <- yday(start_date) + # Now we need to check whether we're ending on the right day + day2 <- yday(end_date) + days.use = day1:day2 + nday=length(days.use) # Update nday + } else if(i==1) { + # If this is the first of many years, we only need to worry about the start date + nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + day1 <- yday(start_date) + day2 = nday + days.use = day1:day2 + nday=length(days.use) # Update nday + } else if(i==rows) { + # If this is the last of many years, we only need to worry about the start date + nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + day1 = 1 + day2 <- yday(end_date) + days.use = day1:day2 + nday=length(days.use) # Update nday + } + ntime = nday # leap year or not; time slice (coerce to daily) + + loc.file <- file.path(outfolder, paste(model, scenario, ensemble_member, str_pad(y.now, width=4, side="left", pad="0"), "nc", sep = ".")) + + + ## Create dimensions + dim.lat <- ncdim_def(name='latitude', units='degree_north', vals=lat.in, create_dimvar=TRUE) + dim.lon <- ncdim_def(name='longitude', units='degree_east', vals=lon.in, create_dimvar=TRUE) + dim.time <- ncdim_def(name='time', units="sec", vals=seq((min(days.use)+1-1/24)*24*360, (max(days.use)+1-1/24)*24*360, length.out=ntime), create_dimvar=TRUE, unlim=TRUE) + nc.dim=list(dim.lat,dim.lon,dim.time) + + + # Defining our dimensions up front + var.list = list() + dat.list = list() + + for(j in 1:nrow(var)){ + var.list[[j]] = ncvar_def(name=as.character(var$CF.name[j]), units=as.character(var$units[j]), dim=nc.dim, missval=-999, verbose=verbose) + dat.list[[j]] <- array(NA, dim=c(length(lat.in), length(lon.in), ntime)) # Go ahead and make the arrays + } + names(var.list) <- names(dat.list) <- var$CF.name + + # Loop through each variable in the order of everything else + for(v in 1:nrow(var)){ + dat.list[[v]] <- dat.all[[v]][yr.ind] + } # End variable loop + + ## put data in new file + loc <- nc_create(filename=loc.file, vars=var.list, verbose=verbose) + for(j in 1:nrow(var)){ + ncvar_put(nc=loc, varid=as.character(var$CF.name[j]), vals=dat.list[[j]]) + } + nc_close(loc) + + results$file[i] <- loc.file + # results$host[i] <- fqdn() + results$startdate[i] <- paste0(as.Date(paste(y.now, day1, sep="-"), format = "%Y-%j"), " 00:00:00") + results$enddate[i] <- paste0(as.Date(paste(y.now, day2, sep="-"), format = "%Y-%j"), " 00:00:00") + results$mimetype[i] <- 'application/x-netcdf' + results$formatname[i] <- 'CF Meteorology' + + } # End i loop (rows/years) + +} # End function + From 64e1002b116ff47c2ffab2f4870c5787a8f89b4d Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Fri, 25 Aug 2017 10:46:58 -0500 Subject: [PATCH 496/771] Debias bug fixes - move transformations for most variables outside of ensemble loop (ended up squaring things too many times - fix a couple variable names; make sure tax is in there - add na.rm to calculations to accommodate missing data - fix precipitation model to be based off of the training data with paired anomalies --- .../data.atmosphere/R/debias_met_regression.R | 48 ++++++++++++------- 1 file changed, 32 insertions(+), 16 deletions(-) diff --git a/modules/data.atmosphere/R/debias_met_regression.R b/modules/data.atmosphere/R/debias_met_regression.R index 9ca0d5a7355..6fcee77ec60 100644 --- a/modules/data.atmosphere/R/debias_met_regression.R +++ b/modules/data.atmosphere/R/debias_met_regression.R @@ -75,7 +75,7 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU if(ncol(source.data[[2]])>1) warning("Feeding an ensemble of source data is currently experimental! This could crash") # Variables need to be done in a specific order - vars.all <- c("air_temperature", "air_temperature_minimum", "air_temperature_maximum", "specific_humidity", "surface_downwelling_shortwave_flux_in_air", "air_pressure", "surface_downwelling_longwave_flux_in_air", "wind_speed", "precipitation_flux") + vars.all <- c("air_temperature", "air_temperature_maximum", "air_temperature_minimum", "specific_humidity", "surface_downwelling_shortwave_flux_in_air", "air_pressure", "surface_downwelling_longwave_flux_in_air", "wind_speed", "precipitation_flux") if(is.null(vars.debias)) vars.debias <- vars.all[vars.all %in% names(train.data)] # Don't try to do vars that we don't have if(is.null(yrs.save)) yrs.save <- unique(source.data$time$Year) @@ -223,7 +223,7 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU # Aggregate to get rid of years so that we can compare climatic means clim.src <- aggregate(met.src[met.src$year %in% yrs.overlap,"X"], by=met.src[met.src$year %in% yrs.overlap,c("doy", "ind.src")], - FUN=mean) + FUN=mean, na.rm=T) names(clim.src)[3] <- "X" # ----- @@ -280,6 +280,7 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU if(v %in% vars.transform){ dat.clim[,c("X", "Y")] <- sqrt(dat.clim[,c("X", "Y")]) met.src$X <- sqrt(met.src$X) + met.train$X <- sqrt(met.train$X) met.train$Y <- sqrt(met.train$Y) } # ------------- @@ -417,12 +418,13 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU # k=round(length(met.src$year)/(25*366),0) # k=max(k, 4) # we can't have less than 4 knots - mod.anom <- gam(anom.raw ~ s(year, k=k) + (air_temperature_maximum.anom + air_temperature_minimum.anom + surface_downwelling_shortwave_flux_in_air.anom + surface_downwelling_longwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.src[met.src$ind==ind,]) + # mod.anom <- gam(anom.raw ~ s(year, k=k) + (air_temperature_maximum.anom + air_temperature_minimum.anom + surface_downwelling_shortwave_flux_in_air.anom + surface_downwelling_longwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.src[met.src$ind==ind,]) + mod.anom <- gam(anom.train ~ s(doy, k=6) + (air_temperature_maximum.anom + air_temperature_minimum.anom + surface_downwelling_shortwave_flux_in_air.anom + surface_downwelling_longwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.train[met.train$ind==ind,]) } else if(v %in% c("wind_speed", "air_pressure", "surface_downwelling_longwave_flux_in_air")) { # These variables are constant in CRU pre-1950. # This means that we can not use information about the long term trend OR the actual annomalies # -- they must be inferred from the other met we have - mod.anom <- gam(anom.raw ~ s(doy, k=6) + (air_temperature_minimum.anom*air_temperature_maximum.anom + surface_downwelling_shortwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.src[met.src$ind==ind,]) + mod.anom <- gam(anom.train ~ s(doy, k=6) + (air_temperature_minimum.anom*air_temperature_maximum.anom + surface_downwelling_shortwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.train[met.train$ind==ind,]) } } else { # If we're dealing with non-empirical datasets, we can't pair anomalies to come up with a direct adjustment @@ -543,16 +545,16 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU # If we're dealing with precip, transform proportions of rain back to actual precip if(v == "precipitation_flux"){ sim1 <- sim1*sim1c - met.src$X <- met.src$X*met.src$X.tot - met.src$anom.raw <- met.src$anom.raw*met.src$X.tot + # met.src$X <- met.src$X*met.src$X.tot + # met.src$anom.raw <- met.src$anom.raw*met.src$X.tot } # Un-transform variables where we encounter zero-truncation issues # NOTE: Need to do this *before* we sum the components!! - if(v %in% c("surface_downwelling_shortwave_flux_in_air", "specific_humidity", "surface_downwelling_longwave_flux_in_air", "wind_speed")){ - sim1 <- sim1^2 - met.src[met.src$ind==ind,"X"] <- met.src[met.src$ind==ind,"X"]^2 - } + #if(v %in% vars.transform){ + # sim1 <- sim1^2 + # # met.src[met.src$ind==ind,"X"] <- met.src[met.src$ind==ind,"X"]^2 + #} # For preciptiation, we need to make sure we don't have constant drizzel and have @@ -578,8 +580,8 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU dry <- rows.yr[which(sim1[rows.yr,j] < 0)] # update our dry days } - n.now <- round(rnorm(1, mean(rainless), sd(rainless)), 0) - cutoff <- quantile(sim1[rows.yr, j], n.now/366) + n.now <- round(rnorm(1, mean(rainless, na.rm=T), sd(rainless, na.rm=T)), 0) + cutoff <- quantile(sim1[rows.yr, j], n.now/366, na.rm=T) # Figure out which days are currently below our cutoff and randomly distribute # their precip to days that are not below the cutoff (this causes a more bi-modal @@ -610,6 +612,20 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU rm(mod.bias, anom.train, anom.src, mod.anom, Xp, Xp.anom, sim1, sim1a, sim1b) } + + if(v == "precipitation_flux"){ + # sim1 <- sim1*sim1c + met.src$X <- met.src$X*met.src$X.tot + met.src$anom.raw <- met.src$anom.raw*met.src$X.tot + } + + if(v %in% vars.transform){ + sim.final <- sim.final^2 + dat.clim[,c("X", "Y")] <- (dat.clim[,c("X", "Y")]^2) + met.src$X <- (met.src$X)^2 + met.train$X <- (met.train$X)^2 + met.train$Y <- (met.train$Y)^2 + } # Store the output in our dat.out dat.out[[v]] <- sim.final @@ -622,10 +638,10 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU dir.create(path.diagnostics, recursive=T, showWarnings=F) dat.pred <- source.data$time - dat.pred$obs <- apply(source.data[[v]], 1, mean) - dat.pred$mean <- apply(dat.out[[v]], 1, mean) - dat.pred$lwr <- apply(dat.out[[v]], 1, quantile, 0.025) - dat.pred$upr <- apply(dat.out[[v]], 1, quantile, 0.975) + dat.pred$obs <- apply(source.data[[v]], 1, mean, na.rm=T) + dat.pred$mean <- apply(dat.out[[v]], 1, mean, na.rm=T) + dat.pred$lwr <- apply(dat.out[[v]], 1, quantile, 0.025, na.rm=T) + dat.pred$upr <- apply(dat.out[[v]], 1, quantile, 0.975, na.rm=T) # Plotting the observed and the bias-corrected 95% CI png(file.path(path.diagnostics, paste(ens.name, v, "day.png", sep="_"))) From 079da9418415a4f942feffe12349a138b908f1e0 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Wed, 30 Aug 2017 16:04:28 -0500 Subject: [PATCH 497/771] Update Documentation Updating all of the documentation that goes along with the debiasing functions --- modules/data.atmosphere/NAMESPACE | 3 + modules/data.atmosphere/man/align.met.Rd | 41 ++++++++++ .../man/debias.met.regression.Rd | 74 +++++++++++++++++++ .../man/extract.local.CMIP5.Rd | 51 +++++++++++++ 4 files changed, 169 insertions(+) create mode 100644 modules/data.atmosphere/man/align.met.Rd create mode 100644 modules/data.atmosphere/man/debias.met.regression.Rd create mode 100644 modules/data.atmosphere/man/extract.local.CMIP5.Rd diff --git a/modules/data.atmosphere/NAMESPACE b/modules/data.atmosphere/NAMESPACE index 1bf20dd6cbe..c6592321c74 100644 --- a/modules/data.atmosphere/NAMESPACE +++ b/modules/data.atmosphere/NAMESPACE @@ -3,6 +3,7 @@ export(.extract.nc.module) export(.met2model.module) export(AirDens) +export(align.met) export(browndog.met) export(cfmet.downscale.daily) export(cfmet.downscale.subdaily) @@ -10,6 +11,7 @@ export(cfmet.downscale.time) export(closest_xy) export(db.site.lat.lon) export(debias.met) +export(debias.met.regression) export(download.Ameriflux) export(download.AmerifluxLBL) export(download.CRUNCEP) @@ -27,6 +29,7 @@ export(download.NLDAS) export(download.PalEON) export(download.PalEON_ENS) export(exner) +export(extract.local.CMIP5) export(extract.nc) export(gen.subdaily.models) export(get.es) diff --git a/modules/data.atmosphere/man/align.met.Rd b/modules/data.atmosphere/man/align.met.Rd new file mode 100644 index 00000000000..e76007a2610 --- /dev/null +++ b/modules/data.atmosphere/man/align.met.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/align_met.R +\name{align.met} +\alias{align.met} +\title{align.met} +\usage{ +align.met(train.path, source.path, yrs.train = NULL, n.ens = NULL, + pair.mems = TRUE, seed = Sys.Date(), verbose = FALSE) +} +\arguments{ +\item{train.path}{- path to the dataset to be used to downscale the data} + +\item{source.path}{- data to be bias-corrected aligned with training data (from align.met)} + +\item{yrs.train}{- (optional) specify a specific years to be loaded for the training data; +prevents needing to load the entire dataset. If NULL, all available years +will be loaded. If not null, should be a vector of numbers (so you can skip +problematic years)} + +\item{n.ens}{- number of ensemble members to generate and save} + +\item{pair.mems}{- logical stating whether ensemble members should be paired} + +\item{seed}{- specify seed so that random draws can be reproduced} +} +\description{ +This script aligns meteorology datasets in at temporal resolution for debiasing & + temporal downscaling. + Note: The output here is stored in memory! + Note: can probably at borrow from or adapt align_data.R in Benchmarking module, but + it's too much of a black box at the moment. +} +\details{ +Align meteorology datasets for debiasing +} +\seealso{ +Other debias - Debias & Align Meteorology Datasets into continuous time series: \code{\link{debias.met.regression}} +} +\author{ +Christy Rollinson +} diff --git a/modules/data.atmosphere/man/debias.met.regression.Rd b/modules/data.atmosphere/man/debias.met.regression.Rd new file mode 100644 index 00000000000..1ba10b28480 --- /dev/null +++ b/modules/data.atmosphere/man/debias.met.regression.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/debias_met_regression.R +\name{debias.met.regression} +\alias{debias.met.regression} +\title{debias.met.regression} +\usage{ +debias.met.regression(train.data, source.data, n.ens, vars.debias = NULL, + CRUNCEP = FALSE, pair.anoms = TRUE, pair.ens = FALSE, + uncert.prop = "mean", resids = FALSE, seed = Sys.Date(), outfolder, + yrs.save = NULL, ens.name, ens.mems = NULL, lat.in, lon.in, + save.diagnostics = TRUE, path.diagnostics = NULL, parallel = FALSE, + n.cores = NULL, overwrite = TRUE, verbose = FALSE) +} +\arguments{ +\item{train.data}{- training data coming out of align.met} + +\item{source.data}{- data to be bias-corrected aligned with training data (from align.met)} + +\item{n.ens}{- number of ensemble members to generate and save for EACH source ensemble member} + +\item{vars.debias}{- which met variables should be debiased? if NULL, all variables in train.data} + +\item{CRUNCEP}{- flag for if the dataset being downscaled is CRUNCEP; if TRUE, special cases triggered for +met variables that have been naively gapfilled for certain time periods} + +\item{pair.anoms}{- logical stating whether anomalies from the same year should be matched or not} + +\item{pair.ens}{- logical stating whether ensembles from train and source data need to be paired together +(for uncertainty propogation)} + +\item{uncert.prop}{- method for error propogation if only 1 ensemble member; options=c(random, mean); *Not Implemented yet} + +\item{resids}{- logical stating whether to pass on residual data or not *Not implemented yet} + +\item{seed}{- specify seed so that random draws can be reproduced} + +\item{outfolder}{- directory where the data should go} + +\item{yrs.save}{- what years from the source data should be saved; if NULL all years of the source data will be saved} + +\item{ens.name}{- what is the name that should be attached to the debiased ensemble} + +\item{ens.mems}{- what labels/numbers to attach to the ensemble members so we can gradually build bigger ensembles +without having to do do giant runs at once; if NULL will be numbered 1:n.ens} + +\item{lat.in}{- latitude of site} + +\item{lon.in}{- longitude of site} + +\item{save.diagnostics}{- logical; save diagnostic plots of output?} + +\item{path.diagnostics}{- path to where the diagnostic graphs should be saved} + +\item{parallel}{- (experimental) logical stating whether to run temporal_downscale_functions.R in parallel *Not Implemented yet} + +\item{n.cores}{- (experimental) how many cores to use in parallelization *Not implemented yet} + +\item{overwrite}{- overwrite existing files?} +} +\description{ +This script debiases one dataset (e.g. GCM, re-analysis product) given another higher + resolution product or empirical observations. It assumes input are in annual CF standard + files that are generate from the pecan extract or download funcitons. +} +\details{ +Debias Meteorology using Multiple Linear Regression +Statistically debias met datasets and generate ensembles based on the observed uncertainty +} +\seealso{ +Other debias - Debias & Align Meteorology Datasets into continuous time series: \code{\link{align.met}} +} +\author{ +Christy Rollinson +} diff --git a/modules/data.atmosphere/man/extract.local.CMIP5.Rd b/modules/data.atmosphere/man/extract.local.CMIP5.Rd new file mode 100644 index 00000000000..abfdb852451 --- /dev/null +++ b/modules/data.atmosphere/man/extract.local.CMIP5.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/extract_local_CMIP5.R +\name{extract.local.CMIP5} +\alias{extract.local.CMIP5} +\title{extract.local.CMIP5} +\usage{ +extract.local.CMIP5(outfolder, in.path, start_date, end_date, site_id, lat.in, + lon.in, model, scenario, ensemble_member = "r1i1p1", overwrite = FALSE, + verbose = FALSE, ...) +} +\arguments{ +\item{outfolder}{- directory where output files will be stored} + +\item{in.path}{- path to the raw full grids} + +\item{start_date}{- first day for which you want to extract met (yyyy-mm-dd)} + +\item{end_date}{- last day for which you want to extract met (yyyy-mm-dd)} + +\item{site_id}{name to associate with extracted files} + +\item{lat.in}{site latitude in decimal degrees} + +\item{lon.in}{site longitude in decimal degrees} + +\item{model}{which GCM to extract data from} + +\item{scenario}{which experiment to pull (p1000, historical, ...)} + +\item{ensemble_member}{which CMIP5 experiment ensemble member} + +\item{overwrite}{logical. Download a fresh version even if a local file with the same name already exists?} + +\item{verbose}{logical. to control printing of debug info} + +\item{...}{Other arguments, currently ignored} +} +\description{ +This function extracts CMIP5 data from grids that have been downloaded and stored locally. + Files are saved as a netCDF file in CF conventions at *DAILY* resolution. Note: At this point + in time, variables that are only available at a native monthly resolution will be repeated to + give a pseudo-daily record (and can get dealt with in the downscaling workflow). These files + are ready to be used in the general PEcAn workflow or fed into the downscaling workflow. +} +\details{ +Extract NLDAS from local download +Extract NLDAS meteorology for a poimt from a local download of the full grid +} +\author{ +Christy Rollinson, +} From 9a72bff7265d6022076078101ca38c249bc2225c Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Thu, 31 Aug 2017 07:21:09 -0400 Subject: [PATCH 498/771] tree-ring: small bugfix --- modules/data.land/R/InventoryGrowthFusion.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/R/InventoryGrowthFusion.R b/modules/data.land/R/InventoryGrowthFusion.R index 30c7028531c..b05ab466c62 100644 --- a/modules/data.land/R/InventoryGrowthFusion.R +++ b/modules/data.land/R/InventoryGrowthFusion.R @@ -330,7 +330,7 @@ model{ covX[j] <- sub("[t]","",covX[j],fixed = TRUE) if(!(covX[j] %in% names(data))){ ## add cov variables to data object - data[[covX[j]]] <- time_varying[[covX[j]]] + data[[covX[j]]] <- time_data[[covX[j]]] } myBeta <- paste0(myBeta,covX[j]) covX[j] <- paste0(covX[j],"[i,t]") From 1905fb006578dd59de4abf4c9b49379e2a370a4b Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 31 Aug 2017 11:02:21 -0400 Subject: [PATCH 499/771] Add SoilResp to standard_vars --- base/utils/data/standard_vars.csv | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/base/utils/data/standard_vars.csv b/base/utils/data/standard_vars.csv index 969648f4414..01cbdfd02e5 100755 --- a/base/utils/data/standard_vars.csv +++ b/base/utils/data/standard_vars.csv @@ -17,8 +17,9 @@ "GPP",NA,"kg C m-2 s-1","Gross Primary Productivity","Carbon Fluxes","real","lon","lat","time",NA,"Rate of photosynthesis (always positive)" "NEE",NA,"kg C m-2 s-1","Net Ecosystem Exchange","Carbon Fluxes","real","lon","lat","time",NA,"Net Ecosystem Exchange (NEE=HeteroResp+AutoResp-GPP, positive into atmosphere)" "TotalResp",NA,"kg C m-2 s-1","Total Respiration","Carbon Fluxes","real","lon","lat","time",NA,"Total respiration (TotalResp=AutoResp+heteroResp, always positive)" -"AutoResp",NA,"kg C m-2 s-1","Autotrophic Respiration","Carbon Fluxes","real","lon","lat","time",NA,"Autotrophic respiration rate (always positive)" -"HeteroResp",NA,"kg C m-2 s-1","Heterotrophic Respiration","Carbon Fluxes","real","lon","lat","time",NA,"Heterotrophic respiration rate (always positive)" +"AutoResp","plant_respiration_carbon_flux","kg C m-2 s-1","Autotrophic Respiration","Carbon Fluxes","real","lon","lat","time",NA,"Autotrophic respiration rate (always positive)" +"HeteroResp","heterotrophic_respiration_carbon_flux","kg C m-2 s-1","Heterotrophic Respiration","Carbon Fluxes","real","lon","lat","time",NA,"Heterotrophic respiration rate (always positive)" +"SoilResp","soil_respiration_carbon_flux","kg C m-2 s-1","Soil Respiration","Carbon Fluxes","real","lon","lat","time",NA,"Sum of respiration in the soil by heterotrophs and by the roots of plants (autotrophs)" "DOC_flux",NA,"kg C m-2 s-1","Dissolved Organic Carbon flux","Carbon Fluxes","real","lon","lat","time",NA,"Loss of organic carbon dissolved in ground water or rivers (positive out of grid cell)" "Fire_flux",NA,"kg C m-2 s-1","Fire emissions","Carbon Fluxes","real","lon","lat","time",NA,"Flux of carbon due to fires (always positive)" "litter_carbon_flux","litter_carbon_flux","kg C m-2 s-1","Litter Carbon Flux","Carbon Fluxes","real","lon","lat","time",NA,"Total carbon flux of litter, excluding coarse woody debris" From 0a839326aec0a8860642b51eef2130716b7d51d9 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 31 Aug 2017 11:20:06 -0400 Subject: [PATCH 500/771] Update Changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1b95356f7b1..abf2d76d51d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,6 +16,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Cleaned up NAMESPACE and source code of `PEcAn.DB` (#1520) - Debugged python script in call_MODIS in data.remote to allow MODIS downloads - Fixed FATES build script to work on ubuntu +- SIPNET output netcdf now includes LAI; some variable names changed to match standard ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) From 995e5834b46ccd79a7e8c2398d8355037b8ac2e4 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 31 Aug 2017 11:57:09 -0400 Subject: [PATCH 501/771] Remove Year and FracJulianDay variables from sipnet output --- models/sipnet/R/model2netcdf.SIPNET.R | 84 +++++++++++++-------------- 1 file changed, 40 insertions(+), 44 deletions(-) diff --git a/models/sipnet/R/model2netcdf.SIPNET.R b/models/sipnet/R/model2netcdf.SIPNET.R index fa220093e9c..5664e1f1803 100644 --- a/models/sipnet/R/model2netcdf.SIPNET.R +++ b/models/sipnet/R/model2netcdf.SIPNET.R @@ -51,40 +51,38 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, ## Setup outputs for netCDF file in appropriate units output <- list() - output[[1]] <- sub.sipnet.output$year # Year - output[[2]] <- sub.sipnet.output$day + step # Fractional day - output[[3]] <- (sub.sipnet.output$gpp * 0.001) / timestep.s # GPP in kgC/m2/s - ## output[[4]] <- (sub.sipnet.output$npp*0.001) / timestep.s # NPP in kgC/m2/s. Internal SIPNET + output[[1]] <- (sub.sipnet.output$gpp * 0.001) / timestep.s # GPP in kgC/m2/s + ## output[[2]] <- (sub.sipnet.output$npp*0.001) / timestep.s # NPP in kgC/m2/s. Internal SIPNET ## calculation - output[[4]] <- (sub.sipnet.output$gpp * 0.001) / timestep.s - ((sub.sipnet.output$rAboveground * + output[[2]] <- (sub.sipnet.output$gpp * 0.001) / timestep.s - ((sub.sipnet.output$rAboveground * 0.001) / timestep.s + (sub.sipnet.output$rRoot * 0.001) / timestep.s) # NPP in kgC/m2/s. Post SIPNET calculation - output[[5]] <- (sub.sipnet.output$rtot * 0.001) / timestep.s # Total Respiration in kgC/m2/s - output[[6]] <- (sub.sipnet.output$rAboveground * 0.001) / timestep.s + (sub.sipnet.output$rRoot * + output[[3]] <- (sub.sipnet.output$rtot * 0.001) / timestep.s # Total Respiration in kgC/m2/s + output[[4]] <- (sub.sipnet.output$rAboveground * 0.001) / timestep.s + (sub.sipnet.output$rRoot * 0.001) / timestep.s # Autotrophic Respiration in kgC/m2/s - output[[7]] <- ((sub.sipnet.output$rSoil - sub.sipnet.output$rRoot) * 0.001) / timestep.s # Heterotrophic Respiration in kgC/m2/s - output[[8]] <- (sub.sipnet.output$rSoil * 0.001) / timestep.s # Soil Respiration in kgC/m2/s - output[[9]] <- (sub.sipnet.output$nee * 0.001) / timestep.s # NEE in kgC/m2/s - # output[[9]] <- rep(-999,sipnet.output.dims[1]) # CarbPools - output[[10]] <- (sub.sipnet.output$plantWoodC * 0.001) # Above ground wood kgC/m2 - output[[11]] <- (sub.sipnet.output$plantLeafC * 0.001) # Leaf C kgC/m2 - output[[12]] <- (sub.sipnet.output$plantWoodC * 0.001) + (sub.sipnet.output$plantLeafC * 0.001) + + output[[5]] <- ((sub.sipnet.output$rSoil - sub.sipnet.output$rRoot) * 0.001) / timestep.s # Heterotrophic Respiration in kgC/m2/s + output[[6]] <- (sub.sipnet.output$rSoil * 0.001) / timestep.s # Soil Respiration in kgC/m2/s + output[[7]] <- (sub.sipnet.output$nee * 0.001) / timestep.s # NEE in kgC/m2/s + # output[[7]] <- rep(-999,sipnet.output.dims[1]) # CarbPools + output[[8]] <- (sub.sipnet.output$plantWoodC * 0.001) # Above ground wood kgC/m2 + output[[9]] <- (sub.sipnet.output$plantLeafC * 0.001) # Leaf C kgC/m2 + output[[10]] <- (sub.sipnet.output$plantWoodC * 0.001) + (sub.sipnet.output$plantLeafC * 0.001) + (sub.sipnet.output$coarseRootC * 0.001) + (sub.sipnet.output$fineRootC * 0.001) # Total living C kgC/m2 - output[[13]] <- (sub.sipnet.output$soil * 0.001) + (sub.sipnet.output$litter * 0.001) # Total soil C kgC/m2 + output[[11]] <- (sub.sipnet.output$soil * 0.001) + (sub.sipnet.output$litter * 0.001) # Total soil C kgC/m2 if (revision == "r136") { - output[[14]] <- (sub.sipnet.output$evapotranspiration * 10 * PEcAn.data.atmosphere::get.lv()) / timestep.s # Qle W/m2 + output[[12]] <- (sub.sipnet.output$evapotranspiration * 10 * PEcAn.data.atmosphere::get.lv()) / timestep.s # Qle W/m2 } else { ## *** NOTE : npp in the sipnet output file is actually evapotranspiration, this is due to a bug in sipnet.c : *** ## *** it says "npp" in the header (written by L774) but the values being written are trackers.evapotranspiration (L806) *** ## evapotranspiration in SIPNET is cm^3 water per cm^2 of area, to convert it to latent heat units W/m2 multiply with : ## 0.01 (cm2m) * 1000 (water density, kg m-3) * latent heat of vaporization (J kg-1) ## latent heat of vaporization is not constant and it varies slightly with temperature, get.lv() returns 2.5e6 J kg-1 by default - output[[14]] <- (sub.sipnet.output$npp * 10 * get.lv()) / timestep.s # Qle W/m2 + output[[12]] <- (sub.sipnet.output$npp * 10 * get.lv()) / timestep.s # Qle W/m2 } - output[[15]] <- (sub.sipnet.output$fluxestranspiration * 10) / timestep.s # Transpiration kgW/m2/s - output[[16]] <- (sub.sipnet.output$soilWater * 10) # Soil moisture kgW/m2 - output[[17]] <- (sub.sipnet.output$soilWetnessFrac) # Fractional soil wetness - output[[18]] <- (sub.sipnet.output$snow * 10) # SWE - output[[19]] <- sub.sipnet.output$litter * 0.001 ## litter kgC/m2 + output[[13]] <- (sub.sipnet.output$fluxestranspiration * 10) / timestep.s # Transpiration kgW/m2/s + output[[14]] <- (sub.sipnet.output$soilWater * 10) # Soil moisture kgW/m2 + output[[15]] <- (sub.sipnet.output$soilWetnessFrac) # Fractional soil wetness + output[[16]] <- (sub.sipnet.output$snow * 10) # SWE + output[[17]] <- sub.sipnet.output$litter * 0.001 ## litter kgC/m2 #calculate LAI for standard output param <- read.table(file.path(gsub(pattern = "/out/", @@ -93,7 +91,7 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, id <- which(param[, 1] == "leafCSpWt") leafC <- 0.48 SLA <- 1000 * leafC / param[id, 2] #SLA, m2/kgC - output[[20]] <- output[[11]] * SLA # LAI + output[[18]] <- output[[9]] * SLA # LAI # ******************** Declare netCDF variables ********************# @@ -115,28 +113,26 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, mstmipvar <- PEcAn.utils::mstmipvar nc_var <- list() - nc_var[[1]] <- mstmipvar("Year", lat, lon, t, NA) - nc_var[[2]] <- mstmipvar("FracJulianDay", lat, lon, t, NA) - nc_var[[3]] <- PEcAn.utils::to_ncvar("GPP", dims) - nc_var[[4]] <- PEcAn.utils::to_ncvar("NPP", dims) - nc_var[[5]] <- PEcAn.utils::to_ncvar("TotalResp", dims) - nc_var[[6]] <- PEcAn.utils::to_ncvar("AutoResp", dims) - nc_var[[7]] <- PEcAn.utils::to_ncvar("HeteroResp", dims) - nc_var[[8]] <- ncdf4::ncvar_def("SoilResp", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, + nc_var[[1]] <- PEcAn.utils::to_ncvar("GPP", dims) + nc_var[[2]] <- PEcAn.utils::to_ncvar("NPP", dims) + nc_var[[3]] <- PEcAn.utils::to_ncvar("TotalResp", dims) + nc_var[[4]] <- PEcAn.utils::to_ncvar("AutoResp", dims) + nc_var[[5]] <- PEcAn.utils::to_ncvar("HeteroResp", dims) + nc_var[[6]] <- ncdf4::ncvar_def("SoilResp", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, longname = "Soil Respiration") #need to figure out standard variable for this output - nc_var[[9]] <- PEcAn.utils::to_ncvar("NEE", dims) - # nc_var[[9]] <- mstmipvar('CarbPools', lat, lon, t, NA) - nc_var[[10]] <- PEcAn.utils::to_ncvar("AbvGrndWood", dims) - nc_var[[11]] <- PEcAn.utils::to_ncvar("leaf_carbon_content", dims) - nc_var[[12]] <- PEcAn.utils::to_ncvar("TotLivBiom", dims) - nc_var[[13]] <- PEcAn.utils::to_ncvar("TotSoilCarb", dims) - nc_var[[14]] <- PEcAn.utils::to_ncvar("Qle", dims) - nc_var[[15]] <- PEcAn.utils::to_ncvar("Transp", dims) - nc_var[[16]] <- PEcAn.utils::to_ncvar("SoilMoist", dims) - nc_var[[17]] <- PEcAn.utils::to_ncvar("SoilMoistFrac", dims) - nc_var[[18]] <- PEcAn.utils::to_ncvar("SWE", dims) - nc_var[[19]] <- PEcAn.utils::to_ncvar("litter_carbon_content", dims) - nc_var[[20]] <- PEcAn.utils::to_ncvar("LAI", dims) + nc_var[[7]] <- PEcAn.utils::to_ncvar("NEE", dims) + # nc_var[[7]] <- mstmipvar('CarbPools', lat, lon, t, NA) + nc_var[[8]] <- PEcAn.utils::to_ncvar("AbvGrndWood", dims) + nc_var[[9]] <- PEcAn.utils::to_ncvar("leaf_carbon_content", dims) + nc_var[[10]] <- PEcAn.utils::to_ncvar("TotLivBiom", dims) + nc_var[[11]] <- PEcAn.utils::to_ncvar("TotSoilCarb", dims) + nc_var[[12]] <- PEcAn.utils::to_ncvar("Qle", dims) + nc_var[[13]] <- PEcAn.utils::to_ncvar("Transp", dims) + nc_var[[14]] <- PEcAn.utils::to_ncvar("SoilMoist", dims) + nc_var[[15]] <- PEcAn.utils::to_ncvar("SoilMoistFrac", dims) + nc_var[[16]] <- PEcAn.utils::to_ncvar("SWE", dims) + nc_var[[17]] <- PEcAn.utils::to_ncvar("litter_carbon_content", dims) + nc_var[[18]] <- PEcAn.utils::to_ncvar("LAI", dims) # ******************** Declare netCDF variables ********************# From 2b355d685e0a916a2c6bda4f07f51e33cdc64cbb Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 31 Aug 2017 12:09:49 -0400 Subject: [PATCH 502/771] Add namespace to get.lv --- models/sipnet/R/model2netcdf.SIPNET.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/sipnet/R/model2netcdf.SIPNET.R b/models/sipnet/R/model2netcdf.SIPNET.R index 5664e1f1803..97abc29abd3 100644 --- a/models/sipnet/R/model2netcdf.SIPNET.R +++ b/models/sipnet/R/model2netcdf.SIPNET.R @@ -76,7 +76,7 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, ## evapotranspiration in SIPNET is cm^3 water per cm^2 of area, to convert it to latent heat units W/m2 multiply with : ## 0.01 (cm2m) * 1000 (water density, kg m-3) * latent heat of vaporization (J kg-1) ## latent heat of vaporization is not constant and it varies slightly with temperature, get.lv() returns 2.5e6 J kg-1 by default - output[[12]] <- (sub.sipnet.output$npp * 10 * get.lv()) / timestep.s # Qle W/m2 + output[[12]] <- (sub.sipnet.output$npp * 10 * PEcAn.data.atmosphere::get.lv()) / timestep.s # Qle W/m2 } output[[13]] <- (sub.sipnet.output$fluxestranspiration * 10) / timestep.s # Transpiration kgW/m2/s output[[14]] <- (sub.sipnet.output$soilWater * 10) # Soil moisture kgW/m2 From dfb997aa72c11d6a5f918765e688e471490dea00 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Thu, 31 Aug 2017 12:10:18 -0400 Subject: [PATCH 503/771] change outputs to to_ncvar --- models/dalec/R/model2netcdf.DALEC.R | 42 ++++++++++++++--------------- 1 file changed, 20 insertions(+), 22 deletions(-) diff --git a/models/dalec/R/model2netcdf.DALEC.R b/models/dalec/R/model2netcdf.DALEC.R index 5c8302044a4..b32d152d58d 100644 --- a/models/dalec/R/model2netcdf.DALEC.R +++ b/models/dalec/R/model2netcdf.DALEC.R @@ -18,8 +18,6 @@ ##' @param sitelon Longitude of the site ##' @param start_date Start time of the simulation ##' @param end_date End time of the simulation -##' @importFrom ncdf4 ncvar_def ncdim_def -##' @importFrom PEcAn.utils mstmipvar to_ncvar to_ncdim ##' @export ##' @author Shawn Serbin, Michael Dietze model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { @@ -104,11 +102,11 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { if(y == lubridate::year(start_date)){ start.day <- length(as.Date(paste0(y, "-01-01")):as.Date(start_date)) } - t <- ncdim_def(name = "time", units = paste0("days since ", y, "-01-01 00:00:00"), + t <- ncdf4::ncdim_def(name = "time", units = paste0("days since ", y, "-01-01 00:00:00"), vals = start.day:(start.day + (nrow(sub.DALEC.output)-1)), calendar = "standard", unlim = TRUE) - lat <- ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") - lon <- ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") + lat <- ncdf4::ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") + lon <- ncdf4::ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") dims <- list(lon = lon, lat = lat, time = t) ## ***** Need to dynamically update the UTC offset here ***** @@ -120,24 +118,24 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { nc_var <- list() - nc_var[[1]] <- to_ncvar("AutoResp", dims) - nc_var[[2]] <- to_ncvar("HeteroResp", dims) - nc_var[[3]] <- to_ncvar("GPP", dims) - nc_var[[4]] <- to_ncvar("NEE", dims) - nc_var[[5]] <- to_ncvar("NPP", dims) - nc_var[[6]] <- to_ncvar("leaf_litter_carbon_flux", dims) #was LeafLitter - nc_var[[7]] <- to_ncvar("WoodyLitter", dims) #need to resolve standard woody litter flux - nc_var[[8]] <- to_ncvar("subsurface_litter_carbon_flux", dims) #was RootLitter - nc_var[[9]] <- to_ncvar("leaf_carbon_content", dims) #was LeafBiomass - nc_var[[10]] <- to_ncvar("wood_carbon_content", dims) #was WoodBiomass - nc_var[[11]] <- to_ncvar("root_carbon_content", dims) #was RootBiomass - nc_var[[12]] <- to_ncvar("litter_carbon_content", dims) #was LitterBiomass - nc_var[[13]] <- to_ncvar("soil_carbon_content", dims) #was SoilC; SOM pool technically includes woody debris (can't be represented by our standard) + nc_var[[1]] <- PEcAn.utils::to_ncvar("AutoResp", dims) + nc_var[[2]] <- PEcAn.utils::to_ncvar("HeteroResp", dims) + nc_var[[3]] <- PEcAn.utils::to_ncvar("GPP", dims) + nc_var[[4]] <- PEcAn.utils::to_ncvar("NEE", dims) + nc_var[[5]] <- PEcAn.utils::to_ncvar("NPP", dims) + nc_var[[6]] <- PEcAn.utils::to_ncvar("leaf_litter_carbon_flux", dims) #was LeafLitter + nc_var[[7]] <- PEcAn.utils::to_ncvar("WoodyLitter", dims) #need to resolve standard woody litter flux + nc_var[[8]] <- PEcAn.utils::to_ncvar("subsurface_litter_carbon_flux", dims) #was RootLitter + nc_var[[9]] <- PEcAn.utils::to_ncvar("leaf_carbon_content", dims) #was LeafBiomass + nc_var[[10]] <- PEcAn.utils::to_ncvar("wood_carbon_content", dims) #was WoodBiomass + nc_var[[11]] <- PEcAn.utils::to_ncvar("root_carbon_content", dims) #was RootBiomass + nc_var[[12]] <- PEcAn.utils::to_ncvar("litter_carbon_content", dims) #was LitterBiomass + nc_var[[13]] <- PEcAn.utils::to_ncvar("soil_carbon_content", dims) #was SoilC; SOM pool technically includes woody debris (can't be represented by our standard) - nc_var[[14]] <- to_ncvar("TotalResp", dims) - nc_var[[15]] <- to_ncvar("TotLivBiom", dims) - nc_var[[16]] <- to_ncvar("TotSoilCarb", dims) - nc_var[[17]] <- to_ncvar("LAI", dims) + nc_var[[14]] <- PEcAn.utils::to_ncvar("TotalResp", dims) + nc_var[[15]] <- PEcAn.utils::to_ncvar("TotLivBiom", dims) + nc_var[[16]] <- PEcAn.utils::to_ncvar("TotSoilCarb", dims) + nc_var[[17]] <- PEcAn.utils::to_ncvar("LAI", dims) # ******************** Declar netCDF variables ********************# From 5b9d2fc7362c922aa664c8ba78aa90b1650a8fe6 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Thu, 31 Aug 2017 15:30:09 -0400 Subject: [PATCH 504/771] move to to_nc definition of output --- models/dalec/R/model2netcdf.DALEC.R | 17 +++++----- models/gday/R/model2netcdf.GDAY.R | 40 ++++++++++++----------- models/linkages/R/model2netcdf.LINKAGES.R | 30 ++++++++--------- models/lpjguess/R/model2netcdf.LPJGUESS.R | 14 ++++---- models/maat/R/model2netcdf.MAAT.R | 9 ++--- models/maespa/DESCRIPTION | 3 +- models/maespa/R/model2netcdf.MAESPA.R | 26 +++++++-------- models/preles/R/runPRELES.jobsh.R | 16 +++++---- 8 files changed, 80 insertions(+), 75 deletions(-) diff --git a/models/dalec/R/model2netcdf.DALEC.R b/models/dalec/R/model2netcdf.DALEC.R index b32d152d58d..3b8c597b134 100644 --- a/models/dalec/R/model2netcdf.DALEC.R +++ b/models/dalec/R/model2netcdf.DALEC.R @@ -21,14 +21,15 @@ ##' @export ##' @author Shawn Serbin, Michael Dietze model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { - runid <- basename(outdir) DALEC.configs <- read.table(file.path(gsub(pattern = "/out/", replacement = "/run/", x = outdir), - paste0("CONFIG.",runid)), stringsAsFactors = FALSE) - + paste0("CONFIG.", runid)), + stringsAsFactors = FALSE) + ### Read in model output in DALEC format - DALEC.output <- read.table(file.path(outdir, "out.txt"), header = FALSE, sep = "") + DALEC.output <- read.table(file.path(outdir, "out.txt"), + header = FALSE, sep = "") DALEC.output.dims <- dim(DALEC.output) ### Determine number of years and output timestep @@ -43,7 +44,7 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { if (file.exists(file.path(outdir, paste(y, "nc", sep = ".")))) { next } - print(paste("---- Processing year: ", y)) # turn on for debugging + print(paste("---- Processing year: ", y)) #turn on for debugging ## Subset data for processing sub.DALEC.output <- subset(DALEC.output, year == y) @@ -78,8 +79,7 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { output[[2]] <- (sub.DALEC.output[, 21] + sub.DALEC.output[, 23]) * 0.001 / timestep.s # Heterotrophic Resp kgC/m2/s output[[3]] <- (sub.DALEC.output[, 31] * 0.001)/timestep.s # GPP in kgC/m2/s output[[4]] <- (sub.DALEC.output[, 33] * 0.001)/timestep.s # NEE in kgC/m2/s - output[[5]] <- (sub.DALEC.output[, 3] + sub.DALEC.output[, 5] + sub.DALEC.output[, 7]) * - 0.001/timestep.s # NPP kgC/m2/s + output[[5]] <- (sub.DALEC.output[, 3] + sub.DALEC.output[, 5] + sub.DALEC.output[, 7]) * 0.001/timestep.s # NPP kgC/m2/s output[[6]] <- (sub.DALEC.output[, 9] * 0.001) / timestep.s # Leaf Litter Flux, kgC/m2/s output[[7]] <- (sub.DALEC.output[, 11] * 0.001) / timestep.s # Woody Litter Flux, kgC/m2/s output[[8]] <- (sub.DALEC.output[, 13] * 0.001) / timestep.s # Root Litter Flux, kgC/m2/s @@ -99,7 +99,7 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { # ******************** Declare netCDF variables ********************# start.day <- 1 - if(y == lubridate::year(start_date)){ + if (y == lubridate::year(start_date)){ start.day <- length(as.Date(paste0(y, "-01-01")):as.Date(start_date)) } t <- ncdf4::ncdim_def(name = "time", units = paste0("days since ", y, "-01-01 00:00:00"), @@ -143,7 +143,6 @@ model2netcdf.DALEC <- function(outdir, sitelat, sitelon, start_date, end_date) { nc <- ncdf4::nc_create(file.path(outdir, paste(y, "nc", sep = ".")), nc_var) varfile <- file(file.path(outdir, paste(y, "nc", "var", sep = ".")), "w") for (i in seq_along(nc_var)) { - # print(i) ncdf4::ncvar_put(nc, nc_var[[i]], output[[i]]) cat(paste(nc_var[[i]]$name, nc_var[[i]]$longname), file = varfile, sep = "\n") } diff --git a/models/gday/R/model2netcdf.GDAY.R b/models/gday/R/model2netcdf.GDAY.R index 49b2a253896..ee0c8af4e9f 100644 --- a/models/gday/R/model2netcdf.GDAY.R +++ b/models/gday/R/model2netcdf.GDAY.R @@ -85,32 +85,34 @@ model2netcdf.GDAY <- function(outdir, sitelat, sitelon, start_date, end_date) { output[[i]] <- rep(-999, length(t$vals)) } + dims <- list(lon = lon, lat = lat, time = t) + var <- list() ## C-Fluxes - var[[1]] <- ncvar_def("AutoResp","kgC/m2/s", list(lon,lat,t), -999) - var[[2]] <- ncvar_def("HeteroResp", "kgC/m2/s", list(lon,lat,t), -999) - var[[3]] <- ncvar_def("TotalResp","kgC/m2/s", list(lon,lat,t), -999) - var[[4]] <- ncvar_def("GPP", "kgC/m2/s", list(lon,lat,t), -999) - var[[5]] <- ncvar_def("NEE", "kgC/m2/s", list(lon,lat,t), -999) - var[[6]] <- ncvar_def("NPP", "kgC/m2/s", list(lon,lat,t), -999) + var[[1]] <- PEcAn.utils::to_ncvar("AutoResp",dims) + var[[2]] <- PEcAn.utils::to_ncvar("HeteroResp", dims) + var[[3]] <- PEcAn.utils::to_ncvar("TotalResp",dims) + var[[4]] <- PEcAn.utils::to_ncvar("GPP", dims) + var[[5]] <- PEcAn.utils::to_ncvar("NEE", dims) + var[[6]] <- PEcAn.utils::to_ncvar("NPP", dims) ## C-State - var[[7]] <- ncvar_def("AbvGrndWood", "kgC/m2", list(lon,lat,t), -999) - var[[8]] <- ncvar_def("TotSoilCarb","kgC/m2", list(lon,lat,t), -999) - var[[9]] <- ncvar_def("LAI","m2/m2", list(lon,lat,t), -999) + var[[7]] <- PEcAn.utils::to_ncvar("AbvGrndWood", dims) + var[[8]] <- PEcAn.utils::to_ncvar("TotSoilCarb", dims) + var[[9]] <- PEcAn.utils::to_ncvar("LAI","m2/m2", dims) ## Water fluxes - var[[10]] <- ncvar_def("Evap", "kg/m2/s", list(lon,lat,t), -999) - var[[11]] <- ncvar_def("TVeg", "kg/m2/s",list(lon,lat,t), -999) + var[[10]] <- PEcAn.utils::to_ncvar("Evap", dims) + var[[11]] <- PEcAn.utils::to_ncvar("TVeg", dims) - #var[[6]] <- ncvar_def("LeafLitter", "kgC/m2/s", list(lon,lat,t), -999) - #var[[7]] <- ncvar_def("WoodyLitter", "kgC/m2/s", list(lon,lat,t), -999) - #var[[8]] <- ncvar_def("RootLitter", "kgC/m2/s", list(lon,lat,t), -999) - #var[[9]] <- ncvar_def("LeafBiomass", "kgC/m2", list(lon,lat,t), -999) - #var[[10]] <- ncvar_def("WoodBiomass", "kgC/m2", list(lon,lat,t), -999) - #var[[11]] <- ncvar_def("RootBiomass", "kgC/m2", list(lon,lat,t), -999) - #var[[12]] <- ncvar_def("LitterBiomass", "kgC/m2", list(lon,lat,t), -999) - #var[[13]] <- ncvar_def("SoilC", "kgC/m2", list(lon,lat,t), -999) + #var[[6]] <- PEcAn.utils::to_ncvar("LeafLitter", "kgC/m2/s", list(lon,lat,t), -999) + #var[[7]] <- PEcAn.utils::to_ncvar("WoodyLitter", "kgC/m2/s", list(lon,lat,t), -999) + #var[[8]] <- PEcAn.utils::to_ncvar("RootLitter", "kgC/m2/s", list(lon,lat,t), -999) + #var[[9]] <- PEcAn.utils::to_ncvar("LeafBiomass", "kgC/m2", list(lon,lat,t), -999) + #var[[10]] <- PEcAn.utils::to_ncvar("WoodBiomass", "kgC/m2", list(lon,lat,t), -999) + #var[[11]] <- PEcAn.utils::to_ncvar("RootBiomass", "kgC/m2", list(lon,lat,t), -999) + #var[[12]] <- PEcAn.utils::to_ncvar("LitterBiomass", "kgC/m2", list(lon,lat,t), -999) + #var[[13]] <- PEcAn.utils::to_ncvar("SoilC", "kgC/m2", list(lon,lat,t), -999) # ******************** Declare netCDF variables ********************# diff --git a/models/linkages/R/model2netcdf.LINKAGES.R b/models/linkages/R/model2netcdf.LINKAGES.R index e944f3b9c4a..646ba44a1cb 100644 --- a/models/linkages/R/model2netcdf.LINKAGES.R +++ b/models/linkages/R/model2netcdf.LINKAGES.R @@ -85,22 +85,22 @@ model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, e output[[i]] <- rep(-999, length(t$vals)) } - var <- list() - var[[1]] <- ncvar_def("AGB", "kgC/m2", list(dim.lat, dim.lon, dim.t), -999) - var[[2]] <- ncvar_def("TotLivBiomass", "kgC/m2", list(dim.lat, dim.lon, dim.t), -999) - var[[3]] <- ncvar_def("TotSoilCarb", "kgC/m2", list(dim.lat, dim.lon, dim.t), -999) - var[[4]] <- ncvar_def("CarbPools", "kgC/m2", list(dim.cpools, dim.lat, dim.lon, dim.t), -999) - var[[5]] <- ncvar_def("poolnames", units = "", dim = list(dim.string, dim.cpools1), + var <- list( + var[[1]] <- PEcAn.utils::to_ncvar("AGB", dims) + var[[2]] <- PEcAn.utils::to_ncvar("TotLivBiomass", dims) + var[[3]] <- PEcAn.utils::to_ncvar("TotSoilCarb", dims) + var[[4]] <- ncdf4::ncvar_def("CarbPools", "kgC/m2", list(dim.cpools, dim.lat, dim.lon, dim.t), -999) + var[[5]] <- ncdf4::ncvar_def("poolnames", units = "", dim = list(dim.string, dim.cpools1), longname = "Carbon Pool Names", prec = "char") - var[[6]] <- ncvar_def("GWBI", "kgC/m2", list(dim.lat, dim.lon, dim.t), -999) - var[[7]] <- ncvar_def("HeteroResp", "kgC/m2/s", list(dim.lat, dim.lon, dim.t), -999) - var[[8]] <- ncvar_def("NPP", "kgC/m2/s", list(dim.lat, dim.lon, dim.t), -999) - var[[9]] <- ncvar_def("NEE", "kgC/m2/s", list(dim.lat, dim.lon, dim.t), -999) - var[[10]] <- ncvar_def("Evap", "kg/m2/s", list(dim.lat, dim.lon, dim.t), -999) - var[[11]] <- ncvar_def("AGB.pft", "kgC/m2", list(dim.pfts, dim.lat, dim.lon, dim.t), -999) - var[[12]] <- ncvar_def("Fcomp", "kgC/kgC", list(dim.pfts, dim.lat, dim.lon, dim.t), -999) - var[[13]] <- ncvar_def("LAI", "m2/m2", list(dim.lat, dim.lon, dim.t), -999) - var[[14]] <- ncvar_def("SoilMoist", "m2/m2", list(dim.lat, dim.lon, dim.t), -999) + var[[6]] <- PEcAn.utils::to_ncvar("GWBI", dims) + var[[7]] <- PEcAn.utils::to_ncvar("HeteroResp", dims) + var[[8]] <- PEcAn.utils::to_ncvar("NPP", dims) + var[[9]] <- PEcAn.utils::to_ncvar("NEE", dims) + var[[10]] <- PEcAn.utils::to_ncvar("Evap", dims) + var[[11]] <- PEcAn.utils::to_ncvar("AGB.pft", dims) + var[[12]] <- PEcAn.utils::to_ncvar("Fcomp", dims) + var[[13]] <- PEcAn.utils::to_ncvar("LAI", dims) + var[[14]] <- PEcAn.utils::to_ncvar("SoilMoist", dims) # ******************** Declare netCDF variables ********************# diff --git a/models/lpjguess/R/model2netcdf.LPJGUESS.R b/models/lpjguess/R/model2netcdf.LPJGUESS.R index c77d60c4dd9..8d53f5269d1 100644 --- a/models/lpjguess/R/model2netcdf.LPJGUESS.R +++ b/models/lpjguess/R/model2netcdf.LPJGUESS.R @@ -99,13 +99,15 @@ model2netcdf.LPJGUESS <- function(outdir, sitelat, sitelon, start_date, end_date mstmipvar <- PEcAn.utils::mstmipvar + dims <- list(lon = lon, lat = lat, time = t) + var <- list() - var[[1]] <- mstmipvar("GPP", lat, lon, t, NA) - var[[2]] <- mstmipvar("NPP", lat, lon, t, NA) - var[[3]] <- mstmipvar("AutoResp", lat, lon, t, NA) - var[[4]] <- mstmipvar("HeteroResp", lat, lon, t, NA) - var[[5]] <- mstmipvar("NEE", lat, lon, t, NA) - var[[6]] <- mstmipvar("LAI", lat, lon, t, NA) + var[[1]] <- PEcAn.utils::to_ncvar("GPP", dims) + var[[2]] <- PEcAn.utils::to_ncvar("NPP", dims) + var[[3]] <- PEcAn.utils::to_ncvar("AutoResp", dims) + var[[4]] <- PEcAn.utils::to_ncvar("HeteroResp", dims) + var[[5]] <- PEcAn.utils::to_ncvar("NEE", dims) + var[[6]] <- PEcAn.utils::to_ncvar("LAI", dims) # ******************** Declare netCDF variables ********************# diff --git a/models/maat/R/model2netcdf.MAAT.R b/models/maat/R/model2netcdf.MAAT.R index 2ddd89e41c8..5373fba5677 100644 --- a/models/maat/R/model2netcdf.MAAT.R +++ b/models/maat/R/model2netcdf.MAAT.R @@ -103,12 +103,13 @@ model2netcdf.MAAT <- function(outdir, sitelat = -999, sitelon = -999, start_date "mol H2O m-2 s-1", "kg H2O m-2 s-1")) # stomatal_conductance in kg H2O m2 s1 + dims <- list(lon = lon, lat = lat, time = t) + ### Put output into netCDF format nc_var <- list() - nc_var[[1]] <- mstmipvar("Year", lat, lon, t, NA) - nc_var[[2]] <- mstmipvar("FracJulianDay", lat, lon, t, NA) - nc_var[[3]] <- mstmipvar("GPP", lat, lon, t, NA) - nc_var[[4]] <- mstmipvar("stomatal_conductance", lat, lon, t, NA) + nc_var[[1]] <- PEcAn.utils::to_ncvar("Year", dims) + nc_var[[3]] <- PEcAn.utils::to_ncvar("GPP", dims) + nc_var[[4]] <- PEcAn.utils::to_ncvar("stomatal_conductance", dims) ### Output netCDF data nc <- ncdf4::nc_create(file.path(outdir, paste(y, "nc", sep = ".")), nc_var) diff --git a/models/maespa/DESCRIPTION b/models/maespa/DESCRIPTION index ed262f4571d..693ffd5c64a 100644 --- a/models/maespa/DESCRIPTION +++ b/models/maespa/DESCRIPTION @@ -18,7 +18,8 @@ Imports: PEcAn.utils, lubridate (>= 1.6.0), ncdf4 (>= 1.15), - udunits2 (>= 0.11) + udunits2 (>= 0.11), + Maeswrap Suggests: coda, PEcAn.data.atmosphere, diff --git a/models/maespa/R/model2netcdf.MAESPA.R b/models/maespa/R/model2netcdf.MAESPA.R index 70263d1db68..dfcf17e93d4 100755 --- a/models/maespa/R/model2netcdf.MAESPA.R +++ b/models/maespa/R/model2netcdf.MAESPA.R @@ -28,8 +28,8 @@ model2netcdf.MAESPA <- function(outdir, sitelat, sitelon, start_date, end_date, library(Maeswrap) ### Read in model output using Maeswrap. Dayflx.dat, watbalday.dat - dayflx.dataframe <- readdayflux(filename = "Dayflx.dat") - watbalday.dataframe <- readwatbal(filename = "watbalday.dat") + dayflx.dataframe <- Maeswrap::readdayflux(filename = "Dayflx.dat") + watbalday.dataframe <- Maeswrap::readwatbal(filename = "watbalday.dat") # moles of Carbon to kilograms mole2kg_C <- 0.0120107 @@ -58,29 +58,27 @@ model2netcdf.MAESPA <- function(outdir, sitelat, sitelon, start_date, end_date, output[[5]] <- (watbalday.dataframe$qe) * 1e+06 # (Qle)latent Heat flux MJ m-2 day-1 -> W m-2 # ******************** Declare netCDF variables ********************# - t <- ncdim_def(name = "time", + t <- ncdf4::ncdim_def(name = "time", units = paste0("days since ", y, "-01-01 00:00:00"), vals = (dayflx.dataframe$DOY), calendar = "standard", unlim = TRUE) - lat <- ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") - lon <- ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") + lat <- ncdf4::ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") + lon <- ncdf4::ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") for (i in seq_along(output)) { if (length(output[[i]]) == 0) output[[i]] <- rep(-999, length(t$vals)) } - mstmipvar <- PEcAn.utils::mstmipvar + dims <- list(lon = lon, lat = lat, time = t) + var <- list() - var[[1]] <- ncvar_def("GPP", units = ("kg C m-2 s-1"), dim = list(lat, lon, t), missval = -999, - longname = "Gross Primary Production") - var[[2]] <- ncvar_def("NPP", units = ("kg C m-2 s-1"), dim = list(lat, lon, t), missval = -999, - longname = " Net Primary Production") - var[[3]] <- ncvar_def("TVeg", units = ("kg m-2 s-1"), dim = list(lat, lon, t), missval = -999, - longname = "EvapoTranpiration") - var[[4]] <- ncvar_def("Qh", units = ("W m-2"), dim = list(lat, lon, t), missval = -999, longname = "Sensible Heat Flux") - var[[5]] <- ncvar_def("Qle", units = ("W m-2"), dim = list(lat, lon, t), missval = -999, longname = "latent Heat Flux") + var[[1]] <- PEcAn.utils::to_ncvar("GPP", dims) + var[[2]] <- PEcAn.utils::to_ncvar("NPP",dims) + var[[3]] <- PEcAn.utils::to_ncvar("TVeg", dims) + var[[4]] <- PEcAn.utils::to_ncvar("Qh", dims) + var[[5]] <- PEcAn.utils::to_ncvar("Qle", dims) ### Output netCDF data nc <- ncdf4::nc_create(file.path(outdir, paste(y, "nc", sep = ".")), var) diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index c009c7357aa..499b1a8bcc3 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -179,14 +179,16 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star output[[i]] <- rep(-999, length(t$vals)) } + dims <- list(lon = lon, lat = lat, time = t) + var <- list() - var[[1]] <- mstmipvar("GPP", lat, lon, t, NA) - var[[2]] <- ncvar_def("Evapotranspiration", "kg/m2s1", list(lon, lat, t), -999) - var[[3]] <- ncvar_def("SoilMoist", "kg/m2s1", list(lat, lon, t), NA) - var[[4]] <- ncvar_def("fWE", "NA", list(lon, lat, t), -999) - var[[5]] <- ncvar_def("fW", "NA", list(lon, lat, t), -999) - var[[6]] <- ncvar_def("Evap", "kg/m2/s", list(lon, lat, t), -999) - var[[7]] <- ncvar_def("TVeg", "kg/m2/s", list(lat, lon, t), NA) + var[[1]] <- PEcAn.utils::to_ncvar("GPP",dims) + var[[2]] <- PEcAn.utils::to_ncvar("Evapotranspiration", dims) + var[[3]] <- PEcAn.utils::to_ncvar("SoilMoist", dims) + var[[4]] <- PEcAn.utils::to_ncvar("fWE", dims) + var[[5]] <- PEcAn.utils::to_ncvarf("fW", dims) + var[[6]] <- PEcAn.utils::to_ncvar("Evap", dims) + var[[7]] <- PEcAn.utils::to_ncvar("TVeg", dims) nc <- ncdf4::nc_create(file.path(outdir, paste(y, "nc", sep = ".")), var) varfile <- file(file.path(outdir, paste(y, "nc", "var", sep = ".")), "w") From 5b266c984d1254e4e520b4e0de7876cfc0cc028b Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Thu, 31 Aug 2017 15:47:15 -0400 Subject: [PATCH 505/771] mising parenthesis --- models/linkages/R/model2netcdf.LINKAGES.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/models/linkages/R/model2netcdf.LINKAGES.R b/models/linkages/R/model2netcdf.LINKAGES.R index 646ba44a1cb..17572dbe0d3 100644 --- a/models/linkages/R/model2netcdf.LINKAGES.R +++ b/models/linkages/R/model2netcdf.LINKAGES.R @@ -85,7 +85,9 @@ model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, e output[[i]] <- rep(-999, length(t$vals)) } - var <- list( + dims <- list(lon = dim.lon, lat = dim.lat, time = dim.t) + + var <- list() var[[1]] <- PEcAn.utils::to_ncvar("AGB", dims) var[[2]] <- PEcAn.utils::to_ncvar("TotLivBiomass", dims) var[[3]] <- PEcAn.utils::to_ncvar("TotSoilCarb", dims) From e3483a8901f0a73b329c3b352db82d17df963cdd Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Thu, 31 Aug 2017 16:55:18 -0400 Subject: [PATCH 506/771] delte library calls and add imports --- models/dalec/NAMESPACE | 6 ---- models/fates/NAMESPACE | 2 -- models/maespa/NAMESPACE | 1 - models/maespa/R/met2model.MAESPA.R | 50 ++++++++++++-------------- models/template/R/met2model.MODEL.R | 2 +- models/template/R/model2netcdf.MODEL.R | 2 +- models/template/R/write.config.MODEL.R | 5 ++- 7 files changed, 26 insertions(+), 42 deletions(-) diff --git a/models/dalec/NAMESPACE b/models/dalec/NAMESPACE index b4b547e53c1..2912413b08a 100644 --- a/models/dalec/NAMESPACE +++ b/models/dalec/NAMESPACE @@ -3,9 +3,3 @@ export(met2model.DALEC) export(model2netcdf.DALEC) export(write.config.DALEC) -importFrom(PEcAn.utils,mstmipvar) -importFrom(PEcAn.utils,to_ncdim) -importFrom(PEcAn.utils,to_ncvar) -importFrom(ncdf4,ncdim_def) -importFrom(ncdf4,ncvar_def) -importFrom(ncdf4,ncvar_get) diff --git a/models/fates/NAMESPACE b/models/fates/NAMESPACE index 33062b774d9..4003d35ecce 100644 --- a/models/fates/NAMESPACE +++ b/models/fates/NAMESPACE @@ -6,7 +6,5 @@ export(recurse.create) export(write.config.FATES) importFrom(ncdf4,ncatt_get) importFrom(ncdf4,ncdim_def) -importFrom(ncdf4,ncvar_add) -importFrom(ncdf4,ncvar_def) importFrom(ncdf4,ncvar_get) importFrom(ncdf4,ncvar_put) diff --git a/models/maespa/NAMESPACE b/models/maespa/NAMESPACE index 973ba8ec02e..860544e53b8 100644 --- a/models/maespa/NAMESPACE +++ b/models/maespa/NAMESPACE @@ -4,4 +4,3 @@ export(met2model.MAESPA) export(model2netcdf.MAESPA) export(write.config.MAESPA) importFrom(ncdf4,ncvar_def) -importFrom(ncdf4,ncvar_get) diff --git a/models/maespa/R/met2model.MAESPA.R b/models/maespa/R/met2model.MAESPA.R index 71151215247..00f3d5077ad 100755 --- a/models/maespa/R/met2model.MAESPA.R +++ b/models/maespa/R/met2model.MAESPA.R @@ -26,12 +26,9 @@ ##' @param verbose should the function be very verbose ##' ##' @author Tony Gardella -##' @importFrom ncdf4 ncvar_get met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { - library(PEcAn.utils) - print("START met2model.MAESPA") start.date <- as.POSIXlt(start_date, tz = "GMT") end.date <- as.POSIXlt(end_date, tz = "GMT") @@ -60,10 +57,7 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date PEcAn.logger::logger.debug("File '", out.file.full, "' already exists, skipping to next file.") return(invisible(results)) } - - library(PEcAn.data.atmosphere) - library(Maeswrap) - + ## check to see if the outfolder is defined, if not create directory for output if (!file.exists(outfolder)) { dir.create(outfolder) @@ -97,18 +91,18 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date # Check which variables are available and which are not ## extract variables - lat <- ncvar_get(nc, "latitude") - lon <- ncvar_get(nc, "longitude") - RAD <- ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") #W m-2 - PAR <- try(ncvar_get(nc, "surface_downwelling_photosynthetic_photon_flux_in_air")) #mol m-2 s-1 - TAIR <- ncvar_get(nc, "air_temperature") # K - QAIR <- ncvar_get(nc, "specific_humidity") # 1 - PPT <- ncvar_get(nc, "precipitation_flux") #kg m-2 s-1 - CA <- try(ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air")) #mol/mol - PRESS <- ncvar_get(nc, "air_pressure") # Pa + lat <- ncdf4::ncvar_get(nc, "latitude") + lon <- ncdf4::ncvar_get(nc, "longitude") + RAD <- ncdf4::ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") #W m-2 + PAR <- try(ncdf4::ncvar_get(nc, "surface_downwelling_photosynthetic_photon_flux_in_air")) #mol m-2 s-1 + TAIR <- ncdf4::ncvar_get(nc, "air_temperature") # K + QAIR <- ncdf4::ncvar_get(nc, "specific_humidity") # 1 + PPT <- ncdf4::ncvar_get(nc, "precipitation_flux") #kg m-2 s-1 + CA <- try(ncdf4::ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air")) #mol/mol + PRESS <- ncdf4::ncvar_get(nc, "air_pressure") # Pa ## Convert specific humidity to fractional relative humidity - RH <- qair2rh(QAIR, TAIR, PRESS) + RH <- PEcAn.data.atmosphere::qair2rh(QAIR, TAIR, PRESS) ## Process PAR if (!is.numeric(PAR)) { @@ -186,17 +180,17 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date ## Write output met.dat file metfile <- system.file("met.dat", package = "PEcAn.MAESPA") - met.dat <- replacemetdata(out, oldmetfile = metfile, newmetfile = out.file.full) - - replacePAR(out.file.full, "difsky", "environ", newval = difsky, noquotes = TRUE) - replacePAR(out.file.full, "ca", "environ", newval = defaultCO2, noquotes = TRUE) - replacePAR(out.file.full, "lat", "latlong", newval = lat, noquotes = TRUE) - replacePAR(out.file.full, "long", "latlong", newval = lon, noquotes = TRUE) - replacePAR(out.file.full, "lonhem", "latlong", newval = lonunits, noquotes = TRUE) - replacePAR(out.file.full, "lathem", "latlong", newval = latunits, noquotes = TRUE) - replacePAR(out.file.full, "startdate", "metformat", newval = startdate, noquotes = TRUE) - replacePAR(out.file.full, "enddate", "metformat", newval = enddate, noquotes = TRUE) - replacePAR(out.file.full, "columns", "metformat", newval = columnnames, noquotes = TRUE) + met.dat <- Maeswrap::replacemetdata(out, oldmetfile = metfile, newmetfile = out.file.full) + + Maeswrap::replacePAR(out.file.full, "difsky", "environ", newval = difsky, noquotes = TRUE) + Maeswrap::replacePAR(out.file.full, "ca", "environ", newval = defaultCO2, noquotes = TRUE) + Maeswrap::replacePAR(out.file.full, "lat", "latlong", newval = lat, noquotes = TRUE) + Maeswrap::replacePAR(out.file.full, "long", "latlong", newval = lon, noquotes = TRUE) + Maeswrap::replacePAR(out.file.full, "lonhem", "latlong", newval = lonunits, noquotes = TRUE) + Maeswrap::replacePAR(out.file.full, "lathem", "latlong", newval = latunits, noquotes = TRUE) + Maeswrap::replacePAR(out.file.full, "startdate", "metformat", newval = startdate, noquotes = TRUE) + Maeswrap::replacePAR(out.file.full, "enddate", "metformat", newval = enddate, noquotes = TRUE) + Maeswrap::replacePAR(out.file.full, "columns", "metformat", newval = columnnames, noquotes = TRUE) return(invisible(results)) } # met2model.MAESPA diff --git a/models/template/R/met2model.MODEL.R b/models/template/R/met2model.MODEL.R index f1addf0fae3..eadfaed7d33 100644 --- a/models/template/R/met2model.MODEL.R +++ b/models/template/R/met2model.MODEL.R @@ -24,7 +24,7 @@ met2model.MODEL <- function(in.path, in.prefix, outfolder, overwrite = FALSE) { PEcAn.logger::logger.severe("NOT IMPLEMENTED") # Please follow the PEcAn style guide: - # https://pecan.gitbooks.io/pecan-documentation/content/developers_guide/Coding_style.html + # https://pecanproject.github.io/pecan-documentation/master/coding-style.html # Note that `library()` calls should _never_ appear here; instead, put # packages dependencies in the DESCRIPTION file, under "Imports:". diff --git a/models/template/R/model2netcdf.MODEL.R b/models/template/R/model2netcdf.MODEL.R index dd99580ea70..230deb181da 100644 --- a/models/template/R/model2netcdf.MODEL.R +++ b/models/template/R/model2netcdf.MODEL.R @@ -25,7 +25,7 @@ model2netcdf.MODEL <- function(outdir, sitelat, sitelon, start_date, end_date) { PEcAn.logger::logger.severe("NOT IMPLEMENTED") # Please follow the PEcAn style guide: - # https://pecan.gitbooks.io/pecan-documentation/content/developers_guide/Coding_style.html + # https://pecanproject.github.io/pecan-documentation/develop/coding-style.html # Note that `library()` calls should _never_ appear here; instead, put # packages dependencies in the DESCRIPTION file, under "Imports:". diff --git a/models/template/R/write.config.MODEL.R b/models/template/R/write.config.MODEL.R index 2b5ab0fa687..631edf9f904 100644 --- a/models/template/R/write.config.MODEL.R +++ b/models/template/R/write.config.MODEL.R @@ -24,10 +24,9 @@ ##' @author Rob Kooper ##-------------------------------------------------------------------------------------------------# write.config.MODEL <- function(defaults, trait.values, settings, run.id) { - + PEcAn.logger::logger.severe("NOT IMPLEMENTED") # Please follow the PEcAn style guide: - # https://pecan.gitbooks.io/pecan-documentation/content/developers_guide/Coding_style.html - + # https://pecanproject.github.io/pecan-documentation/develop/coding-style.html # Note that `library()` calls should _never_ appear here; instead, put # packages dependencies in the DESCRIPTION file, under "Imports:". # Calls to dependent packages should use a double colon, e.g. From 9b5ebb07a5607faf0db86cb022384834e1f3678c Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 31 Aug 2017 17:23:30 -0400 Subject: [PATCH 507/771] Change expected date inputs to standard date format --- modules/data.remote/R/call_MODIS.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/modules/data.remote/R/call_MODIS.R b/modules/data.remote/R/call_MODIS.R index 8a73f9beef6..d5d3e739ac5 100644 --- a/modules/data.remote/R/call_MODIS.R +++ b/modules/data.remote/R/call_MODIS.R @@ -5,8 +5,8 @@ ##' @export ##' @param outfolder where the output file will be stored ##' @param fname name of netcdf file to output -##' @param start first date in year and day-of-year. For example May 1 2010 would be 2010121 -##' @param end laste date in year and day-of-year. For example May 1 2010 would be 2010121 +##' @param start_date beginning of date range for LAI download in unambiguous date format +##' @param end_date end of date range for LAI download in unambiguous date format ##' @param lat Latitude of the pixel ##' @param lon Longitude of the pixel ##' @param size NS and WE distance in km to be included @@ -23,9 +23,11 @@ ##' test <- call_MODIS(start="2001001",end="2016366",lat=44.0646,lon=-71.28808,size=3,qc_band = "FparLai_QC",sd_band = "LaiStdDev_1km") ##' } ##' -call_MODIS <- function(outfolder = ".", fname = "m_data.nc", start, end, lat, lon, size = 0, +call_MODIS <- function(outfolder = ".", fname = "m_data.nc", start_date, end_date, lat, lon, size = 0, product = "MOD15A2", band = "Lai_1km", qc_band = NA, sd_band = NA, verbose = TRUE) { + start = strftime(as.Date(start_date),'%Y%j') + end = strftime(as.Date(end_date),'%Y%j') # library(MODISTools) # # dat <- MODISTools::GetSubset(Lat=lat, Long=lon, Product=product, Band=band, @@ -102,6 +104,7 @@ call_MODIS <- function(outfolder = ".", fname = "m_data.nc", start, end, lat, lo k <- NA } date <- rPython::python.get("date") + #date = strptime(date, format='%Y%j',tz = 'UTC') %>% as.POSIXct() return(invisible(list(m = m, k = k, date = date))) } # call_MODIS From 0e66fcb95c05a9340523f91859d01c408e7eba8d Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 31 Aug 2017 17:29:36 -0400 Subject: [PATCH 508/771] Update documentation --- modules/data.remote/man/call_MODIS.Rd | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/modules/data.remote/man/call_MODIS.Rd b/modules/data.remote/man/call_MODIS.Rd index 87114d72046..2641a50ce3a 100644 --- a/modules/data.remote/man/call_MODIS.Rd +++ b/modules/data.remote/man/call_MODIS.Rd @@ -4,8 +4,8 @@ \alias{call_MODIS} \title{call_MODIS} \usage{ -call_MODIS(outfolder = ".", fname = "m_data.nc", start, end, lat, lon, - size = 0, product = "MOD15A2", band = "Lai_1km", qc_band = NA, +call_MODIS(outfolder = ".", fname = "m_data.nc", start_date, end_date, lat, + lon, size = 0, product = "MOD15A2", band = "Lai_1km", qc_band = NA, sd_band = NA, verbose = TRUE) } \arguments{ @@ -13,9 +13,9 @@ call_MODIS(outfolder = ".", fname = "m_data.nc", start, end, lat, lon, \item{fname}{name of netcdf file to output} -\item{start}{first date in year and day-of-year. For example May 1 2010 would be 2010121} +\item{start_date}{beginning of date range for LAI download in unambiguous date format} -\item{end}{laste date in year and day-of-year. For example May 1 2010 would be 2010121} +\item{end_date}{end of date range for LAI download in unambiguous date format} \item{lat}{Latitude of the pixel} From 558efafd974d30f25d2cd92d0368b1d1f5bcce0f Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 31 Aug 2017 17:21:05 -0500 Subject: [PATCH 509/771] ED: New, working ED integration test. --- models/ed/tests/test_ed_integration.R | 4 ++ tests/pecan64.ed.xml | 100 +++++++++++++++++--------- 2 files changed, 69 insertions(+), 35 deletions(-) create mode 100644 models/ed/tests/test_ed_integration.R diff --git a/models/ed/tests/test_ed_integration.R b/models/ed/tests/test_ed_integration.R new file mode 100644 index 00000000000..eabeb6b2cd1 --- /dev/null +++ b/models/ed/tests/test_ed_integration.R @@ -0,0 +1,4 @@ +devtools::load_all("models/ed") + +commandArgs <- function(...) "~/pecan/tests/pecan64.ed.xml" +source("~/pecan/web/workflow.R") diff --git a/tests/pecan64.ed.xml b/tests/pecan64.ed.xml index c03ab69d656..19e91c2253f 100644 --- a/tests/pecan64.ed.xml +++ b/tests/pecan64.ed.xml @@ -1,10 +1,10 @@ - pecan + /home/carya/pecan_tests/pecan64.ed.xml - PostgreSQL + PostgreSQL bety bety localhost @@ -15,35 +15,38 @@ - ebifarm.c4grass.doe_vd + temperate.Late_Conifer + + 1 + + + + temperate.Northern_Pine + + 2 + + + + temperate.Southern_Pine + + 3 + 3000 FALSE - 1.2 - AUTO + 1 NPP - - - /usr/local/bin/ed2.r82 - ED2 - 82 + 5000000001 + ED2IN.rgit 0.01 @@ -57,25 +60,52 @@ - 76 - 2004-01-01 00:00:00 - 2009-12-31 23:59:59 + 772 + 1998-01-01 06:00:00 + 2008-01-01 05:00:00 + Niwot Ridge Forest/LTER NWT1 (US-NR1) + 40.0329 + -105.546 - /home/carya/sites/ebifarm/ED_MET_DRIVER_HEADER - /home/carya/oge2OLD/OGE2_ - /home/carya/faoOLD/FAO_ - /home/carya/sites/ebifarm/ebifarm.lat40.0lon-88.0.pss - /home/carya/sites/ebifarm/ebifarm.lat40.0lon-88.0.css - /home/carya/sites/ebifarm/ebifarm.lat40.0lon-88.0.site - /home/carya/ed_inputs/glu - /home/carya/ed_inputs + + 186 + /home/carya/sites/niwot/NR1.NACP.lat40.5lon-105.5.css + + + 187 + /home/carya/sites/niwot/NR1.NACP.lat40.5lon-105.5.pss + + + 188 + /home/carya/sites/niwot/NR1.NACP.lat40.5lon-105.5.site + + + 112 + /home/carya/sites/niwot/ED_MET_DRIVER_HEADER + + + 294 + /home/carya/ed_inputs/glu/ + + + 297 + /home/carya/faoOLD/FAO_ + + + 295 + /home/carya/ed_inputs/ + + + 296 + /home/carya/oge2OLD/OGE2_ + - 2006/01/01 - 2006/12/31 - - localhost - - pecan/dbfiles + 2004/01/01 + 2004/12/31 + + localhost + + pecan/dbfiles From 385ef3dcbddd131b286f825332555627c50f94b9 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 31 Aug 2017 20:31:00 -0400 Subject: [PATCH 510/771] Reformat netcdf in modisWSDL.py + add date conversion function --- modules/data.remote/inst/modisWSDL.py | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 0f10435953d..b414902b818 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -340,15 +340,21 @@ def modisClient( client=None, product=None, band=None, lat=None, lon=None, start # m_data[:] = data # rootgrp.close() +def dateInt_to_posix(date): + import datetime + temp =datetime.datetime.strptime(date, '%Y%j') + return temp.strftime('%Y-%m-%d') -def m_data_to_netCDF(filename, m, k): +def m_data_to_netCDF(filename, m, k, kmLR, kmAB): rootgrp = netCDF4.Dataset(filename, 'w', format='NETCDF4') - rootgrp.createDimension('ncol', m.data.shape[1]) - rootgrp.createDimension('nrow', m.data.shape[0]) - rootgrp.createDimension('dates', len(m.dateInt)) - m_data = rootgrp.createVariable('LAI', 'f8', ('nrow', 'ncol')) - m_std = rootgrp.createVariable('LAIStd', 'f8', ('nrow', 'ncol')) - m_date = rootgrp.createVariable('Dates', 'i8', ('dates')) + nrow = 1 + 2*kmAB + ncol = 1 + 2*kmLR + rootgrp.createDimension('nrow', nrow) + rootgrp.createDimension('ncol', ncol) + rootgrp.createDimension('time', len(m.dateInt)) + m_data = rootgrp.createVariable('LAI', 'f8', ('nrow', 'ncol','time')) + m_std = rootgrp.createVariable('LAIStd', 'f8', ('nrow', 'ncol','time')) + m_date = rootgrp.createVariable('Dates', 'i8', ('time')) m_data[:] = m.data __debugPrint( "populated LAI data in netcdf" ) if k is not None: From b66b6741bbd0634448380cd3a609d4062af172b7 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 31 Aug 2017 20:35:29 -0400 Subject: [PATCH 511/771] Update netcdf function call --- modules/data.remote/inst/modisWSDL.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index b414902b818..96cd3b52b5c 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -414,7 +414,7 @@ def run_main(start_date=2004001, end_date=2004017, la=45.92, lo=-90.45, kmAB=0, if DEBUG_PRINTING: printModisData( m ) - m_data_to_netCDF(fname, m, k) + m_data_to_netCDF(fname, m, k, kmLR, kmAB) # print(len(m.data)) # print(len(k.data)) From 6937d73b7151ebb58aa926b7afbc2a9c8ce30f90 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Wed, 30 Aug 2017 01:15:34 -0400 Subject: [PATCH 512/771] quiet spurious "no visible binding" on check --- models/biocro/R/met2model.BIOCRO.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/models/biocro/R/met2model.BIOCRO.R b/models/biocro/R/met2model.BIOCRO.R index 47d6b97be71..857e5243b5d 100644 --- a/models/biocro/R/met2model.BIOCRO.R +++ b/models/biocro/R/met2model.BIOCRO.R @@ -173,16 +173,16 @@ cf2biocro <- function(met, longitude = NULL, zulu2solarnoon = FALSE) { } ## Convert RH from percent to fraction BioCro functions just to confirm - if (met[, max(relative_humidity) > 1]) { - met[, `:=`(relative_humidity = relative_humidity/100)] + if (met[, max(met$relative_humidity) > 1]) { + met$relative_humidity = met$relative_humidity/100 } newmet <- met[, list(year = lubridate::year(date), doy = lubridate::yday(date), hour = round(lubridate::hour(date) + lubridate::minute(date) / 60, 0), SolarR = ppfd, - Temp = udunits2::ud.convert(air_temperature, "Kelvin", "Celsius"), - RH = relative_humidity, + Temp = udunits2::ud.convert(met$air_temperature, "Kelvin", "Celsius"), + RH = met$relative_humidity, WS = wind_speed, - precip = udunits2::ud.convert(precipitation_flux, "s-1", "h-1"))][hour <= 23] + precip = udunits2::ud.convert(met$precipitation_flux, "s-1", "h-1"))][hour <= 23] return(as.data.frame(newmet)) } # cf2biocro From c4ae6e0b4cbd1f755171ac0478c94f337ab5ab50 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 31 Aug 2017 22:08:29 -0400 Subject: [PATCH 513/771] include source df name to avoid "no visible binding..." warning --- models/biocro/R/model2netcdf.BIOCRO.R | 2 +- models/biocro/R/run.biocro.R | 50 +++++++++++++++------------ 2 files changed, 28 insertions(+), 24 deletions(-) diff --git a/models/biocro/R/model2netcdf.BIOCRO.R b/models/biocro/R/model2netcdf.BIOCRO.R index d46699b016c..8e7b9bd9327 100644 --- a/models/biocro/R/model2netcdf.BIOCRO.R +++ b/models/biocro/R/model2netcdf.BIOCRO.R @@ -46,7 +46,7 @@ model2netcdf.BIOCRO <- function(result, genus = NULL, outdir, lat = -9999, lon = unlim = TRUE) for (yeari in unique(result$Year)) { - result_yeari <- result[Year == yeari] + result_yeari <- result[result$Year == yeari] dates <- lubridate::ymd(paste0(result_yeari$Year, "-01-01")) + lubridate::days(as.numeric(result_yeari$DayofYear - 1)) + lubridate::hours(result_yeari$Hour) days_since_origin <- dates - lubridate::ymd_hms("1700-01-01 00:00:00") diff --git a/models/biocro/R/run.biocro.R b/models/biocro/R/run.biocro.R index 3f9a4904e3d..7980b17c984 100644 --- a/models/biocro/R/run.biocro.R +++ b/models/biocro/R/run.biocro.R @@ -160,31 +160,35 @@ run.biocro <- function(lat, lon, metpath, soil.nc = NULL, config = config, coppi } hourly.results <- do.call("rbind", hourly.results) - hourly.results <- hourly.results[order(year, doy, hour)] + hourly.results <- hourly.results[order(hourly.results$year, hourly.results$doy, hourly.results$hour),] - daily.results <- hourly.results[, list(Stem = max(Stem), - Leaf = max(Leaf), - Root = max(Root), - AboveLitter = max(AboveLitter), - BelowLitter = max(BelowLitter), - Rhizome = max(Rhizome), - SoilEvaporation = sum(SoilEvaporation), - CanopyTrans = sum(CanopyTrans), - Grain = max(Grain), - LAI = max(LAI), - tmax = max(Temp), tmin = min(Temp), tavg = mean(Temp), - precip = sum(precip)), by = "year,doy"] + daily.results <- hourly.results[, list(Stem = max(hourly.results$Stem), + Leaf = max(hourly.results$Leaf), + Root = max(hourly.results$Root), + AboveLitter = max(hourly.results$AboveLitter), + BelowLitter = max(hourly.results$BelowLitter), + Rhizome = max(hourly.results$Rhizome), + SoilEvaporation = sum(hourly.results$SoilEvaporation), + CanopyTrans = sum(hourly.results$CanopyTrans), + Grain = max(hourly.results$Grain), + LAI = max(hourly.results$LAI), + tmax = max(hourly.results$Temp), + tmin = min(hourly.results$Temp), + tavg = mean(hourly.results$Temp), + precip = sum(hourly.results$precip)), + by = "year,doy"] - annual.results <- hourly.results[, list(Stem = max(Stem), - Leaf = max(Leaf), - Root = max(Root), - AboveLitter = max(AboveLitter), - BelowLitter = max(BelowLitter), - Rhizome = max(Rhizome), - Grain = max(Grain), - SoilEvaporation = sum(SoilEvaporation), - CanopyTrans = sum(CanopyTrans), - map = sum(precip), mat = mean(Temp)), + annual.results <- hourly.results[, list(Stem = max(hourly.results$Stem), + Leaf = max(hourly.results$Leaf), + Root = max(hourly.results$Root), + AboveLitter = max(hourly.results$AboveLitter), + BelowLitter = max(hourly.results$BelowLitter), + Rhizome = max(hourly.results$Rhizome), + Grain = max(hourly.results$Grain), + SoilEvaporation = sum(hourly.results$SoilEvaporation), + CanopyTrans = sum(hourly.results$CanopyTrans), + map = sum(hourly.results$precip), + mat = mean(hourly.results$Temp)), by = "year"] return(list(hourly = hourly.results, daily = daily.results, From f859771a015de5f0e1717e550de50566010b828d Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 31 Aug 2017 22:14:01 -0400 Subject: [PATCH 514/771] skip data.table conversion --- models/biocro/R/run.biocro.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/biocro/R/run.biocro.R b/models/biocro/R/run.biocro.R index 7980b17c984..caf7f4b1215 100644 --- a/models/biocro/R/run.biocro.R +++ b/models/biocro/R/run.biocro.R @@ -46,8 +46,8 @@ run.biocro <- function(lat, lon, metpath, soil.nc = NULL, config = config, coppi day1 <- lubridate::yday(config$simulationPeriod$dateofplanting) dayn <- lubridate::yday(config$simulationPeriod$dateofharvest) } else if (lat > 0) { - day1 <- as.numeric(as.data.table(WetDat)[doy < 180 & Temp < -2, list(day1 = max(doy))]) - dayn <- as.numeric(as.data.table(WetDat)[doy > 180 & Temp < -2, list(day1 = min(doy))]) + day1 <- max(WetDat[ (WetDat[,"doy"] < 180 & WetDat[,"Temp"] < -2), "doy"]) + dayn <- min(WetDat[ (WetDat[,"doy"] > 180 & WetDat[,"Temp"] < -2), "doy"]) ## day1 = last spring frost dayn = first fall frost from Miguez et al 2009 } else { day1 <- NULL From 7f2b99aa1b1372c4eb668825b463a180a0f22e3c Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 31 Aug 2017 22:15:18 -0400 Subject: [PATCH 515/771] specify namespace --- models/biocro/R/run.biocro.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/biocro/R/run.biocro.R b/models/biocro/R/run.biocro.R index caf7f4b1215..76237d4f76c 100644 --- a/models/biocro/R/run.biocro.R +++ b/models/biocro/R/run.biocro.R @@ -63,7 +63,7 @@ run.biocro <- function(lat, lon, metpath, soil.nc = NULL, config = config, coppi # If not, rescale day1 and dayn to be relative to the start of the input. # Scaling is derived by inverting Biocro's day->index equations. biocro_checks_doy <- tryCatch( - {m <- BioGro(WetDat = matrix(c(0,10,0,0,0,0,0,0),nrow = 1), + {m <- BioCro::BioGro(WetDat = matrix(c(0,10,0,0,0,0,0,0),nrow = 1), day1 = 10, dayn = 10, timestep = 24); class(m) == "BioGro"}, error = function(e){FALSE}) From 3f0214b9ac3c7e004b0b94f5a89c506763b1816b Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 31 Aug 2017 22:15:38 -0400 Subject: [PATCH 516/771] typo --- models/biocro/R/write.configs.BIOCRO.R | 2 +- models/biocro/man/convert.samples.BIOCRO.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/models/biocro/R/write.configs.BIOCRO.R b/models/biocro/R/write.configs.BIOCRO.R index d5bd43a20f6..42298dda144 100644 --- a/models/biocro/R/write.configs.BIOCRO.R +++ b/models/biocro/R/write.configs.BIOCRO.R @@ -12,7 +12,7 @@ PREFIX_XML <- "\n\ ##------------------------------------------------------------------------------------------------# ##' convert parameters from PEcAn database default units to biocro defaults ##' -##' Performs model specific unit conversions on a a list of trait values, +##' Performs model specific unit conversions on a list of trait values, ##' such as those provided to write.config ##' @name convert.samples.BIOCRO ##' @title Convert samples for biocro diff --git a/models/biocro/man/convert.samples.BIOCRO.Rd b/models/biocro/man/convert.samples.BIOCRO.Rd index 43cc0e00517..3ecde863214 100644 --- a/models/biocro/man/convert.samples.BIOCRO.Rd +++ b/models/biocro/man/convert.samples.BIOCRO.Rd @@ -16,7 +16,7 @@ matrix or dataframe with values transformed convert parameters from PEcAn database default units to biocro defaults } \details{ -Performs model specific unit conversions on a a list of trait values, +Performs model specific unit conversions on a list of trait values, such as those provided to write.config } \author{ From 347429eaf0463372d36b6a01db88f40678c8b6e7 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 31 Aug 2017 22:26:04 -0400 Subject: [PATCH 517/771] do unit conversions without transform() --- models/biocro/R/write.configs.BIOCRO.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/biocro/R/write.configs.BIOCRO.R b/models/biocro/R/write.configs.BIOCRO.R index 42298dda144..87c66dddfdf 100644 --- a/models/biocro/R/write.configs.BIOCRO.R +++ b/models/biocro/R/write.configs.BIOCRO.R @@ -46,10 +46,10 @@ convert.samples.BIOCRO <- function(trait.samples) { ## transform values with different units cuticular conductance - BETY default is ## umol; BioCro uses mol if ("b0" %in% trait.names) { - trait.samples <- transform(trait.samples, b0 = udunits2::ud.convert(b0, "umol", "mol")) + trait.samples$b0 = udunits2::ud.convert(trait.samples$b0, "umol", "mol") } if ("Sp" %in% trait.names) { - trait.samples <- transform(trait.samples, Sp = udunits2::ud.convert(Sp, "kg/m2", "g/cm2")) + trait.samples$Sp = udunits2::ud.convert(trait.samples$Sp, "kg/m2", "g/cm2") } if ("vmax" %in% trait.names) { ## HAAAACK From acbaa51b73ca88656bb2f1e941098a19372d29db Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 31 Aug 2017 22:30:26 -0400 Subject: [PATCH 518/771] remove no-op identity transforms ...These ARE no-ops, right? Please check my work carefully. --- models/biocro/R/write.configs.BIOCRO.R | 8 -------- 1 file changed, 8 deletions(-) diff --git a/models/biocro/R/write.configs.BIOCRO.R b/models/biocro/R/write.configs.BIOCRO.R index 87c66dddfdf..162e7551b71 100644 --- a/models/biocro/R/write.configs.BIOCRO.R +++ b/models/biocro/R/write.configs.BIOCRO.R @@ -51,14 +51,6 @@ convert.samples.BIOCRO <- function(trait.samples) { if ("Sp" %in% trait.names) { trait.samples$Sp = udunits2::ud.convert(trait.samples$Sp, "kg/m2", "g/cm2") } - if ("vmax" %in% trait.names) { - ## HAAAACK - trait.samples <- transform(trait.samples, vmax = vmax) - } - if ("Rd" %in% trait.names) { - ## HAAAACK - trait.samples <- transform(trait.samples, Rd = Rd) - } # kd = k*omega from $e^{-kL\omega}$, if (all(c('kd', 'clumping') %in% # trait.names)) { trait.samples <- transform(trait.samples, kd = clumping * kd, From 0ad2fcc77b066761d428ca08a0982306f9d88f7e Mon Sep 17 00:00:00 2001 From: Chris Black Date: Fri, 1 Sep 2017 04:53:43 -0400 Subject: [PATCH 519/771] WIP: remove library() calls --- models/biocro/NAMESPACE | 1 - models/biocro/R/model2netcdf.BIOCRO.R | 14 +++++++------- models/biocro/R/run.biocro.R | 5 ++--- models/biocro/R/write.configs.BIOCRO.R | 2 +- models/biocro/inst/biocro.Rscript | 16 +++++----------- models/biocro/tests/testthat.R | 2 +- 6 files changed, 16 insertions(+), 24 deletions(-) diff --git a/models/biocro/NAMESPACE b/models/biocro/NAMESPACE index 89bbe179aa1..d22030b66cb 100644 --- a/models/biocro/NAMESPACE +++ b/models/biocro/NAMESPACE @@ -14,5 +14,4 @@ import(data.table) importFrom(PEcAn.data.atmosphere,par2ppfd) importFrom(PEcAn.data.atmosphere,qair2rh) importFrom(PEcAn.data.atmosphere,sw2par) -importFrom(PEcAn.data.land,get.soil) importFrom(data.table,":=") diff --git a/models/biocro/R/model2netcdf.BIOCRO.R b/models/biocro/R/model2netcdf.BIOCRO.R index d46699b016c..1990c8ac23b 100644 --- a/models/biocro/R/model2netcdf.BIOCRO.R +++ b/models/biocro/R/model2netcdf.BIOCRO.R @@ -61,13 +61,13 @@ model2netcdf.BIOCRO <- function(result, genus = NULL, outdir, lat = -9999, lon = } } - vars <- list(NPP = mstmipvar("NPP", x, y, t), - TotLivBiom = mstmipvar("TotLivBiom", x, y, t), - RootBiom = mstmipvar("RootBiom", x, y, t), - StemBiom = mstmipvar("StemBiom", x, y, t), - Evap = mstmipvar("Evap", x, y, t), - TVeg = mstmipvar("TVeg", x, y, t), - LAI = mstmipvar("LAI", x, y, t)) + vars <- list(NPP = PEcAn.utils::mstmipvar("NPP", x, y, t), + TotLivBiom = PEcAn.utils::mstmipvar("TotLivBiom", x, y, t), + RootBiom = PEcAn.utils::mstmipvar("RootBiom", x, y, t), + StemBiom = PEcAn.utils::mstmipvar("StemBiom", x, y, t), + Evap = PEcAn.utils::mstmipvar("Evap", x, y, t), + TVeg = PEcAn.utils::mstmipvar("TVeg", x, y, t), + LAI = PEcAn.utils::mstmipvar("LAI", x, y, t)) biomass2c <- 0.4 k <- udunits2::ud.convert(1, "Mg/ha", "kg/m2") * biomass2c diff --git a/models/biocro/R/run.biocro.R b/models/biocro/R/run.biocro.R index 3f9a4904e3d..24a84ea60b0 100644 --- a/models/biocro/R/run.biocro.R +++ b/models/biocro/R/run.biocro.R @@ -9,7 +9,6 @@ #' @param coppice.interval numeric, number of years between cuttings for coppice plant or perinneal grass (default 1) #' @return output from one of the \code{BioCro::*.Gro} functions (determined by \code{config$genus}), as data.table object #' @export -#' @importFrom PEcAn.data.land get.soil #' @import data.table #' @author David LeBauer run.biocro <- function(lat, lon, metpath, soil.nc = NULL, config = config, coppice.interval = 1) { @@ -20,7 +19,7 @@ run.biocro <- function(lat, lon, metpath, soil.nc = NULL, config = config, coppi years <- lubridate::year(start.date):lubridate::year(end.date) if (!is.null(soil.nc)) { - soil <- get.soil(lat = lat, lon = lon, soil.nc = soil.nc) + soil <- PEcAn.data.land::get.soil(lat = lat, lon = lon, soil.nc = soil.nc) config$pft$soilControl$soilType <- ifelse(soil$usda_class %in% 1:10, soil$usda_class, 10) @@ -33,7 +32,7 @@ run.biocro <- function(lat, lon, metpath, soil.nc = NULL, config = config, coppi starti <- max(start.date, lubridate::ymd(paste0(yeari, "-01-01"))) endi <- min(end.date, lubridate::ymd(paste0(yeari, "-12-31"))) metfile <- paste(metpath, yeari, "csv", sep = ".") - WetDat <- fread(metfile) + WetDat <- data.table::fread(metfile) WetDat <- WetDat[WetDat$doy >= lubridate::yday(starti) & WetDat$doy <= lubridate::yday(endi), ] # Check that all variables are present in the expected order -- diff --git a/models/biocro/R/write.configs.BIOCRO.R b/models/biocro/R/write.configs.BIOCRO.R index d5bd43a20f6..665c16b0075 100644 --- a/models/biocro/R/write.configs.BIOCRO.R +++ b/models/biocro/R/write.configs.BIOCRO.R @@ -160,7 +160,7 @@ write.config.BIOCRO <- function(defaults = NULL, trait.values, settings, run.id) strip.white = TRUE)))) { if (sum(unused.traits) > 0) { PEcAn.logger::logger.warn("the following traits parameters are not added to config file:", - vecpaste(names(unused.traits)[unused.traits == TRUE])) + PEcAn.utils::vecpaste(names(unused.traits)[unused.traits == TRUE])) } } diff --git a/models/biocro/inst/biocro.Rscript b/models/biocro/inst/biocro.Rscript index 7319b4ff3b6..f60dc701c06 100755 --- a/models/biocro/inst/biocro.Rscript +++ b/models/biocro/inst/biocro.Rscript @@ -9,29 +9,23 @@ if(interactive()) { rundir <- file.path(settings$rundir, runid) outdir <- file.path(settings$outdir, "out", runid) } -require(PEcAn.data.land) -require(PEcAn.BIOCRO) -require(BioCro) -require(PEcAn.data.atmosphere) -require(PEcAn.utils) -require(lubridate) -config <- read.biocro.config(file.path(rundir, "config.xml")) +config <- PEcAn.BIOCRO::read.biocro.config(file.path(rundir, "config.xml")) metpath <- config$run$met.path if(!is.null(config$run$soil.file)){ - soil.nc <- nc_open(config$run$soil.file) + soil.nc <- ncdf4::nc_open(config$run$soil.file) } else { soil.nc <- NULL } -# atmco2.nc <- nc_open(file.path(inputdir, "co2/CO2_Global_HD_v1.nc")) +# atmco2.nc <- ncdf4::nc_open(file.path(inputdir, "co2/CO2_Global_HD_v1.nc")) lat <- as.numeric(config$location$latitude) lon <- as.numeric(config$location$longitude) -out <- run.biocro(lat, lon, +out <- PEcAn.BIOCRO::run.biocro(lat, lon, metpath = metpath, soil.nc = soil.nc, config = config) @@ -45,7 +39,7 @@ save(biocro_result, file = file.path(outdir, "biocro_output.RData")) #hourly <- out$hourly #save(hourly, file = file.path(outdir, "biocro_hourly.RData")) -model2netcdf.BIOCRO(result = out$hourly, +PEcAn.BIOCRO::model2netcdf.BIOCRO(result = out$hourly, genus = config$pft$type$genus, outdir = outdir, lat = lat, lon = lon) diff --git a/models/biocro/tests/testthat.R b/models/biocro/tests/testthat.R index 45bd65b95e6..31a95f2fe7e 100644 --- a/models/biocro/tests/testthat.R +++ b/models/biocro/tests/testthat.R @@ -10,4 +10,4 @@ library(PEcAn.settings) library(testthat) PEcAn.logger::logger.setQuitOnSevere(FALSE) -# test_check('PEcAn.BIOCRO') +test_check('PEcAn.BIOCRO') From 48a40b340c51e0d4356fdfd98f54cf7d58991d0a Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 1 Sep 2017 07:32:05 -0500 Subject: [PATCH 520/771] Met: Replace `year %% 4` with `leap_year` --- models/clm45/R/met2model.CLM45.R | 64 +++++----- models/dalec/R/met2model.DALEC.R | 82 ++++++------- models/preles/R/runPRELES.jobsh.R | 116 +++++++++--------- .../data.atmosphere/R/download.MsTMIP_NARR.R | 72 +++++------ .../inst/scripts/extract2driver.R | 48 ++++---- 5 files changed, 191 insertions(+), 191 deletions(-) diff --git a/models/clm45/R/met2model.CLM45.R b/models/clm45/R/met2model.CLM45.R index 34c6d46577e..9d7b7c890a5 100644 --- a/models/clm45/R/met2model.CLM45.R +++ b/models/clm45/R/met2model.CLM45.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2015 NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -10,7 +10,7 @@ ## R Code to convert NetCDF CF met files into NetCDF CLM met files. ##' met2model wrapper for CLM45 -##' +##' ##' @title met2model for CLM45 ##' @export ##' @param in.path location on disk where inputs are stored @@ -22,80 +22,80 @@ ##' @param overwrite should existing files be overwritten ##' @param verbose should the function be very verbosefor(year in start_year:end_year) met2model.CLM45 <- function(in.path,in.prefix,outfolder,start_date, end_date, lst=0,lat,lon,..., overwrite=FALSE,verbose=FALSE){ - + #General Structure- CLM Uses Netcdf so for now just need to rename vars.(Many not is CF standard. Need to Check that out) #Get Met file from inpath. #Loop over years (Open nc.file,rename vars,change dimensions as needed,close/save .nc file) #close #defining temporal dimension needs to be figured out. If we configure clm to use same tstep then we may not need to change dimensions - + # library("PEcAn.data.atmosphere") # library("PEcAn.utils") -# +# # #Process start and end dates # start_date<-as.POSIXlt(start.date,tz="UTC") # end_date<-as.POSIXlt(end.date,tz="UTC") -# +# # start_year <- year(start_date) # end_year <- year(end_date) -# +# # timestep.s<-86400 #Number of seconds in a day -# +# # ## Build met # met <- NULL # for(year in start_year:end_year){ -# +# # met.file.y = paste(met.file,year,"nc",sep=".") -# +# # if(file.exists(met.file.y)){ -# +# # ## Open netcdf file # nc=ncdf4::nc_open(met.file.y) -# -# +# +# # ## convert time to seconds -# sec <- nc$dim$time$vals +# sec <- nc$dim$time$vals # sec = udunits2::ud.convert(sec,unlist(strsplit(nc$dim$time$units," "))[1],"seconds") -# -# -# +# +# +# # ##build day and year -# +# # ifelse(leap_year(year)==TRUE, # dt <- (366*24*60*60)/length(sec), #leap year # dt <- (365*24*60*60)/length(sec)) #non-leap year # tstep = round(timestep.s/dt) #time steps per day -# -# doy <- rep(1:365,each=tstep)[1:length(sec)] -# if(year %% 4 == 0){ ## is leap +# +# doy <- rep(1:365,each=tstep)[1:length(sec)] +# if(lubridate::leap_year(year)){ # doy <- rep(1:366,each=tstep)[1:length(sec)] # } -# - +# + ## extract variables. These need to be read in and converted to CLM standards - + # ncdf4::ncvar_rename(ncfile,varid="LONGXY") # ncdf4::ncvar_rename(ncfile,varid="LATIXY") # # double ZBOT(time, lat, lon) ; # # ZBOT:long_name = "observational height" ; # # ZBOT:units = "m" ; # ZBOT = ncvar_rename(ncfile,"ZBOT","ZBOT") -# # +# # # # double EDGEW(scalar) ; # # EDGEW:long_name = "western edge in atmospheric data" ; # # EDGEW:units = "degrees E" ; # EDGEW = ncvar_rename(ncfile,"EDGEW","EDGEW") -# +# # # double EDGEE(scalar) ; # # EDGEE:long_name = "eastern edge in atmospheric data" ; # # EDGEE:units = "degrees E" ; # EDGEE = ncvar_rename(ncfile,"EDGEE","EDGEE") -# +# # # double EDGES(scalar) ; # # EDGES:long_name = "southern edge in atmospheric data" ; # # EDGES:units = "degrees N" ; -# EDGES = ncvar_rename(ncfile,"EDGES","EDGES") -# # +# EDGES = ncvar_rename(ncfile,"EDGES","EDGES") +# # # # double EDGEN(scalar) ; # # EDGEN:long_name = "northern edge in atmospheric data" ; # # EDGEN:units = "degrees N" ; @@ -104,7 +104,7 @@ met2model.CLM45 <- function(in.path,in.prefix,outfolder,start_date, end_date, ls # # TBOT:long_name = "temperature at the lowest atm level (TBOT)" ; # # TBOT:units = "K" ; # TBOT = ncvar_rename(ncfile,"TBOT","specific_humidity") -# # double RH(time, lat, lon) ; +# # double RH(time, lat, lon) ; # # RH:long_name = "relative humidity at the lowest atm level (RH)" ; # # relative_humidity # # RH:units = "%" ; @@ -122,7 +122,7 @@ met2model.CLM45 <- function(in.path,in.prefix,outfolder,start_date, end_date, ls # # FLDS:long_name = "incident longwave (FLDS)" ; # # FLDS:units = "W/m2" ; # FLDS = ncvar_rename(ncfile,"FLDS","") -# # double PSRF(time, lat, lon) ; +# # double PSRF(time, lat, lon) ; # # PSRF:long_name = "pressure at the lowest atm level (PSRF)" ; # # PSRF:units = "Pa" ; # PSRF = ncvar_rename(ncfile,"PSRF","air_pressure") @@ -130,7 +130,7 @@ met2model.CLM45 <- function(in.path,in.prefix,outfolder,start_date, end_date, ls # # PRECTmms:long_name = "precipitation (PRECTmms)" ; # # PRECTmms:units = "mm/s" ; # PRECTmms =ncvar_rename(ncfile,"PRECTmmc","precipitation_flux") - + #nc_close(ncfiles) #} ### end loop over met files diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index 0ecd1c1eae7..f78e0f17c32 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2015 Boston University, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -27,17 +27,17 @@ ##' @importFrom ncdf4 ncvar_get met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, spin_nyear=NULL,spin_nsample=NULL,spin_resample=NULL, ...) { - + ## DALEC 1 driver format (.csv): Runday, Min temp (°C), Max temp (°C), Radiation (MJ d-1), ## Atmospheric CO2 (μmol mol-1), Day of year - + ## DALEC EnKF (Quaife) format (.dat, space delimited): The nine columns of driving data are: day ## of year; mean air temperature (deg C); max daily temperature (deg C); min daily temperature ## (deg C); incident radiation (MJ/m2/day); maximum soil-leaf water potential difference (MPa); ## atmospheric carbon dioxide concentration (ppm); total plant-soil hydraulic resistance ## (MPa.m2.s/mmol-1); average foliar nitorgen (gC/m2 leaf area). Calculate these from ## air_temperature (K), surface_downwelling_shortwave_flux_in_air (W/m2), CO2 (ppm) - + library(PEcAn.utils) start_date <- as.POSIXlt(start_date, tz = "UTC") @@ -58,19 +58,19 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, start_date_string <- paste0(lubridate::year(start_date),"-01-01") ## strptime can't parse negative years PEcAn.logger::logger.info("New Start Date",start_date_string) } - - out.file <- paste0(in.prefix, start_date_string,".", - strptime(end_date, "%Y-%m-%d"), + + out.file <- paste0(in.prefix, start_date_string,".", + strptime(end_date, "%Y-%m-%d"), ".dat") out.file.full <- file.path(outfolder, out.file) - - results <- data.frame(file = c(out.file.full), + + results <- data.frame(file = c(out.file.full), host = c(PEcAn.utils::fqdn()), - mimetype = c("text/plain"), - formatname = c("DALEC meteorology"), - startdate = c(start_date), - enddate = c(end_date), - dbfile.name = out.file, + mimetype = c("text/plain"), + formatname = c("DALEC meteorology"), + startdate = c(start_date), + enddate = c(end_date), + dbfile.name = out.file, stringsAsFactors = FALSE) print("internal results") print(results) @@ -79,43 +79,43 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, PEcAn.logger::logger.debug("File '", out.file.full, "' already exists, skipping to next file.") return(invisible(results)) } - + library(PEcAn.data.atmosphere) ## check to see if the outfolder is defined, if not create directory for output if (!file.exists(outfolder)) { dir.create(outfolder) } - + out <- NULL - + # get start/end year since inputs are specified on year basis start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - - ## loop over files + + ## loop over files for (year in start_year:end_year) { print(year) ## Assuming default values for leaf water potential, hydraulic resistance, foliar N leafN <- 2.5 HydResist <- 1 LeafWaterPot <- -0.8 - + old.file <- file.path(in.path, paste(in.prefix, year, ".nc", sep = "")) if(!file.exists(old.file)) PEcAn.logger::logger.error("file not found",old.file) ## open netcdf nc <- ncdf4::nc_open(old.file) - + ## convert time to seconds sec <- nc$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") timestep.s <- 86400 # seconds in a day - ifelse(lubridate::leap_year(year) == TRUE, - dt <- (366 * 24 * 60 * 60) / length(sec), # leap year + ifelse(lubridate::leap_year(year) == TRUE, + dt <- (366 * 24 * 60 * 60) / length(sec), # leap year dt <- (365 * 24 * 60 * 60) / length(sec)) # non-leap year tstep <- round(timestep.s / dt) dt <- timestep.s / tstep #dt is now an integer - + ## extract variables lat <- ncvar_get(nc, "latitude") lon <- ncvar_get(nc, "longitude") @@ -123,39 +123,39 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, SW <- ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") ## in W/m2 CO2 <- try(ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air")) ncdf4::nc_close(nc) - + useCO2 <- is.numeric(CO2) - if (useCO2) + if (useCO2) CO2 <- CO2 * 1e+06 ## convert from mole fraction (kg/kg) to ppm - + ## is CO2 present? if (!is.numeric(CO2)) { PEcAn.logger::logger.warn("CO2 not found in", old.file, "setting to default: 400 ppm") CO2 <- rep(400, length(Tair)) } - + if (length(leafN) == 1) { PEcAn.logger::logger.warn("Leaf N not specified, setting to default: ", leafN) leafN <- rep(leafN, length(Tair)) } if (length(HydResist) == 1) { - PEcAn.logger::logger.warn("total plant-soil hydraulic resistance (MPa.m2.s/mmol-1) not specified, setting to default: ", + PEcAn.logger::logger.warn("total plant-soil hydraulic resistance (MPa.m2.s/mmol-1) not specified, setting to default: ", HydResist) HydResist <- rep(HydResist, length(Tair)) } if (length(LeafWaterPot) == 1) { - PEcAn.logger::logger.warn("maximum soil-leaf water potential difference (MPa) not specified, setting to default: ", + PEcAn.logger::logger.warn("maximum soil-leaf water potential difference (MPa) not specified, setting to default: ", LeafWaterPot) LeafWaterPot <- rep(LeafWaterPot, length(Tair)) } - + ## build day of year doy <- rep(1:365, each = timestep.s / dt)[1:length(sec)] - if (year %% 4 == 0) { + if (lubridate::leap_year(year)) { ## is leap doy <- rep(1:366, each = timestep.s / dt)[1:length(sec)] } - + ## Aggregate variables up to daily Tmean <- udunits2::ud.convert(tapply(Tair, doy, mean, na.rm = TRUE), "Kelvin", "Celsius") Tmin <- udunits2::ud.convert(tapply(Tair, doy, min, na.rm = TRUE), "Kelvin", "Celsius") @@ -166,16 +166,16 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, HydResist <- tapply(HydResist, doy, mean) leafN <- tapply(leafN, doy, mean) doy <- tapply(doy, doy, mean) - + ## The nine columns of driving data are: day of year; mean air temperature (deg C); max daily ## temperature (deg C); min daily temperature (deg C); incident radiation (MJ/m2/day); maximum ## soil-leaf water potential difference (MPa); atmospheric carbon dioxide concentration (ppm); ## total plant-soil hydraulic resistance (MPa.m2.s/mmol-1); average foliar nitorgen (gC/m2 leaf ## area). - + ## build data matrix tmp <- cbind(doy, Tmean, Tmax, Tmin, Rin, LeafWaterPot, CO2, HydResist, leafN) - + ##filter out days not included in start or end date if(year == start_year){ start.row <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date @@ -185,7 +185,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, print(nrow(tmp)) tmp <- tmp[start.row:nrow(tmp),] } - } + } if (year == end_year){ if(year == start_year){ end.row <- length(as.Date(start_date):as.Date(end_date)) @@ -200,9 +200,9 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, tmp <- tmp[1:end.row,] } } - + } - + if (is.null(out)) { out <- tmp } else { @@ -210,7 +210,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, } } ## end loop over years write.table(out, out.file.full, quote = FALSE, sep = " ", row.names = FALSE, col.names = FALSE) - + return(invisible(results)) - + } # met2model.DALEC diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index c009c7357aa..9b0fb719f83 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -14,52 +14,52 @@ ##' @param outdir Location of PRELES model output ##' @param start_date Start time of the simulation ##' @param end_date End time of the simulation -##' @export +##' @export ##' @author Tony Gardella, Michael Dietze ##' @importFrom ncdf4 ncvar_get ncvar_def runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, start.date, end.date) { - + library(PEcAn.data.atmosphere) library(PEcAn.utils) library(Rpreles) - + # Process start and end dates start_date <- as.POSIXlt(start.date, tz = "UTC") end_date <- as.POSIXlt(end.date, tz = "UTC") - + start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - + timestep.s <- 86400 # Number of seconds in a day - + ## Build met met <- NULL for (year in start_year:end_year) { - + met.file.y <- paste(met.file, year, "nc", sep = ".") - + if (file.exists(met.file.y)) { - + ## Open netcdf file nc <- ncdf4::nc_open(met.file.y) - + ## convert time to seconds sec <- nc$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") - + ## build day and year - - dt <- ifelse(lubridate::leap_year(year) == TRUE, + + dt <- ifelse(lubridate::leap_year(year) == TRUE, 366 * 24 * 60 * 60 / length(sec), # leap year 365 * 24 * 60 * 60 / length(sec)) # non-leap year tstep <- round(timestep.s / dt) #time steps per day - + doy <- rep(1:365, each = tstep)[1:length(sec)] - if (year %% 4 == 0) { + if (lubridate::leap_year(year)) { ## is leap doy <- rep(1:366, each = tstep)[1:length(sec)] } - + ## Get variables from netcdf file SW <- ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") # SW in W/m2 Tair <- ncvar_get(nc, "air_temperature") # air temperature in K @@ -68,25 +68,25 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star SH <- ncvar_get(nc, "specific_humidity") lat <- ncvar_get(nc, "latitude") lon <- ncvar_get(nc, "longitude") - + ncdf4::nc_close(nc) - + ## Check for CO2 and PAR if (!is.numeric(CO2)) { PEcAn.logger::logger.warn("CO2 not found. Setting to default: 4.0e+8 mol/mol") # using rough estimate of atmospheric CO2 levels CO2 <- rep(4e+08, length(Precip)) } - + ## GET VPD from Saturated humidity and Air Temperature RH <- qair2rh(SH, Tair) VPD <- get.vpd(RH, Tair) - + VPD <- VPD * 0.01 # convert to Pascal - + ## Get PPFD from SW PPFD <- sw2ppfd(SW) # PPFD in umol/m2/s PPFD <- PPFD * 1e-06 # convert umol to mol - + ## Format/convert inputs ppfd <- tapply(PPFD, doy, mean, na.rm = TRUE) # Find the mean for the day tair <- udunits2::ud.convert(tapply(Tair, doy, mean, na.rm = TRUE), "kelvin", "celsius") # Convert Kelvin to Celcius @@ -96,89 +96,89 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star co2 <- co2 / 1e+06 # convert to ppm doy <- tapply(doy, doy, mean) # day of year fapar <- rep(0.6, length = length(doy)) # For now set to 0.6. Needs to be between 0-1 - + ## Bind inputs tmp <- cbind(ppfd, tair, vpd, precip, co2, fapar) tmp[is.na(tmp)] <- 0 met <- rbind(met, tmp) } ## end file exists } ## end met process - + param.def <- rep(NA, 30) - + #PARAMETER DEFAULT LIST - ##GPP_MODEL_PARAMETERS - #1.soildepth 413.0 |2.ThetaFC 0.450 | 3.ThetaPWP 0.118 |4.tauDrainage 3 + ##GPP_MODEL_PARAMETERS + #1.soildepth 413.0 |2.ThetaFC 0.450 | 3.ThetaPWP 0.118 |4.tauDrainage 3 #5.betaGPP 0.748018 |6.tauGPP 13.23383 |7.S0GPP -3.9657867 |8.SmaxGPP 18.76696 - #9.kappaGPP -0.130473 |10.gammaGPP 0.034459 |11.soilthresGPP 0.450828 |12.cmCO2 2000 - #13.ckappaCO2 0.4 - ##EVAPOTRANSPIRATION_PARAMETERS - #14.betaET 0.324463 |15.kappaET 0.874151 |16.chiET 0.075601 |17.soilthresE 0.541605 + #9.kappaGPP -0.130473 |10.gammaGPP 0.034459 |11.soilthresGPP 0.450828 |12.cmCO2 2000 + #13.ckappaCO2 0.4 + ##EVAPOTRANSPIRATION_PARAMETERS + #14.betaET 0.324463 |15.kappaET 0.874151 |16.chiET 0.075601 |17.soilthresE 0.541605 #18.nu ET 0.273584 ##SNOW_RAIN_PARAMETERS - #19.Meltcoef 1.2 |20.I_0 0.33 |21.CWmax 4.970496 |22.SnowThreshold 0 - #23.T_0 0 - ##START INITIALISATION PARAMETERS + #19.Meltcoef 1.2 |20.I_0 0.33 |21.CWmax 4.970496 |22.SnowThreshold 0 + #23.T_0 0 + ##START INITIALISATION PARAMETERS #24.SWinit 200 |25.CWinit 0 |26.SOGinit 0 |27.Sinit 20 #28.t0 fPheno_start_date_Tsum_accumulation; conif -999, for birch 57 #29.tcrit -999 fPheno_start_date_Tsum_Tthreshold, 1.5 birch #30.tsumcrit -999 fPheno_budburst_Tsum, 134 birch - + ## Replace default with sampled parameters load(parameters) params <- data.frame(trait.values) colnames <- c(names(trait.values[[1]])) colnames(params) <- colnames - + param.def[5] <- as.numeric(params["bGPP"]) param.def[9] <- as.numeric(params["kGPP"]) - + ## Run PRELES - PRELES.output <- as.data.frame(PRELES(PAR = tmp[, "ppfd"], - TAir = tmp[, "tair"], - VPD = tmp[, "vpd"], - Precip = tmp[, "precip"], - CO2 = tmp[, "co2"], + PRELES.output <- as.data.frame(PRELES(PAR = tmp[, "ppfd"], + TAir = tmp[, "tair"], + VPD = tmp[, "vpd"], + Precip = tmp[, "precip"], + CO2 = tmp[, "co2"], fAPAR = tmp[, "fapar"], p = param.def)) PRELES.output.dims <- dim(PRELES.output) - + days <- as.Date(start_date):as.Date(end_date) year <- strftime(as.Date(days, origin = "1970-01-01"), "%Y") years <- unique(year) num.years <- length(years) - + for (y in years) { - if (file.exists(file.path(outdir, paste(y)))) + if (file.exists(file.path(outdir, paste(y)))) next print(paste("----Processing year: ", y)) - + sub.PRELES.output <- subset(PRELES.output, years == y) sub.PRELES.output.dims <- dim(sub.PRELES.output) - + output <- list() output[[1]] <- (sub.PRELES.output[, 1] * 0.001)/timestep.s #GPP - gC/m2day to kgC/m2s1 output[[2]] <- (sub.PRELES.output[, 2])/timestep.s #Evapotranspiration - mm =kg/m2 output[[3]] <- (sub.PRELES.output[, 3])/timestep.s #Soilmoisture - mm = kg/m2 output[[4]] <- (sub.PRELES.output[, 4])/timestep.s #fWE modifier - just a modifier output[[5]] <- (sub.PRELES.output[, 5])/timestep.s #fW modifier - just a modifier - output[[6]] <- (sub.PRELES.output[, 6])/timestep.s #Evaporation - mm = kg/m2 + output[[6]] <- (sub.PRELES.output[, 6])/timestep.s #Evaporation - mm = kg/m2 output[[7]] <- (sub.PRELES.output[, 7])/timestep.s #transpiration - mm = kg/m2 - + t <- ncdf4::ncdim_def(name = "time", - units = paste0("days since", y, "-01-01 00:00:00"), - vals = 1:nrow(sub.PRELES.output), - calendar = "standard", + units = paste0("days since", y, "-01-01 00:00:00"), + vals = 1:nrow(sub.PRELES.output), + calendar = "standard", unlim = TRUE) - + lat <- ncdf4::ncdim_def("lat", "degrees_east", vals = as.numeric(sitelat), longname = "station_longitude") lon <- ncdf4::ncdim_def("lat", "degrees_north", vals = as.numeric(sitelon), longname = "station_longitude") - + for (i in seq_along(output)) { - if (length(output[[i]]) == 0) + if (length(output[[i]]) == 0) output[[i]] <- rep(-999, length(t$vals)) } - + var <- list() var[[1]] <- mstmipvar("GPP", lat, lon, t, NA) var[[2]] <- ncvar_def("Evapotranspiration", "kg/m2s1", list(lon, lat, t), -999) @@ -187,7 +187,7 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star var[[5]] <- ncvar_def("fW", "NA", list(lon, lat, t), -999) var[[6]] <- ncvar_def("Evap", "kg/m2/s", list(lon, lat, t), -999) var[[7]] <- ncvar_def("TVeg", "kg/m2/s", list(lat, lon, t), NA) - + nc <- ncdf4::nc_create(file.path(outdir, paste(y, "nc", sep = ".")), var) varfile <- file(file.path(outdir, paste(y, "nc", "var", sep = ".")), "w") for (i in seq_along(var)) { diff --git a/modules/data.atmosphere/R/download.MsTMIP_NARR.R b/modules/data.atmosphere/R/download.MsTMIP_NARR.R index aa9d770e2a3..f3c79a85002 100644 --- a/modules/data.atmosphere/R/download.MsTMIP_NARR.R +++ b/modules/data.atmosphere/R/download.MsTMIP_NARR.R @@ -12,66 +12,66 @@ download.MsTMIP_NARR <- function(outfolder, start_date, end_date, site_id, lat.in, lon.in, overwrite = FALSE, verbose = FALSE, ...) { library(PEcAn.utils) - + start_date <- as.POSIXlt(start_date, tz = "UTC") end_date <- as.POSIXlt(end_date, tz = "UTC") start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) site_id <- as.numeric(site_id) outfolder <- paste0(outfolder, "_site_", paste0(site_id%/%1e+09, "-", site_id%%1e+09)) - + lat.in <- as.numeric(lat.in) lon.in <- as.numeric(lon.in) lat_trunc <- floor(4 * (84 - as.numeric(lat.in))) lon_trunc <- floor(4 * (as.numeric(lon.in) + 170)) dap_base <- "http://thredds.daac.ornl.gov/thredds/dodsC/ornldaac/1220/mstmip_driver_na_qd_climate_" - + dir.create(outfolder, showWarnings = FALSE, recursive = TRUE) - + ylist <- seq(start_year, end_year, by = 1) rows <- length(ylist) - results <- data.frame(file = character(rows), + results <- data.frame(file = character(rows), host = character(rows), - mimetype = character(rows), - formatname = character(rows), - startdate = character(rows), - enddate = character(rows), - dbfile.name = "MsTMIP_NARR", + mimetype = character(rows), + formatname = character(rows), + startdate = character(rows), + enddate = character(rows), + dbfile.name = "MsTMIP_NARR", stringsAsFactors = FALSE) - - var <- data.frame(DAP.name = c("air_2m", "dswrf", "dlwrf", "wnd_10m", "apcp", "shum_2m", "rhum_2m"), - CF.name = c("air_temperature", "surface_downwelling_shortwave_flux_in_air", - "surface_downwelling_longwave_flux_in_air", - "wind_speed", "precipitation_flux", "specific_humidity", "relative_humidity"), + + var <- data.frame(DAP.name = c("air_2m", "dswrf", "dlwrf", "wnd_10m", "apcp", "shum_2m", "rhum_2m"), + CF.name = c("air_temperature", "surface_downwelling_shortwave_flux_in_air", + "surface_downwelling_longwave_flux_in_air", + "wind_speed", "precipitation_flux", "specific_humidity", "relative_humidity"), units = c("Kelvin", "W/m2", "W/m2", "m/s", "kg/m2/s", "g/g", "%")) - - + + for (i in seq_len(rows)) { year <- ylist[i] - - ntime <- ifelse(year %% 4 == 0, 2923, 2919) # should use lubridate::leap_year? + + ntime <- ifelse(lubridate::leap_year(year), 2923, 2919) loc.file <- file.path(outfolder, paste("MsTMIP_NARR", year, "nc", sep = ".")) - + ## Create dimensions lat <- ncdf4::ncdim_def(name = "latitude", units = "degree_north", vals = lat.in, create_dimvar = TRUE) lon <- ncdf4::ncdim_def(name = "longitude", units = "degree_east", vals = lon.in, create_dimvar = TRUE) - time <- ncdf4::ncdim_def(name = "time", - units = "sec", - vals = (1:ntime) * 10800, - create_dimvar = TRUE, + time <- ncdf4::ncdim_def(name = "time", + units = "sec", + vals = (1:ntime) * 10800, + create_dimvar = TRUE, unlim = TRUE) dim <- list(lat, lon, time) - + var.list <- list() dat.list <- list() - + DAPvar <- c("air", "dswrf", "dlwrf", "wnd", "apcp", "shum", "rhum") - + ## get data off OpenDAP for (j in seq_len(nrow(var))) { if (var$DAP.name[j] == "dswrf") { - (dap_file <- paste0("http://thredds.daac.ornl.gov/thredds/dodsC/ornldaac/1220/mstmip_driver_na_qd_dswrf_", + (dap_file <- paste0("http://thredds.daac.ornl.gov/thredds/dodsC/ornldaac/1220/mstmip_driver_na_qd_dswrf_", year, "_v1.nc4")) } else { (dap_file <- paste0(dap_base, var$DAP.name[j], "_", year, "_v1.nc4")) @@ -79,24 +79,24 @@ download.MsTMIP_NARR <- function(outfolder, start_date, end_date, site_id, lat.i dap <- ncdf4::nc_open(dap_file) dat.list[[j]] <- ncdf4::ncvar_get(dap, as.character(DAPvar[j]), c(lon_trunc, lat_trunc, 1), c(1, 1, ntime)) - var.list[[j]] <- ncdf4::ncvar_def(name = as.character(var$CF.name[j]), - units = as.character(var$units[j]), - dim = dim, - missval = -999, + var.list[[j]] <- ncdf4::ncvar_def(name = as.character(var$CF.name[j]), + units = as.character(var$units[j]), + dim = dim, + missval = -999, verbose = verbose) ncdf4::nc_close(dap) } - + ## change units of precip to kg/m2/s instead of 3 hour accumulated precip dat.list[[5]] <- dat.list[[5]] / 10800 - + ## put data in new file loc <- ncdf4::nc_create(filename = loc.file, vars = var.list, verbose = verbose) for (j in seq_len(nrow(var))) { ncdf4::ncvar_put(nc = loc, varid = as.character(var$CF.name[j]), vals = dat.list[[j]]) } ncdf4::nc_close(loc) - + results$file[i] <- loc.file results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year, "-01-01 00:00:00") @@ -104,6 +104,6 @@ download.MsTMIP_NARR <- function(outfolder, start_date, end_date, site_id, lat.i results$mimetype[i] <- "application/x-netcdf" results$formatname[i] <- "CF Meteorology" } - + return(invisible(results)) } # download.MsTMIP_NARR diff --git a/modules/data.atmosphere/inst/scripts/extract2driver.R b/modules/data.atmosphere/inst/scripts/extract2driver.R index c5e7ec55b67..d850f91abb6 100644 --- a/modules/data.atmosphere/inst/scripts/extract2driver.R +++ b/modules/data.atmosphere/inst/scripts/extract2driver.R @@ -2,7 +2,7 @@ ################################## ## ## -## SINGLE SITE TIMESERIES ## +## SINGLE SITE TIMESERIES ## ## ## ################################## ## how to extract a specific cell @@ -37,7 +37,7 @@ readGrib<-function(indices, gribfile, tempfile=paste(tempdir,'GRIB.txt', sep='') system(paste("rm ",tempfile,sep="")) return(V) } -readMetGrib <- function(indices, gribfile, +readMetGrib <- function(indices, gribfile, nearestCells, weights){ print(gribfile) V<-readGrib(indices, gribfile) @@ -49,21 +49,21 @@ readMetGrib <- function(indices, gribfile, extractTar<-function(tarfile, sourcedir, targetdir){ system(paste("tar -xf ", sourcedir, tarfile, ' -C ', targetdir, sep=''), intern=TRUE) } -readMetTar<-function(tarfile, indices, +readMetTar<-function(tarfile, indices, nearestCells, weights, sourcedir=narrdir, targetdir=tempdir){ print(tarfile) - #returns meteorological data from a tar file + #returns meteorological data from a tar file #as a 2D matrix of parameters and tar subfiles - + system(paste("rm ",targetdir,'/merged_AWIP32*',sep="")) # clean up # copy file to temp space and open up extractTar(tarfile, sourcedir, targetdir) - + # get list of sub-files; parse subfiles <- dir(targetdir,"merged") subfiles <- paste(targetdir, subfiles, sep='') - + ## LOOP OVER SMALL FILES tarMetData <- matrix(NA,nrow=length(subfiles),ncol=length(indices)) if (length(indices) > 0){ @@ -76,13 +76,13 @@ readMetTar<-function(tarfile, indices, } tarMetData } -readMetTars<-function(tarfiles, indices, +readMetTars<-function(tarfiles, indices, nearestCells, weights){ # returns meteorological data from a list of tar files # bound into a single 2 dimensional matrix representing 4 dimensions # each column represents a parameter # each row represents a lat/lon coordinate at a specific time - foo<-sapply(tarfiles, + foo<-sapply(tarfiles, function(tarfile){readMetTar(tarfile, indices, nearestCells, weights)}) if(!is.list(foo)){print(foo);browser()} print(tarfiles) @@ -116,7 +116,7 @@ writeHdf5<-function(file, metdata, potential, downscale.radiation=function(x){x} nddsf <- as.met.array(downscale.radiation(nddsf)) vbdsf <- as.met.array(downscale.radiation(vbdsf)) vddsf <- as.met.array(downscale.radiation(vddsf)) - + hdf5save(file,"nbdsf","nddsf","vbdsf","vddsf","prate","dlwrf","pres","hgt","ugrd","vgrd","sh","tmp") } @@ -127,7 +127,7 @@ monthlengths = c(31,28,31,30,31,30,31,31,30,31,30,31) monthlengthsLeap = monthlengths monthlengthsLeap[2] = monthlengthsLeap[2]+1 monthlength <- function(month,year){ - if(year %% 4 == 0){ + if(lubridate::leap_year(year)){ return(monthlengthsLeap[month]) } return(monthlengths[month]) @@ -151,7 +151,7 @@ smoothedRadiation <- function(a, month, year, timelag, new.timestep,old.timestep rep(seq(new.timestep,secsInDay,new.timestep), monthlength(mo,year)), LAT, timelag*24) rbar <- rep(tapply(rin,lab,mean),each=old.timestep/new.timestep) - r <-apply(cbind(dat*rin/rbar,rep(0,length(dat))),1,max) + r <-apply(cbind(dat*rin/rbar,rep(0,length(dat))),1,max) r[rbar == 0] <- 0 ## filter @@ -176,7 +176,7 @@ rad2deg<-function(radians){ potentialRadiation <- function(day,time,LAT,timelag){ #radiation as determined only by solar position dayangle=2.0*pi*(day)/daysInYear - declination = 0.006918 - + declination = 0.006918 - 0.399912 * cos(dayangle)+ 0.070257 * sin(dayangle)- 0.006758 * cos(2.0*dayangle)+ @@ -189,12 +189,12 @@ potentialRadiation <- function(day,time,LAT,timelag){ 0.000719 * cos(2.0*dayangle)+ 0.000077 * sin(2.0*dayangle) solartime=time/secsInHour-12.0+timelag - radiation = 1367.0 * - eccentricity * - (cos(declination) * - cos(deg2rad(LAT)) * + radiation = 1367.0 * + eccentricity * + (cos(declination) * + cos(deg2rad(LAT)) * cos(deg2rad(15.0)*(solartime)) + - sin(declination) * + sin(declination) * sin(deg2rad(LAT))) radiation[radiation<0] <- 0 radiation @@ -211,7 +211,7 @@ potentialRadiation2<-function(lat, lon, day, hours){ #equation of time -> eccentricity and obliquity meridian <- floor(lon/15)*15 if(meridian<0) meridian <- meridian+15 - lonCorrection <- (lon-meridian)*-4/60 + lonCorrection <- (lon-meridian)*-4/60 timeZone <- meridian/360*24 midbin <- 0.5*timestep/secsInHour # shift calc to middle of bin solarTime <- 12+lonCorrection-eccentricity-timeZone-midbin @@ -274,13 +274,13 @@ for(year in unique(years)){ monthTars <- yearTars[which(months[yearTars] == month)] monthnum<-as.numeric(month) print(paste(year,month)) - + surfaceTars <- monthTars[which(vars[monthTars] == "sfc")] surfaceMetData<-readMetTars(tarfiles[surfaceTars], - list(cfrzr=33, cicep=32, crain=34, csnow=31, dlwrf=42, + list(cfrzr=33, cicep=32, crain=34, csnow=31, dlwrf=42, dswrf=41, pres =3, prate=24, tmp =5), nearestCells, weights) - + fluxTars <- monthTars[which(vars[monthTars] == "flx")] fluxMetData<-readMetTars(tarfiles[fluxTars], list(tmp10=38, tmp30=44, ugrd10=35, ugrd30=41, vgrd10=36, @@ -292,14 +292,14 @@ for(year in unique(years)){ stopday<-lastday(monthnum,yearnum)+1 days <- rep(startday:stopday, each = 24/3) hours <- rep(seq(0,21,by=3),length=nrow(monthMetData)) - + potential<-potentialRadiation2(LAT,LON,days, hours) # write as h5 out.file <- paste(narrdir, outdir,"/", outdir,"_", yearnum, monthnames[monthnum],".h5",sep="") print(out.file) - writeHdf5(out.file, monthMetData, potential, + writeHdf5(out.file, monthMetData, potential, downscale.radiation=function(x){x}) #downscale.radiation=function(x){smoothedRadiation(x, monthnum, yearnum, timelag, new.timestep=900, old.timestep=timestep)}) } # end month From 929ba5aa7cfa875e3108fd0af00253efb4106486 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 1 Sep 2017 09:23:29 -0500 Subject: [PATCH 521/771] Cleanup leap years. New function `PEcAn.utils::days_in_year(year)` calculates the days in a year given a year (or vector of years). I used this function to replace many occurrences of `ifelse(leap_year(year), 366, 355)` many places in the code. I also simplified many statements related to leap year if-else clauses, where it was simple enough to do so. Also, new function `PEcAn.data.atmsphere::eccentricity_obliquity(doy)` does the appropriate math. This was refactored out of several places that had this fairly complex equation duplicated. Also, all of the files I touched have had trailing whitespace removed (courtesy of RStudio), which extends the review diff, but is good coding practice. --- base/utils/NAMESPACE | 1 + base/utils/R/days_in_year.R | 19 ++ base/utils/man/days_in_year.Rd | 22 ++ models/dalec/R/met2model.DALEC.R | 11 +- models/ed/R/met2model.ED2.R | 107 ++++----- models/ed/R/model2netcdf.ED2.R | 163 +++++++------- models/jules/R/write.config.JULES.R | 151 +++++++------ models/linkages/R/met2model.LINKAGES.R | 67 +++--- models/lpjguess/R/met2model.LPJGUESS.R | 99 ++++---- models/maat/R/met2model.MAAT.R | 121 +++++----- models/maespa/R/met2model.MAESPA.R | 91 ++++---- models/preles/R/runPRELES.jobsh.R | 11 +- models/sipnet/R/met2model.SIPNET.R | 119 +++++----- modules/assim.batch/R/get.da.data.R | 52 ++--- modules/data.atmosphere/NAMESPACE | 1 + .../R/download.CRUNCEP_Global.R | 64 +++--- modules/data.atmosphere/R/download.GLDAS.R | 101 ++++----- .../data.atmosphere/R/download.MsTMIP_NARR.R | 2 +- modules/data.atmosphere/R/download.NLDAS.R | 88 ++++---- .../R/eccentricity_obliquity.R | 13 ++ modules/data.atmosphere/R/metgapfill.R | 24 +- .../R/tdm_predict_subdaily_met.R | 213 +++++++++--------- .../inst/scripts/ORNL_FACE_MET.v2.R | 23 +- .../inst/scripts/ncep/Globalmet.R | 34 +-- .../man/eccentricity_obliquity.Rd | 17 ++ .../man/predict_subdaily_met.Rd | 4 +- 26 files changed, 825 insertions(+), 793 deletions(-) create mode 100644 base/utils/R/days_in_year.R create mode 100644 base/utils/man/days_in_year.Rd create mode 100644 modules/data.atmosphere/R/eccentricity_obliquity.R create mode 100644 modules/data.atmosphere/man/eccentricity_obliquity.Rd diff --git a/base/utils/NAMESPACE b/base/utils/NAMESPACE index 831b7cad582..5fed2312189 100644 --- a/base/utils/NAMESPACE +++ b/base/utils/NAMESPACE @@ -13,6 +13,7 @@ export(convert.input) export(convert.outputs) export(counter) export(create.base.plot) +export(days_in_year) export(distn.stats) export(distn.table.stats) export(do_conversions) diff --git a/base/utils/R/days_in_year.R b/base/utils/R/days_in_year.R new file mode 100644 index 00000000000..46112fdb080 --- /dev/null +++ b/base/utils/R/days_in_year.R @@ -0,0 +1,19 @@ +#' Number of days in a year +#' +#' Calculate number of days in a year based on whether it is a leap year or not. +#' +#' @param year Numeric year +#' +#' @author Alexey Shiklomanov +#' @return +#' @export +#' @examples +#' days_in_year(2010) # Not a leap year -- returns 365 +#' days_in_year(2012) # Leap year -- returns 366 +#' days_in_year(2000:2008) # Function is vectorized over years +days_in_year <- function(year) { + if (any(year %% 1 != 0)) { + PEcAn.logger::logger.severe("Year must be integer. Given ", year, '.') + } + ifelse(lubridate::leap_year(year), yes = 366, no = 365) +} diff --git a/base/utils/man/days_in_year.Rd b/base/utils/man/days_in_year.Rd new file mode 100644 index 00000000000..3f715982270 --- /dev/null +++ b/base/utils/man/days_in_year.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/days_in_year.R +\name{days_in_year} +\alias{days_in_year} +\title{Number of days in a year} +\usage{ +days_in_year(year) +} +\arguments{ +\item{year}{Numeric year} +} +\description{ +Calculate number of days in a year based on whether it is a leap year or not. +} +\examples{ +days_in_year(2010) # Not a leap year -- returns 365 +days_in_year(2012) # Leap year -- returns 366 +days_in_year(2000:2008) # Function is vectorized over years +} +\author{ +Alexey Shiklomanov +} diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index f78e0f17c32..bde12e127d9 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -110,9 +110,8 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, sec <- nc$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") timestep.s <- 86400 # seconds in a day - ifelse(lubridate::leap_year(year) == TRUE, - dt <- (366 * 24 * 60 * 60) / length(sec), # leap year - dt <- (365 * 24 * 60 * 60) / length(sec)) # non-leap year + diy <- PEcAn.utils::days_in_year(year) + dt <- diy * 24 * 60 * 60 / length(sec) tstep <- round(timestep.s / dt) dt <- timestep.s / tstep #dt is now an integer @@ -150,11 +149,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, } ## build day of year - doy <- rep(1:365, each = timestep.s / dt)[1:length(sec)] - if (lubridate::leap_year(year)) { - ## is leap - doy <- rep(1:366, each = timestep.s / dt)[1:length(sec)] - } + doy <- rep(seq_len(diy), each = timestep.s / dt)[seq_along(sec)] ## Aggregate variables up to daily Tmean <- udunits2::ud.convert(tapply(Tair, doy, mean, na.rm = TRUE), "Kelvin", "Celsius") diff --git a/models/ed/R/met2model.ED2.R b/models/ed/R/met2model.ED2.R index e5b0a2f7920..ae8090ff2f9 100644 --- a/models/ed/R/met2model.ED2.R +++ b/models/ed/R/met2model.ED2.R @@ -1,6 +1,6 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. -# All rights reserved. This program and the accompanying materials +# All rights reserved. This program and the accompanying materials # are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at @@ -10,7 +10,7 @@ ## R Code to convert from NACP intercomparison NETCDF met files into ED2 ascii met files ## It requires the rhdf5 library, which is not available on CRAN, but by can be installed locally: -## >source('http://bioconductor.org/biocLite.R') +## >source('http://bioconductor.org/biocLite.R') ## >biocLite('rhdf5') ## If files already exist in 'Outfolder', the default function is NOT to overwrite them and only @@ -31,11 +31,11 @@ ##' @param overwrite should existing files be overwritten ##' @param verbose should the function be very verbose ##' @importFrom ncdf4 ncvar_get ncdim_def ncatt_get ncvar_add -met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, lst = 0, lat = NA, +met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, lst = 0, lat = NA, lon = NA, overwrite = FALSE, verbose = FALSE, ...) { overwrite <- as.logical(overwrite) - # deprecated? + # deprecated? library(rhdf5) library(PEcAn.utils) @@ -44,19 +44,19 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l end_date <- as.POSIXlt(end_date, tz = "UTC") met_folder <- outfolder met_header <- file.path(met_folder, "ED_MET_DRIVER_HEADER") - - results <- data.frame(file = c(met_header), - host = c(PEcAn.utils::fqdn()), - mimetype = c("text/plain"), - formatname = c("ed.met_driver_header files format"), - startdate = c(start_date), - enddate = c(end_date), - dbfile.name = "ED_MET_DRIVER_HEADER", + + results <- data.frame(file = c(met_header), + host = c(PEcAn.utils::fqdn()), + mimetype = c("text/plain"), + formatname = c("ed.met_driver_header files format"), + startdate = c(start_date), + enddate = c(end_date), + dbfile.name = "ED_MET_DRIVER_HEADER", stringsAsFactors = FALSE) - + ## check to see if the outfolder is defined, if not create directory for output dir.create(met_folder, recursive = TRUE, showWarnings = FALSE) - + ### FUNCTIONS dm <- c(0, 32, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366) dl <- c(0, 32, 61, 92, 122, 153, 183, 214, 245, 275, 306, 336, 367) @@ -69,20 +69,20 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l mo[!leap] <- findInterval(day[!leap], dm) return(mo) } - + # get start/end year since inputs are specified on year basis start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - + ## loop over files for (year in start_year:end_year) { ncfile <- file.path(in.path, paste(in.prefix, year, "nc", sep = ".")) - + ## extract file root name froot <- substr(files[i],1,28) print(c(i,froot)) - + ## open netcdf nc <- ncdf4::nc_open(ncfile) - + # check lat/lon flat <- try(ncvar_get(nc, "latitude"), silent = TRUE) if (!is.numeric(flat)) { @@ -93,7 +93,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l } else if (lat != flat) { PEcAn.logger::logger.warn("Latitude does not match that of file", lat, "!=", flat) } - + flon <- try(ncvar_get(nc, "longitude"), silent = TRUE) if (!is.numeric(flon)) { flat <- nc$dim[[2]]$vals[1] @@ -103,9 +103,9 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l } else if (lon != flon) { PEcAn.logger::logger.warn("Longitude does not match that of file", lon, "!=", flon) } - + ## determine GMT adjustment lst <- site$LST_shift[which(site$acro == froot)] - + ## extract variables lat <- eval(parse(text = lat)) lon <- eval(parse(text = lon)) @@ -119,20 +119,19 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l SW <- ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") LW <- ncvar_get(nc, "surface_downwelling_longwave_flux_in_air") CO2 <- try(ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air"), silent = TRUE) - + useCO2 <- is.numeric(CO2) - + ## convert time to seconds sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") - + ncdf4::nc_close(nc) - - dt <- ifelse(lubridate::leap_year(year) == TRUE, - 366 * 24 * 60 * 60 / length(sec), # leap year - 365 * 24 * 60 * 60 / length(sec)) # non-leap year - + + diy <- PEcAn.utils::days_in_year(year) + dt <- diy * 24 * 60 * 60 / length(sec) + toff <- -as.numeric(lst) * 3600 / dt - + ## buffer to get to GMT slen <- length(SW) Tair <- c(rep(Tair[1], toff), Tair)[1:slen] @@ -146,7 +145,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l if (useCO2) { CO2 <- c(rep(CO2[1], toff), CO2)[1:slen] } - + ## build time variables (year, month, day of year) skip <- FALSE nyr <- floor(length(sec) / 86400 / 365 * dt) @@ -155,13 +154,9 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l hr <- NULL asec <- sec for (y in seq(year, year + nyr - 1)) { - ytmp <- rep(y, 365 * 86400 / dt) - dtmp <- rep(1:365, each = 86400 / dt) - if (lubridate::leap_year(y)) { - ## is leap - ytmp <- rep(y, 366 * 86400 / dt) - dtmp <- rep(1:366, each = 86400 / dt) - } + diy <- PEcAn.utils::days_in_year(y) + ytmp <- rep(y, diy * 86400 / dt) + dtmp <- rep(seq_len(diy), each = 86400 / dt) if (is.null(yr)) { yr <- ytmp doy <- dtmp @@ -196,12 +191,10 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l print("Skipping to next year") next } - - + + ## calculate potential radiation in order to estimate diffuse/direct - f <- pi/180 * (279.5 + 0.9856 * doy) - et <- (-104.7 * sin(f) + 596.2 * sin(2 * f) + 4.3 * sin(4 * f) - 429.3 * - cos(f) - 2 * cos(2 * f) + 19.3 * cos(3 * f)) / 3600 # equation of time -> eccentricity and obliquity + et <- PEcAn.data.atmosphere::eccentricity_obliquity(doy) merid <- floor(lon/15) * 15 merid[merid < 0] <- merid[merid < 0] + 15 lc <- (lon - merid) * -4 / 60 ## longitude correction @@ -210,13 +203,13 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l t0 <- 12 + lc - et - tz - midbin ## solar time h <- pi/12 * (hr - t0) ## solar hour dec <- -23.45 * pi/180 * cos(2 * pi * (doy + 10) / 365) ## declination - + cosz <- sin(lat * pi/180) * sin(dec) + cos(lat * pi/180) * cos(dec) * cos(h) cosz[cosz < 0] <- 0 - + rpot <- 1366 * cosz rpot <- rpot[1:length(SW)] - + SW[rpot < SW] <- rpot[rpot < SW] ## ensure radiation < max ### this causes trouble at twilight bc of missmatch btw bin avergage and bin midpoint frac <- SW/rpot @@ -225,7 +218,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l frac[is.na(frac)] <- 0 frac[is.nan(frac)] <- 0 SWd <- SW * (1 - frac) ## Diffuse portion of total short wave rad - + ### convert to ED2.1 hdf met variables n <- length(Tair) nbdsfA <- (SW - SWd) * 0.57 # near IR beam downward solar radiation [W/m2] @@ -243,10 +236,10 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l if (useCO2) { co2A <- CO2 * 1e+06 # surface co2 concentration [ppm] converted from mole fraction [kg/kg] } - + ## create directory if(system(paste('ls',froot),ignore.stderr=TRUE)>0) ## system(paste('mkdir',froot)) - + ## write by year and month for (y in year + 1:nyr - 1) { sely <- which(yr == y) @@ -298,11 +291,11 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l } } } - + ## write DRIVER file sites <- 1 metgrid <- c(1, 1, 1, 1, lon, lat) - metvar <- c("nbdsf", "nddsf", "vbdsf", "vddsf", "prate", "dlwrf", + metvar <- c("nbdsf", "nddsf", "vbdsf", "vddsf", "prate", "dlwrf", "pres", "hgt", "ugrd", "vgrd", "sh", "tmp", "co2") nmet <- length(metvar) metfrq <- rep(dt, nmet) @@ -313,18 +306,18 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l } write.table("header", met_header, row.names = FALSE, col.names = FALSE) write.table(sites, met_header, row.names = FALSE, col.names = FALSE, append = TRUE) - write.table(met_folder, met_header, row.names = FALSE, col.names = FALSE, append = TRUE, + write.table(met_folder, met_header, row.names = FALSE, col.names = FALSE, append = TRUE, quote = FALSE) - write.table(matrix(metgrid, nrow = 1), met_header, row.names = FALSE, col.names = FALSE, + write.table(matrix(metgrid, nrow = 1), met_header, row.names = FALSE, col.names = FALSE, append = TRUE, quote = FALSE) write.table(nmet, met_header, row.names = FALSE, col.names = FALSE, append = TRUE, quote = FALSE) write.table(matrix(metvar, nrow = 1), met_header, row.names = FALSE, col.names = FALSE, append = TRUE) - write.table(matrix(metfrq, nrow = 1), met_header, row.names = FALSE, col.names = FALSE, append = TRUE, + write.table(matrix(metfrq, nrow = 1), met_header, row.names = FALSE, col.names = FALSE, append = TRUE, quote = FALSE) - write.table(matrix(metflag, nrow = 1), met_header, row.names = FALSE, col.names = FALSE, + write.table(matrix(metflag, nrow = 1), met_header, row.names = FALSE, col.names = FALSE, append = TRUE, quote = FALSE) } ### end loop over met files - + print("Done with met2model.ED2") return(invisible(results)) } # met2model.ED2 diff --git a/models/ed/R/model2netcdf.ED2.R b/models/ed/R/model2netcdf.ED2.R index 4a3c097da90..4e4e59270c6 100644 --- a/models/ed/R/model2netcdf.ED2.R +++ b/models/ed/R/model2netcdf.ED2.R @@ -1,6 +1,6 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. -# All rights reserved. This program and the accompanying materials +# All rights reserved. This program and the accompanying materials # are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at @@ -8,7 +8,7 @@ #------------------------------------------------------------------------------- ##' Modified from Code to convert ED2.1's HDF5 output into the NACP Intercomparison format (ALMA using netCDF) -##' +##' ##' @name model2netcdf.ED2 ##' @title Code to convert ED2's -T- HDF5 output into netCDF format ##' @@ -23,13 +23,13 @@ ##' @author Michael Dietze, Shawn Serbin, Rob Kooper, Toni Viskari, Istem Fer ## modified M. Dietze 07/08/12 modified S. Serbin 05/06/13 model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { - + flist <- dir(outdir, "-T-") if (length(flist) == 0) { print(paste("*** WARNING: No tower output for :", outdir)) return(NULL) } - + ## extract data info from file names? yr <- rep(NA, length(flist)) for (i in seq_along(flist)) { @@ -40,7 +40,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { yr[i] <- as.numeric(substr(flist[i], index + 3, index + 6)) ## yr[i] <- as.numeric(substr(tmp,1,4)) # Edited by SPS } - + add <- function(dat, col, row, year) { ## data is always given for whole year, except it will start always at 0 ## the left over data is filled with 0's @@ -54,7 +54,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { } else { end <- as.numeric(strftime(paste0(year, "-12-31"), "%j")) * block } - + dims <- dim(dat) if (is.null(dims)) { if (length(dat) == 1) { @@ -62,7 +62,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out[[col]] <- array(dat, dim = (end - start)) } else { if (start != 0) { - PEcAn.logger::logger.warn("start date is not 0 this year, but data already exists in this col", + PEcAn.logger::logger.warn("start date is not 0 this year, but data already exists in this col", col, "how is this possible?") } out[[col]] <- abind::abind(out[[col]], array(dat, dim = (end - start)), along = 1) @@ -76,7 +76,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out[[col]] <- dat } else { if (start != 0) { - PEcAn.logger::logger.warn("start date is not 0 this year, but data already exists in this col", + PEcAn.logger::logger.warn("start date is not 0 this year, but data already exists in this col", col, "how is this possible?") } out[[col]] <- abind::abind(out[[col]], dat, along = 1) @@ -89,7 +89,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out[[col]] <- dat } else { if (start != 0) { - PEcAn.logger::logger.warn("start date is not 0 this year, but data already exists in this col", + PEcAn.logger::logger.warn("start date is not 0 this year, but data already exists in this col", col, "how is this possible?") } out[[col]] <- abind::abind(out[[col]], dat, along = 1) @@ -103,14 +103,14 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { PEcAn.logger::logger.debug("dims=", dims) PEcAn.logger::logger.warn("Don't know how to handle larger arrays yet.") } - + ## finally make sure we use -999 for invalid values out[[col]][is.null(out[[col]])] <- -999 out[[col]][is.na(out[[col]])] <- -999 - + return(out) } - + getHdf5Data <- function(nc, var) { if (var %in% names(nc$var)) { return(ncdf4::ncvar_get(nc, var)) @@ -119,28 +119,28 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { return(-999) } } - + CheckED2Version <- function(nc) { if ("FMEAN_BDEAD_PY" %in% names(nc$var)) { return("Git") } } - + # TODO - remove this function and replace with ifelse statements inline below (SPS) conversion <- function(col, mult) { ## make sure only to convert those values that are not -999 out[[col]][out[[col]] != -999] <- out[[col]][out[[col]] != -999] * mult return(out) } - + checkTemp <- function(col) { out[[col]][out[[col]] == 0] <- -999 return(out) } - + ## loop over files ### break by YEAR yrs <- sort(unique(yr)) - for (y in 1:length(yrs)) { + for (y in seq_along(yrs)) { ysel <- which(yr == yrs[y]) if (yrs[y] < strftime(start_date, "%Y")) { print(paste0(yrs[y], "<", strftime(start_date, "%Y"))) @@ -160,10 +160,9 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { for (i in ysel) { ncT <- ncdf4::nc_open(file.path(outdir, flist[i])) ## determine timestep from HDF5 file - block <- ifelse(lubridate::leap_year(yrs[y]) == TRUE, - ncT$dim$phony_dim_0$len/366, # a leaper - ncT$dim$phony_dim_0$len/365) # non leap - PEcAn.logger::logger.info(paste0("Output interval: ",86400/block," sec")) + diy <- PEcAn.utils::days_in_year(yrs[y]) + block <- ncT$dim$phony_dim_0$len / diy + PEcAn.logger::logger.info(paste0("Output interval: ", 86400/block, " sec")) ## if (file.exists(file.path(outdir, sub("-T-", "-Y-", flist[i])))) { ncY <- ncdf4::nc_open(file.path(outdir, sub("-T-", "-Y-", flist[i]))) @@ -173,14 +172,14 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { PEcAn.logger::logger.warn("Could not find SLZ in Y file, making a crude assumpution.") slzdata <- array(c(-2, -1.5, -1, -0.8, -0.6, -0.4, -0.2, -0.1, -0.05)) } - + ## Check for which version of ED2 we are using. ED2vc <- CheckED2Version(ncT) - + ## store for later use, will only use last data dz <- diff(slzdata) dz <- dz[dz != 0] - + if (!is.null(ED2vc)) { ## out <- add(getHdf5Data(ncT, 'TOTAL_AGB,1,row, yrs[y]) ## AbvGrndWood out <- add(getHdf5Data(ncT, "FMEAN_BDEAD_PY"), 1, row, yrs[y]) ## AbvGrndWood @@ -190,17 +189,17 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out <- add(-999, 5, row, yrs[y]) ## CropYield out <- add(getHdf5Data(ncT, "FMEAN_GPP_PY"), 6, row, yrs[y]) ## GPP out <- add(getHdf5Data(ncT, "FMEAN_RH_PY"), 7, row, yrs[y]) ## HeteroResp - out <- add(-getHdf5Data(ncT, "FMEAN_GPP_PY") + getHdf5Data(ncT, "FMEAN_PLRESP_PY") + + out <- add(-getHdf5Data(ncT, "FMEAN_GPP_PY") + getHdf5Data(ncT, "FMEAN_PLRESP_PY") + getHdf5Data(ncT, "FMEAN_RH_PY"), 8, row, yrs[y]) ## NEE - out <- add(getHdf5Data(ncT, "FMEAN_GPP_PY") - getHdf5Data(ncT, "FMEAN_PLRESP_PY"), + out <- add(getHdf5Data(ncT, "FMEAN_GPP_PY") - getHdf5Data(ncT, "FMEAN_PLRESP_PY"), 9, row, yrs[y]) ## NPP - out <- add(getHdf5Data(ncT, "FMEAN_RH_PY") + getHdf5Data(ncT, "FMEAN_PLRESP_PY"), + out <- add(getHdf5Data(ncT, "FMEAN_RH_PY") + getHdf5Data(ncT, "FMEAN_PLRESP_PY"), 10, row, yrs[y]) ## TotalResp ## out <- add(getHdf5Data(ncT, 'BDEAD + getHdf5Data(ncT, 'BALIVE,11,row, yrs[y]) ## TotLivBiom out <- add(-999, 11, row, yrs[y]) ## TotLivBiom - out <- add(getHdf5Data(ncT, "FAST_SOIL_C_PY") + getHdf5Data(ncT, "STRUCT_SOIL_C_PY") + + out <- add(getHdf5Data(ncT, "FAST_SOIL_C_PY") + getHdf5Data(ncT, "STRUCT_SOIL_C_PY") + getHdf5Data(ncT, "SLOW_SOIL_C_PY"), 12, row, yrs[y]) ## TotSoilCarb - + ## depth from surface to frozen layer tdepth <- 0 fdepth <- 0 @@ -211,11 +210,11 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { for (t in 1:dim(soiltemp)[1]) { # time for (p in 1:dim(soiltemp)[2]) { # polygon for (i in dim(soiltemp)[3]:2) { # depth - if (fdepth[t, p] == 0 & soiltemp[t, p, i] < 273.15 & + if (fdepth[t, p] == 0 & soiltemp[t, p, i] < 273.15 & soiltemp[t, p, i - 1] > 273.13) { fdepth[t, p] <- i } - if (tdepth[t, p] == 0 & soiltemp[t, p, i] > 273.15 & + if (tdepth[t, p] == 0 & soiltemp[t, p, i] > 273.15 & soiltemp[t, p, i - 1] < 273.13) { tdepth[t, p] <- i } @@ -224,14 +223,14 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { z1 <- (SLZ[fdepth[t, p] + 1] + SLZ[fdepth[t, p]]) / 2 z2 <- (SLZ[fdepth[t, p]] + SLZ[fdepth[t, p] - 1]) / 2 if (fdepth[t, p] > 0) { - fdepth[t, p] <- z1 + (z2 - z1) * (273.15 - soiltemp[t, p, fdepth[t, p]]) / + fdepth[t, p] <- z1 + (z2 - z1) * (273.15 - soiltemp[t, p, fdepth[t, p]]) / (soiltemp[t, p, fdepth[t, p] - 1] - soiltemp[t, p, fdepth[t, p]]) } if (tdepth[t, p] > 0) { SLZ <- c(slzdata[t, ], 0) z1 <- (SLZ[tdepth[t, p] + 1] + SLZ[tdepth[t, p]]) / 2 z2 <- (SLZ[tdepth[t, p]] + SLZ[tdepth[t, p] - 1]) / 2 - tdepth[t, p] <- z1 + (z2 - z1) * (273.15 - soiltemp[t, p, tdepth[t, p]]) / + tdepth[t, p] <- z1 + (z2 - z1) * (273.15 - soiltemp[t, p, tdepth[t, p]]) / (soiltemp[t, p, tdepth[t, p] - 1] - soiltemp[t, p, tdepth[t, p]]) } } @@ -253,19 +252,19 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { SLZ <- c(slzdata, 0) z1 <- (SLZ[fdepth[t] + 1] + SLZ[fdepth[t]]) / 2 z2 <- (SLZ[fdepth[t]] + SLZ[fdepth[t] - 1]) / 2 - fdepth[t] <- z1 + (z2 - z1) * (273.15 - soiltemp[fdepth[t], t]) / + fdepth[t] <- z1 + (z2 - z1) * (273.15 - soiltemp[fdepth[t], t]) / (soiltemp[fdepth[t] - 1, t] - soiltemp[fdepth[t], t]) } if (tdepth[t] > 0) { SLZ <- c(slzdata, 0) z1 <- (SLZ[tdepth[t] + 1] + SLZ[tdepth[t]]) / 2 z2 <- (SLZ[tdepth[t]] + SLZ[tdepth[t] - 1]) / 2 - tdepth[t] <- z1 + (z2 - z1) * (273.15 - soiltemp[tdepth[t], t]) / + tdepth[t] <- z1 + (z2 - z1) * (273.15 - soiltemp[tdepth[t], t]) / (soiltemp[tdepth[t] - 1, t] - soiltemp[tdepth[t], t]) } } } - + out <- add(fdepth, 13, row, yrs[y]) ## Fdepth out <- add(getHdf5Data(ncT, "FMEAN_SFCW_DEPTH_PY"), 14, row, yrs[y]) ## SnowDepth (ED2 currently groups snow in to surface water) out <- add(1 - getHdf5Data(ncT, "FMEAN_SFCW_FLIQ_PY"), 15, row, yrs[y]) ## SnowFrac (ED2 currently groups snow in to surface water) @@ -292,7 +291,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out <- add(-999, 26, row, yrs[y]) ## Qg ## out <- add(getHdf5Data(ncT, 'AVG_SENSIBLE_TOT'),27,row, yrs[y]) ## Qh out <- add(getHdf5Data(ncT, "FMEAN_SENSIBLE_AC_PY"), 27, row, yrs[y]) ## Qh - out <- add(getHdf5Data(ncT, "FMEAN_VAPOR_LC_PY") + getHdf5Data(ncT, "FMEAN_VAPOR_WC_PY") + + out <- add(getHdf5Data(ncT, "FMEAN_VAPOR_LC_PY") + getHdf5Data(ncT, "FMEAN_VAPOR_WC_PY") + getHdf5Data(ncT, "FMEAN_VAPOR_GC_PY"), 28, row, yrs[y]) ## Qle out <- add(-999, 29, row, yrs[y]) ## Swnet out <- add(-999, 30, row, yrs[y]) ## RootMoist @@ -302,7 +301,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { ##lai <- matrix(apply(getHdf5Data(ncT, 'LAI_PFT'),1,sum,na.rm=TRUE),nrow=block) ## out <- add(lai,34,row, yrs[y]) ## LAI****************** ## out <- add(getHdf5Data(ncT, 'FMEAN_LAI_PY'),34,row, yrs[y]) ## LAI - no longer using FMEAN LAI - + ## OLD - to be deprecated #laidata <- getHdf5Data(ncT,"LAI_PY") #if(length(dim(laidata)) == 3){ @@ -310,7 +309,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { #} else { # out <- add(-999,34,row, yrs[y]) #} - + # code changes proposed by MCD, tested by SPS 20160607 laidata <- getHdf5Data(ncT, "LAI_PY") if (length(dim(laidata)) == 3) { @@ -319,7 +318,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { } else { out <- add(-999, 34, row, yrs[y]) } - + ##z <- getHdf5Data(ncT, 'SLZ') ##if(z[length(z)] < 0.0) z <- c(z,0.0) ##dz <- diff(z) @@ -337,15 +336,15 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out <- add(getHdf5Data(ncT, "FMEAN_SFCW_TEMP_PY"), 41, row, yrs[y]) ## SnowT (ED2 currently groups snow in to surface water) out <- add(getHdf5Data(ncT, "FMEAN_SFCW_MASS_PY"), 42, row, yrs[y]) ## SWE (ED2 currently groups snow in to surface water) out <- add(getHdf5Data(ncT, "FMEAN_LEAF_TEMP_PY"), 43, row, yrs[y]) ## VegT - out <- add(getHdf5Data(ncT, "FMEAN_VAPOR_LC_PY") + getHdf5Data(ncT, "FMEAN_VAPOR_WC_PY") + - getHdf5Data(ncT, "FMEAN_VAPOR_GC_PY") + getHdf5Data(ncT, "FMEAN_TRANSP_PY"), 44, + out <- add(getHdf5Data(ncT, "FMEAN_VAPOR_LC_PY") + getHdf5Data(ncT, "FMEAN_VAPOR_WC_PY") + + getHdf5Data(ncT, "FMEAN_VAPOR_GC_PY") + getHdf5Data(ncT, "FMEAN_TRANSP_PY"), 44, row, yrs[y]) ## Evap out <- add(getHdf5Data(ncT, "FMEAN_QRUNOFF_PY"), 45, row, yrs[y]) ## Qs out <- add(getHdf5Data(ncT, "BASEFLOW"), 46, row, yrs[y]) ## Qsb - - out <- add(getHdf5Data(ncT, "FMEAN_ROOT_RESP_PY") + getHdf5Data(ncT, "FMEAN_ROOT_GROWTH_RESP_PY") + + + out <- add(getHdf5Data(ncT, "FMEAN_ROOT_RESP_PY") + getHdf5Data(ncT, "FMEAN_ROOT_GROWTH_RESP_PY") + getHdf5Data(ncT, "FMEAN_RH_PY"), 47, row, yrs[y]) ## SoilResp - + } else { ## out <- add(getHdf5Data(ncT, 'TOTAL_AGB,1,row, yrs[y]) ## AbvGrndWood out <- add(getHdf5Data(ncT, "AVG_BDEAD"), 1, row, yrs[y]) ## AbvGrndWood @@ -355,16 +354,16 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out <- add(-999, 5, row, yrs[y]) ## CropYield out <- add(getHdf5Data(ncT, "AVG_GPP"), 6, row, yrs[y]) ## GPP out <- add(getHdf5Data(ncT, "AVG_HTROPH_RESP"), 7, row, yrs[y]) ## HeteroResp - out <- add(-getHdf5Data(ncT, "AVG_GPP") + getHdf5Data(ncT, "AVG_PLANT_RESP") + getHdf5Data(ncT, + out <- add(-getHdf5Data(ncT, "AVG_GPP") + getHdf5Data(ncT, "AVG_PLANT_RESP") + getHdf5Data(ncT, "AVG_HTROPH_RESP"), 8, row, yrs[y]) ## NEE - out <- add(getHdf5Data(ncT, "AVG_GPP") - getHdf5Data(ncT, "AVG_PLANT_RESP"), 9, row, + out <- add(getHdf5Data(ncT, "AVG_GPP") - getHdf5Data(ncT, "AVG_PLANT_RESP"), 9, row, yrs[y]) ## NPP - out <- add(getHdf5Data(ncT, "AVG_HTROPH_RESP") + getHdf5Data(ncT, "AVG_PLANT_RESP"), + out <- add(getHdf5Data(ncT, "AVG_HTROPH_RESP") + getHdf5Data(ncT, "AVG_PLANT_RESP"), 10, row, yrs[y]) ## TotalResp ## out <- add(getHdf5Data(ncT, 'AVG_BDEAD + getHdf5Data(ncT, 'AVG_BALIVE,11,row, yrs[y]) ## ## TotLivBiom out <- add(-999, 11, row, yrs[y]) ## TotLivBiom - out <- add(getHdf5Data(ncT, "AVG_FSC") + getHdf5Data(ncT, "AVG_STSC") + + out <- add(getHdf5Data(ncT, "AVG_FSC") + getHdf5Data(ncT, "AVG_STSC") + getHdf5Data(ncT, "AVG_SSC"), 12, row, yrs[y]) ## TotSoilCarb ## depth from surface to frozen layer tdepth <- 0 @@ -376,11 +375,11 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { for (t in 1:dim(soiltemp)[1]) { # time for (p in 1:dim(soiltemp)[2]) { # polygon for (i in dim(soiltemp)[3]:2) { # depth - if (fdepth[t, p] == 0 & soiltemp[t, p, i] < 273.15 & + if (fdepth[t, p] == 0 & soiltemp[t, p, i] < 273.15 & soiltemp[t, p, i - 1] > 273.13) { fdepth[t, p] <- i } - if (tdepth[t, p] == 0 & soiltemp[t, p, i] > 273.15 & + if (tdepth[t, p] == 0 & soiltemp[t, p, i] > 273.15 & soiltemp[t, p, i - 1] < 273.13) { tdepth[t, p] <- i } @@ -389,14 +388,14 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { z1 <- (SLZ[fdepth[t, p] + 1] + SLZ[fdepth[t, p]]) / 2 z2 <- (SLZ[fdepth[t, p]] + SLZ[fdepth[t, p] - 1]) / 2 if (fdepth[t, p] > 0) { - fdepth[t, p] <- z1 + (z2 - z1) * (273.15 - soiltemp[t, p, fdepth[t, p]]) / + fdepth[t, p] <- z1 + (z2 - z1) * (273.15 - soiltemp[t, p, fdepth[t, p]]) / (soiltemp[t, p, fdepth[t, p] - 1] - soiltemp[t, p, fdepth[t, p]]) } if (tdepth[t, p] > 0) { SLZ <- c(slzdata[t, ], 0) z1 <- (SLZ[tdepth[t, p] + 1] + SLZ[tdepth[t, p]]) / 2 z2 <- (SLZ[tdepth[t, p]] + SLZ[tdepth[t, p] - 1]) / 2 - tdepth[t, p] <- z1 + (z2 - z1) * (273.15 - soiltemp[t, p, tdepth[t, p]]) / + tdepth[t, p] <- z1 + (z2 - z1) * (273.15 - soiltemp[t, p, tdepth[t, p]]) / (soiltemp[t, p, tdepth[t, p] - 1] - soiltemp[t, p, tdepth[t, p]]) } } @@ -418,19 +417,19 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { SLZ <- c(slzdata, 0) z1 <- (SLZ[fdepth[t] + 1] + SLZ[fdepth[t]]) / 2 z2 <- (SLZ[fdepth[t]] + SLZ[fdepth[t] - 1]) / 2 - fdepth[t] <- z1 + (z2 - z1) * (273.15 - soiltemp[fdepth[t], t]) / + fdepth[t] <- z1 + (z2 - z1) * (273.15 - soiltemp[fdepth[t], t]) / (soiltemp[fdepth[t] - 1, t] - soiltemp[fdepth[t], t]) } if (tdepth[t] > 0) { SLZ <- c(slzdata, 0) z1 <- (SLZ[tdepth[t] + 1] + SLZ[tdepth[t]]) / 2 z2 <- (SLZ[tdepth[t]] + SLZ[tdepth[t] - 1]) / 2 - tdepth[t] <- z1 + (z2 - z1) * (273.15 - soiltemp[tdepth[t], t]) / + tdepth[t] <- z1 + (z2 - z1) * (273.15 - soiltemp[tdepth[t], t]) / (soiltemp[tdepth[t] - 1, t] - soiltemp[tdepth[t], t]) } } } - + out <- add(fdepth, 13, row, yrs[y]) ## Fdepth out <- add(getHdf5Data(ncT, "AVG_SNOWDEPTH"), 14, row, yrs[y]) ## SnowDepth out <- add(1 - getHdf5Data(ncT, "AVG_SNOWFRACLIQ"), 15, row, yrs[y]) ## SnowFrac @@ -444,7 +443,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { ## getHdf5Data(ncT, 'AVG_NIR_DIFFUSE')+ ## getHdf5Data(ncT, 'AVG_PAR_BEAM')+ ## getHdf5Data(ncT, 'AVG_PAR_DIFFUSE'),22,row, yrs[y]) ## Swdown - out <- add(getHdf5Data(ncT, "AVG_PAR_BEAM") + getHdf5Data(ncT, "AVG_PAR_DIFFUSE"), + out <- add(getHdf5Data(ncT, "AVG_PAR_BEAM") + getHdf5Data(ncT, "AVG_PAR_DIFFUSE"), 22, row, yrs[y]) ## Swdown out <- add(getHdf5Data(ncT, "AVG_ATM_TMP"), 23, row, yrs[y]) ## Tair out <- add(getHdf5Data(ncT, "AVG_VELS"), 24, row, yrs[y]) ## Wind @@ -481,30 +480,30 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { out <- add(getHdf5Data(ncT, "AVG_SNOWTEMP"), 41, row, yrs[y]) ## SnowT out <- add(getHdf5Data(ncT, "AVG_SNOWMASS"), 42, row, yrs[y]) ## SWE out <- add(getHdf5Data(ncT, "AVG_VEG_TEMP"), 43, row, yrs[y]) ## VegT - out <- add(getHdf5Data(ncT, "AVG_EVAP") + getHdf5Data(ncT, "AVG_TRANSP"), 44, row, + out <- add(getHdf5Data(ncT, "AVG_EVAP") + getHdf5Data(ncT, "AVG_TRANSP"), 44, row, yrs[y]) ## Evap out <- add(getHdf5Data(ncT, "AVG_RUNOFF"), 45, row, yrs[y]) ## Qs - out <- add(getHdf5Data(ncT, "BASEFLOW"), 46, row, yrs[y]) ## Qsb - out <- add(getHdf5Data(ncT, "AVG_ROOT_RESP") + getHdf5Data(ncT, "AVG_ROOT_MAINTENANCE") + + out <- add(getHdf5Data(ncT, "BASEFLOW"), 46, row, yrs[y]) ## Qsb + out <- add(getHdf5Data(ncT, "AVG_ROOT_RESP") + getHdf5Data(ncT, "AVG_ROOT_MAINTENANCE") + getHdf5Data(ncT, "AVG_HTROPH_RESP"), 47, row, yrs[y]) ## SoilResp } - + ncdf4::nc_close(ncT) ## prevTime <- progressBar(i/n,prevTime) row <- row + block - - } ## end file loop - - #out[[10]] <- out[[10]]*1.2e-8 + + } ## end file loop + + #out[[10]] <- out[[10]]*1.2e-8 ## TODO see bug #1174 ## for(t in 1:dim(out[[37]])[1]){ ## for(p in 1:dim(out[[37]])[2]){ ## out[[37]][t,p,] <- out[[37]][t,p,]*1000*dz ## m/m -> kg/m2 ## } ##} - + ## declare variables - + ## figure out what start day is, if not same year as start_date then it is 1 if (yrs[y] == strftime(start_date, "%Y")) { start <- (as.numeric(strftime(start_date, "%j")) - 1) * block @@ -516,19 +515,19 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { } else { end <- (as.numeric(strftime(paste0(yrs[y], "-12-31"), "%j"))) * block - 1 } - - t <- ncdim_def(name = "time", units = paste0("days since ", yrs[y], "-01-01 00:00:00"), vals = start:end/block, + + t <- ncdim_def(name = "time", units = paste0("days since ", yrs[y], "-01-01 00:00:00"), vals = start:end/block, calendar = "standard", unlim = TRUE) lat <- ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") lon <- ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") - + zg <- ncdim_def("SoilLayerMidpoint", "meters", c(slzdata[1:length(dz)] + dz/2, 0)) - + ## Conversion factor for umol C -> kg C Mc <- 12.017 #molar mass of C, g/mol umol2kg_C <- Mc * udunits2::ud.convert(1, "umol", "mol") * udunits2::ud.convert(1, "g", "kg") yr2s <- udunits2::ud.convert(1, "s", "yr") - + nc_var <- list() out <- conversion(1, udunits2::ud.convert(1, "t ha-1", "kg m-2")) ## tC/ha -> kg/m2 nc_var[[1]] <- mstmipvar("AbvGrndWood", lat, lon, t, zg) @@ -538,19 +537,19 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { nc_var[[4]] <- mstmipvar("CO2CAS", lat, lon, t, zg) nc_var[[5]] <- mstmipvar("CropYield", lat, lon, t, zg) out <- conversion(6, yr2s) ## kg C m-2 yr-1 -> kg C m-2 s-1 - nc_var[[6]]<- ncdf4::ncvar_def("GPP", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, + nc_var[[6]]<- ncdf4::ncvar_def("GPP", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, longname = "Gross Primary Productivity") out <- conversion(7, yr2s) ## kg C m-2 yr-1 -> kg C m-2 s-1 - nc_var[[7]]<- ncdf4::ncvar_def("HeteroResp", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, + nc_var[[7]]<- ncdf4::ncvar_def("HeteroResp", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, longname = "Heterotrophic Respiration") out <- conversion(8, yr2s) ## kg C m-2 yr-1 -> kg C m-2 s-1 - nc_var[[8]]<- ncdf4::ncvar_def("NEE", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, + nc_var[[8]]<- ncdf4::ncvar_def("NEE", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, longname = "Net Ecosystem Exchange") out <- conversion(9, yr2s) ## kg C m-2 yr-1 -> kg C m-2 s-1 - nc_var[[9]]<- ncdf4::ncvar_def("NPP", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, + nc_var[[9]]<- ncdf4::ncvar_def("NPP", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, longname = "Net Primary Productivity") out <- conversion(10, yr2s) ## kg C m-2 yr-1 -> kg C m-2 s-1 - nc_var[[10]]<- ncdf4::ncvar_def("TotalResp", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, + nc_var[[10]]<- ncdf4::ncvar_def("TotalResp", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, longname = "Total Respiration") nc_var[[11]] <- mstmipvar("TotLivBiom", lat, lon, t, zg) nc_var[[12]] <- mstmipvar("TotSoilCarb", lat, lon, t, zg) @@ -571,7 +570,7 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { nc_var[[26]] <- mstmipvar("Qg", lat, lon, t, zg) nc_var[[27]] <- mstmipvar("Qh", lat, lon, t, zg) out <- conversion(28,PEcAn.data.atmosphere::get.lv()) ## kg m-2 s-1 -> W m-2 - nc_var[[28]]<- ncdf4::ncvar_def("Qle", units = "W m-2", dim = list(lon, lat, t), missval = -999, + nc_var[[28]]<- ncdf4::ncvar_def("Qle", units = "W m-2", dim = list(lon, lat, t), missval = -999, longname = "Latent heat") nc_var[[29]] <- mstmipvar("SWnet", lat, lon, t, zg) nc_var[[30]] <- mstmipvar("RootMoist", lat, lon, t, zg) @@ -597,9 +596,9 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { nc_var[[45]] <- mstmipvar("Qs", lat, lon, t, zg) nc_var[[46]] <- mstmipvar("Qsb", lat, lon, t, zg) out <- conversion(47, yr2s) ## kg C m-2 yr-1 -> kg C m-2 s-1 - nc_var[[47]]<- ncdf4::ncvar_def("SoilResp", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, + nc_var[[47]]<- ncdf4::ncvar_def("SoilResp", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, longname = "Soil Respiration") - + ## write ALMA nc <- ncdf4::nc_create(file.path(outdir, paste(yrs[y], "nc", sep = ".")), nc_var) varfile <- file(file.path(outdir, paste(yrs[y], "nc", "var", sep = ".")), "w") @@ -609,8 +608,8 @@ model2netcdf.ED2 <- function(outdir, sitelat, sitelon, start_date, end_date) { } close(varfile) ncdf4::nc_close(nc) - + } ## end year loop - + } # model2netcdf.ED2 ##-------------------------------------------------------------------------------------------------# diff --git a/models/jules/R/write.config.JULES.R b/models/jules/R/write.config.JULES.R index e6520d53077..80ec82d3520 100644 --- a/models/jules/R/write.config.JULES.R +++ b/models/jules/R/write.config.JULES.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -21,9 +21,9 @@ ##' @param run.id id of run ##' @return configuration file for JULES for given run ##' @author Mike Dietze, Rob Kooper -##' +##' ##' @export -##' @examples +##' @examples ##' \dontrun{ ##' write.config.JULES(defaults, trait.values, settings, run.id) ##' } @@ -35,13 +35,13 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { useTRIFFID <- "TRIFFID" %in% toupper(names(settings$model)) start_date <- settings$run$start.date run.local <- settings$host$name == "localhost" | settings$host$name == PEcAn.utils::fqdn() - + # find out where to write run/output rundir <- file.path(settings$host$rundir, run.id) outdir <- file.path(settings$host$outdir, run.id) local.outdir <- file.path(settings$outdir,run.id) local.rundir <- file.path(settings$rundir, run.id) - + #----------------------------------------------------------------------- # create launch script (which will create symlink) if (!is.null(settings$model$jobtemplate) && file.exists(settings$model$jobtemplate)) { @@ -49,7 +49,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { } else { jobsh <- readLines(con = system.file("template.job", package = "PEcAn.JULES"), n = -1) } - + # create host specific setttings hostsetup <- "" if (!is.null(settings$model$prerun)) { @@ -58,7 +58,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { if (!is.null(settings$host$prerun)) { hostsetup <- paste(hostsetup, sep = "\n", paste(settings$host$prerun, collapse = "\n")) } - + hostteardown <- "" if (!is.null(settings$model$postrun)) { hostteardown <- paste(hostteardown, sep = "\n", paste(settings$model$postrun, collapse = "\n")) @@ -66,18 +66,18 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { if (!is.null(settings$host$postrun)) { hostteardown <- paste(hostteardown, sep = "\n", paste(settings$host$postrun, collapse = "\n")) } - + # create job.sh jobsh <- gsub("@HOST_SETUP@", hostsetup, jobsh) jobsh <- gsub("@HOST_TEARDOWN@", hostteardown, jobsh) - + jobsh <- gsub("@OUTDIR@", outdir, jobsh) jobsh <- gsub("@RUNDIR@", rundir, jobsh) jobsh <- gsub("@RUNID@", run.id, jobsh) jobsh <- gsub("@BINARY@", settings$model$binary, jobsh) writeLines(jobsh, con = file.path(local.rundir, "job.sh")) Sys.chmod(file.path(local.rundir, "job.sh")) - + #----------------------------------------------------------------------- ### Copy templated NAMELIST files to local rundir if (!is.null(settings$model$config) && dir.exists(settings$model$config)) { @@ -86,7 +86,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { template.dir <- file.path(system.file(package = "PEcAn.JULES"), paste0("template_nml_", settings$model$revision)) } system2("cp", args = paste0(template.dir, "/* ", local.rundir)) - + ## ------------------ Detect time step of met data ------------------ nchar.path <- nchar(settings$run$inputs$met$path) if(substring(settings$run$inputs$met$path,nchar.path)=="/"){ @@ -107,7 +107,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { dt <- PEcAn.utils::remote.execute.R(script=rmt.cmd,host=settings$host,verbose=TRUE) } ## -------------------- END DETECT TIMESTEP -------------------- - + ## PEcAn SPIN-UP: symlink met files, change start date. if(!is.null(settings$spin)){ if(run.local){ @@ -135,7 +135,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { start_date <- PEcAn.utils::remote.execute.R(script=rmt.cmd,host=settings$host,verbose=TRUE) } } ## end spin - + ## set up date strings start_char <- format(as.Date(start_date), "%F %H:%M:%S") year_char <- strsplit(start_char,"-")[[1]][1] @@ -146,8 +146,8 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { } end_char <- format(as.Date(settings$run$end.date), "%F %H:%M:%S") met_end_char <- format(as.Date(settings$run$site$met.end), "%F %H:%M:%S") - - + + ## Edit DRIVE.NML to set met variables drive.file <- file.path(local.rundir, "drive.nml") drive.text <- readLines(con = drive.file, n = -1) @@ -156,29 +156,29 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { drive.text <- gsub("@SITE_MET@", file.path(dirname(settings$run$inputs$met$path),prefix), drive.text) drive.text <- gsub("@DT@", as.numeric(dt), drive.text) writeLines(drive.text, con = drive.file) - + ## Edit TIMESTEPS.NML to set start/end date timesteps.file <- file.path(local.rundir, "timesteps.nml") timesteps.text <- readLines(con = timesteps.file, n = -1) timesteps.text <- gsub("@START_DATE@", start_char, timesteps.text) timesteps.text <- gsub("@END_DATE@", end_char, timesteps.text) writeLines(timesteps.text, con = timesteps.file) - + ## Edit PRESCRIBED_DATA.NML to add CO2 data if("co2" %in% tolower(names(settings$run$inputs))){ pd.file <- file.path(local.rundir, "prescribed_data.nml") pd.text <- readLines(con = pd.file, n = -1) - + ## SPIN the CO2 file if(!is.null(settings$spin)){ dt.co2 = udunits2::ud.convert(as.numeric(as.Date(settings$run$end.date)- as.Date(settings$run$start.date)),"days","years") - co2.dat <- read.table(settings$run$inputs$co2$path,header=FALSE) - co2.per.year <- round(nrow(co2.dat)/dt.co2) - + co2.dat <- read.table(settings$run$inputs$co2$path,header=FALSE) + co2.per.year <- round(nrow(co2.dat)/dt.co2) + ## as first pass, just repeat the whole sequence. Not doing resampling. Not worrying about how to loop the file co2.dat <- c(as.vector(co2.dat[seq_len(as.numeric(settings$spin$nyear)*co2.per.year+1),]),unlist(co2.dat)) - + co2.local <- file.path(local.rundir,basename(settings$run$inputs$co2$path)) write.table(co2.dat,file = co2.local,col.names = FALSE,row.names = FALSE) if(run.local){ @@ -187,10 +187,10 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { co2.remote <- file.path(rundir,basename(settings$run$inputs$co2$path)) settings$run$inputs$co2$path <- co2.remote } - + PEcAn.logger::logger.debug("co2.local",co2.local,length(co2.dat)) } - + ## add CO2 file pdn <- length(pd.text) pd.text[pdn+1] <- paste0("") @@ -203,37 +203,37 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { pd.text[pdn+8] <- paste0("var='co2_mmr'") pd.text[pdn+9] <- paste0("interp='i'") pd.text[pdn+10] <- paste0("/") - + # EXAMPLE # &JULES_PRESCRIBED_DATASET # data_start = '0850-01-01 00:00:00', # data_end = '2011-01-01 00:00:00', - # + # # data_period=-1 - # + # # file='../../../../phase1a_env_drivers_v4/Paleon_CO2_mmr.txt' - # + # # nvars=1 # var='co2_mmr' # interp='i' - # + # # / - + ## update n_datasets nd_i <- grep("n_datasets",pd.text) pd_nd <- as.numeric(sub(",","",strsplit(pd.text[nd_i],"=")[[1]][2])) pd.text[nd_i] = paste0("n_datasets=",pd_nd+1,",") - + writeLines(pd.text, con = pd.file) } - + ## Edit MODEL_GRID.NML to set lat/lon grid.file <- file.path(local.rundir, "model_grid.nml") grid.text <- readLines(con = grid.file, n = -1) grid.text <- gsub("@SITE_LAT@", settings$run$site$lat, grid.text) grid.text <- gsub("@SITE_LON@", settings$run$site$lon, grid.text) writeLines(grid.text, con = grid.file) - + ## Edit OUTPUT.NML to set run.id output.file <- file.path(local.rundir, "output.nml") output.text <- readLines(con = output.file, n = -1) @@ -252,29 +252,29 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { out_nvar <- as.numeric(sub(",","",strsplit(output.text[out_nvar_i],"=")[[1]][2])) output.text[out_nvar_i] = paste0("nvars = ",out_nvar+3,",") output.text[out_type_i] = paste0("output_type = ",out_nvar+3,"*'M',") - + ## add to out_varname k <- which(rev((len > 0)[1:(out_type_i-1)]))[1] ## how many lines back is previous block output.text[out_type_i-k] <- paste0(output.text[out_type_i-k], " 'Fcomp', 'TotLivBio_PFT', 'Height',") - + ## add extra output variables k <- which(rev((len > 0)[1:(out_varname_i-1)]))[1] ## how many lines back is previous block output.text[out_varname_i-k] <- paste0(output.text[out_varname_i-k], " 'frac', 'c_veg', 'canht',") } writeLines(output.text, con = output.file) - + ## Edit ANCILLARIES.NML tile frac soil physical parameters [[OPTIONAL]] if("soil" %in% names(settings$run$inputs)){ ## open soil file soil <- settings$run$inputs$soil nc.soil <- ncdf4::nc_open(soil$path) - + ## extract JULES variables in.soil <- list() in.soil[['b']] <- ncdf4::ncvar_get(nc.soil,"soil_hydraulic_b") - # sathh + # sathh in.soil[['satcon']] <- ncdf4::ncvar_get(nc.soil,"soil_hydraulic_conductivity_at_saturation") in.soil[['satcon']] <- udunits2::ud.convert(in.soil[['satcon']],"m s-1","mm s-1") in.soil[['sm_sat']] <- ncdf4::ncvar_get(nc.soil,"volume_fraction_of_water_in_soil_at_saturation") @@ -286,18 +286,18 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { in.soil[['hcon']] <- ncdf4::ncvar_get(nc.soil,"soil_thermal_conductivity") ## W m-1 K-1 in.soil[['albsoil']] <- ncdf4::ncvar_get(nc.soil,"soil_albedo") ncdf4::nc_close(nc.soil) - + ## open namelist anc.file <- file.path(local.rundir, "ancillaries.nml") anc.text <- readLines(con = anc.file, n = -1) - + ## parse variable names const_val_i <- grep("const_val",anc.text) const_val <- strsplit(strsplit(anc.text[const_val_i],"=")[[1]][2],",")[[1]] soil_var_i <- grep("^var",anc.text) soil_var <- strsplit(strsplit(anc.text[soil_var_i],"=")[[1]][2],",")[[1]] soil_var <- gsub("'","",soil_var) - + ## substitute in new values for(i in seq_along(soil_var)){ k = which(names(in.soil) == soil_var[i]) @@ -306,13 +306,13 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { ## need to figure out how to set depth profile later } } - + ## insert back into text anc.text[const_val_i] <- paste0("const_val=",paste(const_val,sep = "",collapse = ","),",") writeLines(anc.text, con = anc.file) - + } ## end ancillary - + ## PARSE JULES_VEGETATION.NML some of these settings affect which parameter settings are used veg.file <- file.path(local.rundir, "jules_vegetation.nml") veg.text <- readLines(con = veg.file, n = -1) @@ -324,10 +324,10 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { } ## Turn on TRIFFID?? if(useTRIFFID){ - + l_triffid <- grep("l_triffid",veg.text) veg.text[l_triffid] <- sub("false",'true',veg.text[l_triffid]) - + l_trif_eq <- grep("l_trif_eq",veg.text) if(length(l_trif_eq) == 0){ veg.text[length(veg.text)] <- "l_trif_eq=.false.," @@ -335,7 +335,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { } else { veg.text[l_trif_eq] <- sub("true",'false',veg.text[l_triffid]) # set to FALSE } - + l_veg_compete <- grep("l_veg_compete",veg.text) if(length(l_veg_compete) == 0){ veg.text[length(veg.text)] <- "l_veg_compete=.true.," @@ -343,41 +343,41 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { } else { veg.text[l_veg_compete] <- sub('false',"true",veg.text[l_triffid]) # set to TRUE } - + l_triffid_period <- grep("l_triffid_period",veg.text) if(length(l_triffid_period) == 0){ veg.text[length(veg.text)] <- "triffid_period=10," veg.text[length(veg.text)+1] <- "/" } ## no else because right now not adjusting dynamically - + } writeLines(veg.text, con = veg.file) - + ## --------------------- Edit PFT_PARAMS.NML to set model parameters ------------------------- pft.file <- file.path(local.rundir, "pft_params.nml") pft.text <- readLines(con = pft.file, n = -1) if (length(pft.text) < 3) { PEcAn.logger::logger.severe("No DEFAULT parameters provided for JULES") } - + ## split NML into variable list and parameter values pft.parse <- unlist(strsplit(pft.text[2:(length(pft.text) - 1)], "=")) variables <- pft.parse[seq(1, length(pft.parse), by = 2)] defaults <- pft.parse[seq(2, length(pft.parse), by = 2)] - + ## expand out NML multiplication notation mult <- grep("*", defaults, fixed = TRUE) for (i in mult) { tmp <- unlist(strsplit(defaults[i], "*", fixed = TRUE)) defaults[i] <- paste0(rep(tmp[2], tmp[1]), collapse = "") } - + ## parse into matrix of current defaults defaults <- read.csv(textConnection(defaults), header = FALSE) defaults <- defaults[, -ncol(defaults)] ## remove extra column created by NML line ending comma rownames(defaults) <- variables colnames(defaults) <- c("DEC", "EV", "C3", "C4", "SH")[1:ncol(defaults)] - + ## match selected PFTs to correct defaults npft <- length(trait.values) - 1 pft.id <- rep(NA, npft) @@ -397,7 +397,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { PEcAn.logger::logger.severe("Unknown PFT") } } - + ## reorder defaults to match supplied PFTs ### WON'T WORK WITH TRIFFID # pft.ord <- pft.id # unused <- NULL @@ -407,13 +407,13 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { # unused <- (npft + 1):5 # } # defaults <- defaults[, pft.ord] - + ## Loop over PFTS for (i in seq_len(npft)) { pft <- trait.values[[i]] - + for (v in seq_along(pft)) { - + ## convert names and units see JULES variable definitions at ## http://jules-lsm.github.io/vn4.2/namelists/pft_params.nml.html var <- names(pft)[v] @@ -453,7 +453,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { ## dgl_dt_io ## Rate of change of leaf turnover rate with temperature (K-1) ## dqcrit_io ## Critical humidity deficit (kg H2O per kg air). ## dz0v_dh_io ## Rate of change of vegetation roughness length for momentum with height. - ## Roughness length is calculated as dz0v_dh * canht_ft + ## Roughness length is calculated as dz0v_dh * canht_ft ## eta_sl_io ## Live stemwood coefficient (kg C/m/LAI) ## fd_io ## Scale factor for dark respiration ## **** look up equation @@ -530,11 +530,11 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { if (var == "leaf_respiration Q10") { names(pft)[v] <- "q10_leaf_io" } - + ## detect any unmatched variables mch <- which(rownames(defaults) == names(pft[v])) if (length(mch) != 1) { - PEcAn.logger::logger.warn("unmatched parameter in write.configs.JULES", names(pft[v]), "in PFT", + PEcAn.logger::logger.warn("unmatched parameter in write.configs.JULES", names(pft[v]), "in PFT", names(trait.values)[i]) } else { ## insert into defaults table @@ -543,22 +543,22 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { } } ## end loop over parameters } ## end loop over PFTs - - ## write out new file + + ## write out new file write(pft.text[1], pft.file) ## Header for (i in seq_len(nrow(defaults))) { - write(paste0(rownames(defaults)[i], "=", paste(defaults[i, ], collapse = ","), ","), pft.file, + write(paste0(rownames(defaults)[i], "=", paste(defaults[i, ], collapse = ","), ","), pft.file, append = TRUE) } write(pft.text[length(pft.text)], pft.file, append = TRUE) ## Footer - + ## set npft to the value needed for surface type definition npft <- max(c(npft, 5)) - + ## --------------------------- END PFTS ------------------------------------------ - + ## Edit jules_surface_types.nml to set correct number of PFTS - + ## Edit INITIAL_CONDITIONS.NML soil carbon LAI if(useTRIFFID){ ic.file <- file.path(local.rundir, "initial_conditions.nml") @@ -568,18 +568,18 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { ic_nvar_i <- grep("nvars",ic.text) ic_nvar <- as.numeric(sub(",","",strsplit(ic.text[ic_nvar_i],"=")[[1]][2])) ic.text[ic_nvar_i] <- paste0("nvars = ",ic_nvar+2,",") - + ## update use_file use_file <- grep("use_file",ic.text) ic.text[use_file] <- paste0(ic.text[use_file],".true.,.true.,") - + ## update var ic_var <- grep("^var=",ic.text) ic.text[ic_var] <- paste0(ic.text[ic_var],",'canht','frac',") - + ## write namelist writeLines(ic.text, con = ic.file) - + ## also load and parse IC dat file ic.dat <- file.path(local.rundir, "initial_conditions.dat") ic.text <- readLines(con = ic.dat, n = -1) @@ -591,8 +591,8 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { #' Detect timestep of JULES met files #' -#' @param met.dir -#' @param met.regexp +#' @param met.dir +#' @param met.regexp #' @param start_date #' #' @return @@ -628,7 +628,8 @@ detect.timestep <- function(met.dir,met.regexp,start_date){ tlen <- grep("time =", met.header) if (length(tlen) > 0) { tlen <- as.numeric(gsub(pattern = "[^[:digit:]]", "", met.header[tlen])) - dt <- 86400 / round(tlen/(365 + lubridate::leap_year(as.Date(start_date)))) + diy <- PEcAn.utils::days_in_year(lubridate::year(as.Date(start_date))) + dt <- 86400 / round(tlen/(diy)) } else { print(c("write.config.JULES timestep not detected", dt)) dt <- 1800 diff --git a/models/linkages/R/met2model.LINKAGES.R b/models/linkages/R/met2model.LINKAGES.R index 11aa102bf54..7624d2d46d0 100644 --- a/models/linkages/R/met2model.LINKAGES.R +++ b/models/linkages/R/met2model.LINKAGES.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -20,89 +20,88 @@ ##' @export ##' @author Ann Raiho, Betsy Cowdery ##-------------------------------------------------------------------------------------------------# -met2model.LINKAGES <- function(in.path, in.prefix, outfolder, start_date, end_date, +met2model.LINKAGES <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { library(PEcAn.utils) - + start_date <- as.POSIXlt(start_date, tz = "GMT") end_date <- as.POSIXlt(end_date, tz = "GMT") out.file <- file.path(outfolder, "climate.Rdata") # out.file <- file.path(outfolder, paste(in.prefix, strptime(start_date, '%Y-%m-%d'), # strptime(end_date, '%Y-%m-%d'), 'dat', sep='.')) - + results <- data.frame(file = c(out.file), - host = c(PEcAn.utils::fqdn()), - mimetype = c("text/plain"), - formatname = c("LINKAGES meteorology"), - startdate = c(start_date), - enddate = c(end_date), - dbfile.name = "climate.Rdata", + host = c(PEcAn.utils::fqdn()), + mimetype = c("text/plain"), + formatname = c("LINKAGES meteorology"), + startdate = c(start_date), + enddate = c(end_date), + dbfile.name = "climate.Rdata", stringsAsFactors = FALSE) print("internal results") print(results) - + if (file.exists(out.file) && !overwrite) { PEcAn.logger::logger.debug("File '", out.file, "' already exists, skipping to next file.") return(invisible(results)) } - + library(PEcAn.data.atmosphere) - + ## check to see if the outfolder is defined, if not create directory for output if (!file.exists(outfolder)) { dir.create(outfolder) } - + out <- NULL - + # get start/end year since inputs are specified on year basis start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - + year <- sprintf("%04d", seq(start_year, end_year, 1)) month <- sprintf("%02d", seq(1, 12, 1)) - + nyear <- length(year) # number of years to simulate - + month_matrix_precip <- matrix(NA, nyear, 12) DOY_vec_hr <- c(1, c(32, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 365) * 4) - + if(nchar(in.prefix)>0 & substr(in.prefix,nchar(in.prefix),nchar(in.prefix)) != ".") in.prefix = paste0(in.prefix,".") - + for (i in seq_len(nyear)) { year_txt <- formatC(year[i], width = 4, format = "d", flag = "0") infile <- file.path(in.path, paste0(in.prefix, year_txt, ".nc")) ncin <- ncdf4::nc_open(infile) - + ## convert time to seconds sec <- ncin$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(ncin$dim$time$units, " "))[1], "seconds") - dt <- ifelse(lubridate::leap_year(as.numeric(year[i])) == TRUE, - 366 * 24 * 60 * 60 / length(sec), # leap year - 365 * 24 * 60 * 60 / length(sec)) # non-leap year + diy <- PEcAn.utils::days_in_year(as.numeric(year[i])) + dt <- diy * 24 * 60 * 60 / length(sec) tstep <- 86400 / dt - - ncprecipf <- ncdf4::ncvar_get(ncin, "precipitation_flux") # units are kg m-2 s-1 + + ncprecipf <- ncdf4::ncvar_get(ncin, "precipitation_flux") # units are kg m-2 s-1 for (m in 1:12) { month_matrix_precip[i, m] <- (sum(ncprecipf[DOY_vec_hr[m]:(DOY_vec_hr[m + 1] - 1)]) * dt / 10) } ncdf4::nc_close(ncin) # if(i%%100==0) cat(i,' '); flush.console() } - + month_matrix_temp_mean <- matrix(NA, nyear, 12) - + for (i in seq_len(nyear)) { - + year_txt <- formatC(year[i], width = 4, format = "d", flag = "0") - + infile <- file.path(in.path, paste0(in.prefix, year_txt, ".nc")) - + ncin <- ncdf4::nc_open(infile) # print(ncin) - nctemp <- ncdf4::ncvar_get(ncin, "air_temperature") #units are kg m-2 s-1 + nctemp <- ncdf4::ncvar_get(ncin, "air_temperature") #units are kg m-2 s-1 for (m in 1:12) { - month_matrix_temp_mean[i, m] <- (mean(nctemp[DOY_vec_hr[m]:(DOY_vec_hr[m + 1] - 1)]) - + month_matrix_temp_mean[i, m] <- (mean(nctemp[DOY_vec_hr[m]:(DOY_vec_hr[m + 1] - 1)]) - 273.15) #sub daily to monthly } ncdf4::nc_close(ncin) @@ -111,7 +110,7 @@ met2model.LINKAGES <- function(in.path, in.prefix, outfolder, start_date, end_da } flush.console() } - + precip.mat <- month_matrix_precip temp.mat <- month_matrix_temp_mean save(precip.mat, temp.mat, file = out.file) diff --git a/models/lpjguess/R/met2model.LPJGUESS.R b/models/lpjguess/R/met2model.LPJGUESS.R index 6d7e7d021a9..915194c496a 100644 --- a/models/lpjguess/R/met2model.LPJGUESS.R +++ b/models/lpjguess/R/met2model.LPJGUESS.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -26,129 +26,126 @@ ##' @param verbose should the function be very verbose ##' @author Istem Fer ##' @importFrom ncdf4 ncvar_get ncvar_def ncdim_def ncatt_get ncatt_put nc_close -met2model.LPJGUESS <- function(in.path, in.prefix, outfolder, start_date, end_date, +met2model.LPJGUESS <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { - + library(PEcAn.utils) - + print("START met2model.LPJGUESS") start_date <- as.POSIXlt(start_date, tz = "UTC") end_date <- as.POSIXlt(end_date, tz = "UTC") start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - + year <- sprintf("%04d", seq(start_year, end_year, 1)) nyear <- length(year) #number of years to simulate - + ## LPJ-GUESS looks for different input files for different climate variables out.file <- out.files.full <- list() var.names <- c("tmp", "pre", "cld") n.var <- length(var.names) - long.names <- c("air_temperature", - "precipitation_flux", + long.names <- c("air_temperature", + "precipitation_flux", "surface_downwelling_shortwave_flux_in_air") for (i in seq_len(n.var)) { - out.file[[i]] <- paste(in.prefix, sprintf("%04d", start_year), end_year, var.names[[i]], + out.file[[i]] <- paste(in.prefix, sprintf("%04d", start_year), end_year, var.names[[i]], "nc", sep = ".") } for (i in seq_len(n.var)) { out.files.full[[i]] <- file.path(outfolder, out.file[[i]]) } - - results <- data.frame(file = unlist(out.files.full), - host = PEcAn.utils::fqdn(), - mimetype = "application/x-netcdf", - formatname = "lpj-guess.metfile", - startdate = start_date, - enddate = end_date, - dbfile.name = unlist(out.file), + + results <- data.frame(file = unlist(out.files.full), + host = PEcAn.utils::fqdn(), + mimetype = "application/x-netcdf", + formatname = "lpj-guess.metfile", + startdate = start_date, + enddate = end_date, + dbfile.name = unlist(out.file), stringsAsFactors = FALSE) print("internal results") print(results) - + ## check to see if the outfolder is defined, if not create directory for output if (!file.exists(outfolder)) { # why not use `dir.exists`? dir.create(outfolder) } - + ## open netcdf files ncin <- lapply(file.path(in.path, paste(in.prefix, year, "nc", sep = ".")), ncdf4::nc_open) - + ## retrieve lat/lon lon <- ncvar_get(ncin[[1]], "longitude") lat <- ncvar_get(ncin[[1]], "latitude") - + ## at least 2 lat-lon required for LPJ-GUESS to load the data lon <- c(lon, lon) lat <- c(lat, lat) - + ## calculate time step from the time-dimension length, check for leap year - tstep <- ifelse(ncin[[1]]$dim$time$len %% 365 == 0, - ncin[[1]]$dim$time$len / 365, + tstep <- ifelse(ncin[[1]]$dim$time$len %% 365 == 0, + ncin[[1]]$dim$time$len / 365, ncin[[1]]$dim$time$len / 366) - + ## read climate data nc.tmp <- lapply(ncin, ncvar_get, long.names[1]) nc.pre <- lapply(ncin, ncvar_get, long.names[2]) nc.cld <- lapply(ncin, ncvar_get, long.names[3]) - + ## aggregate to daily time steps, LPJ-GUESS reads daily climate data tmp.list <- pre.list <- cld.list <- list() for (y in seq_len(nyear)) { - if (lubridate::leap_year(as.numeric(year[y]))) { - ind.vec <- rep(1:366, each = tstep) - } else { - ind.vec <- rep(1:365, each = tstep) - } + diy <- PEcAn.utils::days_in_year(y) + ind.vec <- rep(seq_len(diy), each = tstep) tmp.list[[y]] <- tapply(nc.tmp[[y]], ind.vec, mean) pre.list[[y]] <- tapply(nc.pre[[y]], ind.vec, mean) cld.list[[y]] <- tapply(nc.cld[[y]], ind.vec, mean) } - + var.list <- list(unlist(tmp.list), unlist(pre.list), unlist(cld.list)) - + var.units <- c("K", "kg m-2 s-1", "W m-2") - + ## write climate data define dimensions - + latdim <- ncdim_def(name = "lat", "degrees_north", as.double(lat)) londim <- ncdim_def(name = "lon", "degrees_east", as.double(lon)) timedim <- ncdim_def("time", paste0("days since ", start_year - 1, "-12-31", sep = ""), as.double(c(1:length(unlist(tmp.list))))) - + fillvalue <- 9.96920996838687e+36 - + for (n in seq_len(n.var)) { # define variable - var.def <- ncvar_def(name = var.names[n], - units = var.units[n], - dim = (list(londim, latdim, timedim)), - fillvalue, long.names[n], - verbose = verbose, + var.def <- ncvar_def(name = var.names[n], + units = var.units[n], + dim = (list(londim, latdim, timedim)), + fillvalue, long.names[n], + verbose = verbose, prec = "float") - + # create netCD file for LPJ-GUESS ncfile <- ncdf4::nc_create(out.files.full[[n]], vars = var.def, force_v4 = TRUE) - + # put variable, rep(...,each=4) is a hack to write the same data for all grids (which all are the # same) ncdf4::ncvar_put(ncfile, var.def, rep(var.list[[n]], each = 4)) - + # additional attributes for LPJ-GUESS ncatt_put(nc = ncfile, varid = var.names[n], attname = "standard_name", long.names[n]) - + ncatt_put(nc = ncfile, varid = "lon", attname = "axis", "X") ncatt_put(nc = ncfile, varid = "lon", attname = "standard_name", "longitude") - + ncatt_put(nc = ncfile, varid = "lat", attname = "axis", "Y") ncatt_put(nc = ncfile, varid = "lat", attname = "standard_name", "latitude") - + ncatt_put(nc = ncfile, varid = "time", attname = "calendar", "gregorian") - + ncdf4::nc_close(ncfile) } - + ## close netcdf files sapply(ncin, nc_close) - + return(invisible(results)) } # met2model.LPJGUESS diff --git a/models/maat/R/met2model.MAAT.R b/models/maat/R/met2model.MAAT.R index 6f283579558..874b955e3d4 100644 --- a/models/maat/R/met2model.MAAT.R +++ b/models/maat/R/met2model.MAAT.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -33,105 +33,104 @@ PREFIX_XML <- "\n" ##' @importFrom udunits2 ud.convert ##' @importFrom ncdf4 ncvar_get ##' @importFrom XML saveXML -met2model.MAAT <- function(in.path, in.prefix, outfolder, start_date, end_date, +met2model.MAAT <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { ## MAAT driver format (.csv): ## Time (POSIX), Air Temp (°C), PAR (umols m-2 s-1), Precipitation( ??), Atmospheric CO2 (μmol mol-1) ... # STILL IN DEVELOPMENT - + print("START met2model.MAAT") - + start_date <- as.POSIXlt(start_date, tz = "GMT") end_date <- as.POSIXlt(end_date, tz = "GMT") - - out.file <- paste(in.prefix, - strptime(start_date, "%Y-%m-%d"), - strptime(end_date, "%Y-%m-%d"), - "csv", + + out.file <- paste(in.prefix, + strptime(start_date, "%Y-%m-%d"), + strptime(end_date, "%Y-%m-%d"), + "csv", sep = ".") out.file.full <- file.path(outfolder, out.file) - - results <- data.frame(file = out.file.full, - host = PEcAn.utils::fqdn(), - mimetype = "text/csv", - formatname = "MAAT meteorology", - startdate = start_date, - enddate = end_date, - dbfile.name = out.file, + + results <- data.frame(file = out.file.full, + host = PEcAn.utils::fqdn(), + mimetype = "text/csv", + formatname = "MAAT meteorology", + startdate = start_date, + enddate = end_date, + dbfile.name = out.file, stringsAsFactors = FALSE) print("internal results") print(results) - + if (file.exists(out.file.full) && !overwrite) { PEcAn.logger::logger.debug("File '", out.file.full, "' already exists, skipping to next file.") return(invisible(results)) } - + ## check to see if the outfolder is defined, if not create directory for output if (!file.exists(outfolder)) { dir.create(outfolder) } - + out <- NULL - + # get start/end year since inputs are specified on year basis start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - - ## loop over files + + ## loop over files ## TODO need to filter out the data that is not inside start_date, end_date for (year in start_year:end_year) { - + skip <- FALSE print(year) - + ncdf.file <- file.path(in.path, paste(in.prefix, year, "nc", sep = ".")) - + if (file.exists(ncdf.file)) { ## open netcdf nc <- ncdf4::nc_open(ncdf.file) - + ## convert time to seconds sec <- nc$dim$time$vals frac.day <- nc$dim$time$vals sec <- ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") - - dt <- ifelse(lubridate::leap_year(year) == TRUE, - 366 * 24 * 60 * 60 / length(sec), # leap year - 365 * 24 * 60 * 60 / length(sec)) # non-leap year - + + diy <- PEcAn.utils::days_in_year(year) + dt <- diy * 24 * 60 * 60 / length(sec) + tstep <- round(86400 / dt) dt <- 86400 / tstep - + ## extract required MAAT driver variables names(nc$var) lat <- ncvar_get(nc, "latitude") lon <- ncvar_get(nc, "longitude") Tair <- ncvar_get(nc, "air_temperature") ## in Kelvin Rain <- ncvar_get(nc, "precipitation_flux") ## 'kg/m^2/s' - + # get humidity vars (NOTE:later add VPD here!!) RH_perc <- ncvar_get(nc, "relative_humidity") ## RH Percentage - + # get radiation SW <- ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") ## in W/m2 PAR <- try(ncvar_get(nc, "surface_downwelling_photosynthetic_photon_flux_in_air") * 1e+06) ## mol/m2/s to umols/m2/s if (!is.numeric(PAR)) { PAR <- SW * 2.114 #W/m2 TO umol/m2/s } - + # get CO2 (if exists) CO2 <- try(ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air")) useCO2 <- is.numeric(CO2) if (useCO2) { CO2 <- CO2 * 1e+06 ## convert from mole fraction (kg/kg) to ppm } - + ncdf4::nc_close(nc) } else { print("Skipping to next year") next } - + ## build time variables (year, month, day of year) nyr <- floor(length(sec) / 86400 / 365 * dt) yr <- NULL @@ -164,44 +163,44 @@ met2model.MAAT <- function(in.path, in.prefix, outfolder, start_date, end_date, asec[rng] <- asec[rng] - asec[rng[1]] hr[rng] <- (asec[rng] - (dtmp - 1) * 86400) / 86400 * 24 } - + # Time time <- as.POSIXct(asec, tz = "UTC", origin = start_date) - + # output matrix n <- length(Tair) - tmp <- cbind.data.frame(Time = time[1:n], - YEAR = yr[1:n], - DOY = doy[1:n], - HOUR = hr[1:n], - FRAC_DAY = frac.day[1:n], - TIMESTEP = rep(dt/86400, n), + tmp <- cbind.data.frame(Time = time[1:n], + YEAR = yr[1:n], + DOY = doy[1:n], + HOUR = hr[1:n], + FRAC_DAY = frac.day[1:n], + TIMESTEP = rep(dt/86400, n), # TODO: Add VPD, etc - CO2 = CO2, + CO2 = CO2, Tair_degC = Tair - 273.15, # convert to celsius Prec_mm = Rain * dt, # converts from mm/s to mm umols/m2/s - RH_perc = RH_perc, + RH_perc = RH_perc, PAR_umols_m2_s = PAR) - + ## quick error check, sometimes get a NA in the last hr ?? NEEDED? hr.na <- which(is.na(tmp[, 3])) if (length(hr.na) > 0) { tmp[hr.na, 3] <- tmp[hr.na - 1, 3] + dt/86400 * 24 } - + if (is.null(out)) { out <- tmp } else { out <- rbind(out, tmp) } } ## end loop over years - + if (!is.null(out)) { - - ## write met csv output + + ## write met csv output # write.table(out,out.file.full,quote = FALSE,sep='\t',row.names=FALSE,col.names=FALSE) write.csv(out, out.file.full, row.names = FALSE) - + # write out leaf_user_met.xml - example # # @@ -212,21 +211,21 @@ met2model.MAAT <- function(in.path, in.prefix, outfolder, start_date, end_date, # # # - + # Create leaf_user_met.xml # TODO: make this dynamic with names above! # TODO: add the additional met variables, make dynamic leaf_user_met_list <- list(leaf = list(env = list(time = "'Time'", temp = "'Tair_degC'", par = "'PAR_umols_m2_s'"))) leaf_user_met_xml <- PEcAn.utils::listToXml(leaf_user_met_list, "met_data_translator") - + # output XML file - saveXML(leaf_user_met_xml, - file = file.path(outfolder, "leaf_user_met.xml"), - indent = TRUE, + saveXML(leaf_user_met_xml, + file = file.path(outfolder, "leaf_user_met.xml"), + indent = TRUE, prefix = PREFIX_XML) - + return(invisible(results)) - + } else { print("NO MET TO OUTPUT") return(invisible(NULL)) diff --git a/models/maespa/R/met2model.MAESPA.R b/models/maespa/R/met2model.MAESPA.R index 71151215247..7a716f83919 100755 --- a/models/maespa/R/met2model.MAESPA.R +++ b/models/maespa/R/met2model.MAESPA.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -27,73 +27,72 @@ ##' ##' @author Tony Gardella ##' @importFrom ncdf4 ncvar_get -met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date, +met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { - + library(PEcAn.utils) - + print("START met2model.MAESPA") start.date <- as.POSIXlt(start_date, tz = "GMT") end.date <- as.POSIXlt(end_date, tz = "GMT") - - out.file <- paste(in.prefix, - strptime(start.date, "%Y-%m-%d"), - strptime(end.date, "%Y-%m-%d"), - "dat", + + out.file <- paste(in.prefix, + strptime(start.date, "%Y-%m-%d"), + strptime(end.date, "%Y-%m-%d"), + "dat", sep = ".") - + out.file.full <- file.path(outfolder, out.file) - + results <- data.frame(file = out.file.full, host = PEcAn.utils::fqdn(), - mimetype = "text/plain", - formatname = "maespa.met", + mimetype = "text/plain", + formatname = "maespa.met", startdate = start_date, enddate = end_date, - dbfile.name = out.file, + dbfile.name = out.file, stringsAsFactors = FALSE) - + print("internal results") print(results) - + if (file.exists(out.file.full) && !overwrite) { PEcAn.logger::logger.debug("File '", out.file.full, "' already exists, skipping to next file.") return(invisible(results)) } - + library(PEcAn.data.atmosphere) library(Maeswrap) - + ## check to see if the outfolder is defined, if not create directory for output if (!file.exists(outfolder)) { dir.create(outfolder) } - + out <- NULL - + # get start/end year since inputs are specified on year basis start_year <- lubridate::year(start.date) end_year <- lubridate::year(end.date) - + ## loop over files for (year in start_year:end_year) { print(year) - + old.file <- file.path(in.path, paste(in.prefix, year, "nc", sep = ".")) - + if (file.exists(old.file)) { ## open netcdf nc <- ncdf4::nc_open(old.file) ## convert time to seconds sec <- nc$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") - - dt <- ifelse(lubridate::leap_year(year) == TRUE, - 366 * 24 * 60 * 60 / length(sec), # leap year - 365 * 24 * 60 * 60 / length(sec)) # non-leap year + + diy <- PEcAn.utils::days_in_year(year) + dt <- diy * 24 * 60 * 60 / length(sec) tstep <- round(86400 / dt) dt <- 86400 / tstep - + # Check which variables are available and which are not ## extract variables @@ -106,10 +105,10 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date PPT <- ncvar_get(nc, "precipitation_flux") #kg m-2 s-1 CA <- try(ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air")) #mol/mol PRESS <- ncvar_get(nc, "air_pressure") # Pa - + ## Convert specific humidity to fractional relative humidity RH <- qair2rh(QAIR, TAIR, PRESS) - + ## Process PAR if (!is.numeric(PAR)) { # Function from data.atmosphere will convert SW to par in W/m2 @@ -118,11 +117,11 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date # convert PAR <- udunits2::ud.convert(PAR, "mol", "umol") } - + # Convert air temperature to Celsius TAIR <- udunits2::ud.convert(TAIR, "kelvin", "celsius") - - #### ppm. atmospheric CO2 concentration. + + #### ppm. atmospheric CO2 concentration. ### Constant from Environ namelist used instead if CA is nonexistent defaultCO2 <- 400 if (!is.numeric(CA)) { @@ -131,37 +130,37 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date } else { CA <- CA * 1e+06 } - + ncdf4::nc_close(nc) } else { print("Skipping to next year") next } - + if (exists("CA")) { tmp <- cbind(TAIR, PPT, RAD, PRESS, PAR, RH, CA) } else { tmp <- cbind(TAIR, PPT, RAD, PRESS, PAR, RH) } - + if (is.null(out)) { out <- tmp } else { out <- rbind(out, tmp) } - + } ### end loop over years - + ### Check for NA if (anyNA(out)) { PEcAn.logger::logger.debug("NA introduced in met data. Maespa will not be able to run properly. Please change Met Data Source or Site") } else { PEcAn.logger::logger.debug("No NA values contained in data") } - + ## Set Variable names columnnames <- colnames(out) - + # Set number of timesteps in a day(timetsep of input data) timesteps <- tstep # Set distribution of diffuse radiation incident from the sky.(0.0) is default. @@ -169,25 +168,25 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date # Change format of date to DD/MM/YY startdate <- paste0(format(as.Date(start_date), "%d/%m/%y")) enddate <- paste0(format(as.Date(end_date), "%d/%m/%y")) - + ## Units of Latitude and longitude if (nc$dim$latitude$units == "degree_north") { latunits <- "N" } else { latunits <- "S" } - + if (nc$dim$longitude$units == "degree_east") { lonunits <- "E" } else { lonunits <- "W" } - + ## Write output met.dat file metfile <- system.file("met.dat", package = "PEcAn.MAESPA") - + met.dat <- replacemetdata(out, oldmetfile = metfile, newmetfile = out.file.full) - + replacePAR(out.file.full, "difsky", "environ", newval = difsky, noquotes = TRUE) replacePAR(out.file.full, "ca", "environ", newval = defaultCO2, noquotes = TRUE) replacePAR(out.file.full, "lat", "latlong", newval = lat, noquotes = TRUE) @@ -197,6 +196,6 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date replacePAR(out.file.full, "startdate", "metformat", newval = startdate, noquotes = TRUE) replacePAR(out.file.full, "enddate", "metformat", newval = enddate, noquotes = TRUE) replacePAR(out.file.full, "columns", "metformat", newval = columnnames, noquotes = TRUE) - + return(invisible(results)) } # met2model.MAESPA diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index 9b0fb719f83..4bc7b0ee5d9 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -49,16 +49,11 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star ## build day and year - dt <- ifelse(lubridate::leap_year(year) == TRUE, - 366 * 24 * 60 * 60 / length(sec), # leap year - 365 * 24 * 60 * 60 / length(sec)) # non-leap year + diy <- PEcAn.utils::days_in_year(year) + dt <- diy * 24 * 60 * 60 / length(sec) tstep <- round(timestep.s / dt) #time steps per day - doy <- rep(1:365, each = tstep)[1:length(sec)] - if (lubridate::leap_year(year)) { - ## is leap - doy <- rep(1:366, each = tstep)[1:length(sec)] - } + doy <- seq_len(diy, each = tstep)[seq_along(sec)] ## Get variables from netcdf file SW <- ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") # SW in W/m2 diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index ccdb2f936c9..3b21ad395f0 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -25,70 +25,70 @@ ##' @param overwrite should existing files be overwritten ##' @param verbose should the function be very verbose ##' @importFrom ncdf4 ncvar_get -met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date, +met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { library(PEcAn.utils) - + PEcAn.logger::logger.info("START met2model.SIPNET") start_date <- as.POSIXlt(start_date, tz = "UTC") end_date <- as.POSIXlt(end_date, tz = "UTC") - out.file <- paste(in.prefix, strptime(start_date, "%Y-%m-%d"), - strptime(end_date, "%Y-%m-%d"), - "clim", + out.file <- paste(in.prefix, strptime(start_date, "%Y-%m-%d"), + strptime(end_date, "%Y-%m-%d"), + "clim", sep = ".") out.file.full <- file.path(outfolder, out.file) - - results <- data.frame(file = out.file.full, - host = PEcAn.utils::fqdn(), - mimetype = "text/csv", - formatname = "Sipnet.climna", - startdate = start_date, - enddate = end_date, - dbfile.name = out.file, + + results <- data.frame(file = out.file.full, + host = PEcAn.utils::fqdn(), + mimetype = "text/csv", + formatname = "Sipnet.climna", + startdate = start_date, + enddate = end_date, + dbfile.name = out.file, stringsAsFactors = FALSE) PEcAn.logger::logger.info("internal results") print(results) - + if (file.exists(out.file.full) && !overwrite) { PEcAn.logger::logger.debug("File '", out.file.full, "' already exists, skipping to next file.") return(invisible(results)) } - + library(PEcAn.data.atmosphere) - + ## check to see if the outfolder is defined, if not create directory for output if (!file.exists(outfolder)) { dir.create(outfolder) } - + out <- NULL - + # get start/end year since inputs are specified on year basis start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - - ## loop over files + + ## loop over files for (year in start_year:end_year) { - + skip <- FALSE PEcAn.logger::logger.info(year) - + + diy <- PEcAn.utils::days_in_year(year) + old.file <- file.path(in.path, paste(in.prefix, year, "nc", sep = ".")) - + if (file.exists(old.file)) { ## open netcdf nc <- ncdf4::nc_open(old.file) - + ## convert time to seconds sec <- nc$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") - - dt <- ifelse(lubridate::leap_year(year) == TRUE, - 366 * 24 * 60 * 60 / length(sec), # leap year - 365 * 24 * 60 * 60 / length(sec)) # non-leap year + + dt <- diy * 24 * 60 * 60 / length(sec) tstep <- round(86400 / dt) dt <- 86400 / tstep - + ## extract variables lat <- ncvar_get(nc, "latitude") lon <- ncvar_get(nc, "longitude") @@ -101,17 +101,17 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date ws <- sqrt(U ^ 2 + V ^ 2) PEcAn.logger::logger.info("wind_speed absent; calculated from eastward_wind and northward_wind") } - + Rain <- ncvar_get(nc, "precipitation_flux") # pres <- ncvar_get(nc,'air_pressure') ## in pascal SW <- ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") ## in W/m2 - + PAR <- try(ncvar_get(nc, "surface_downwelling_photosynthetic_photon_flux_in_air")) ## in mol/m2/s if (!is.numeric(PAR)) { PAR <- SW * 0.45 PEcAn.logger::logger.info("surface_downwelling_photosynthetic_photon_flux_in_air absent; PAR set to SW * 0.45") } - + soilT <- try(ncvar_get(nc, "soil_temperature")) if (!is.numeric(soilT)) { # approximation borrowed from SIPNET CRUNCEPpreprocessing's tsoil.py @@ -123,7 +123,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date } else { soilT <- soilT - 273.15 } - + SVP <- udunits2::ud.convert(get.es(Tair - 273.15), "millibar", "Pa") ## Saturation vapor pressure VPD <- try(ncvar_get(nc, "water_vapor_saturation_deficit")) ## in Pa if (!is.numeric(VPD)) { @@ -132,13 +132,13 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date } e_a <- SVP - VPD VPDsoil <- udunits2::ud.convert(get.es(soilT), "millibar", "Pa") * (1 - qair2rh(Qair, soilT)) - + ncdf4::nc_close(nc) } else { PEcAn.logger::logger.info("Skipping to next year") next } - + ## build time variables (year, month, day of year) nyr <- floor(length(sec) / 86400 / 365 * dt) yr <- NULL @@ -146,13 +146,8 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date hr <- NULL asec <- sec for (y in year + 1:nyr - 1) { - ytmp <- rep(y, 365 * 86400 / dt) - dtmp <- rep(1:365, each = 86400 / dt) - if (lubridate::leap_year(y)) { - ## is leap - ytmp <- rep(y, 366 * 86400 / dt) - dtmp <- rep(1:366, each = 86400 / dt) - } + ytmp <- rep(y, diy * 86400 / dt) + dtmp <- rep(seq_len(diy), each = 86400 / dt) if (is.null(yr)) { yr <- ytmp doy <- dtmp @@ -186,31 +181,31 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date PEcAn.logger::logger.info("Skipping to next year") next } - + ## 0 YEAR DAY HOUR TIMESTEP AirT SoilT PAR PRECIP VPD VPD_Soil AirVP(e_a) WIND SoilM build data ## matrix n <- length(Tair) - tmp <- cbind(rep(0, n), + tmp <- cbind(rep(0, n), yr[1:n], - doy[1:n], - hr[1:n], - rep(dt / 86400, n), - Tair - 273.15, - soilT, - PAR * dt, # mol/m2/hr + doy[1:n], + hr[1:n], + rep(dt / 86400, n), + Tair - 273.15, + soilT, + PAR * dt, # mol/m2/hr Rain * dt, # converts from mm/s to mm - VPD, - VPDsoil, - e_a, + VPD, + VPDsoil, + e_a, ws, # wind rep(0.6, n)) # put soil water at a constant. Don't use, set SIPNET to MODEL_WATER = 1 - + ## quick error check, sometimes get a NA in the last hr hr.na <- which(is.na(tmp[, 4])) if (length(hr.na) > 0) { tmp[hr.na, 4] <- tmp[hr.na - 1, 4] + dt/86400 * 24 } - + ##filter out days not included in start or end date if(year == start_year){ extra.days <- length(as.Date(paste0(start_year, "-01-01")):as.Date(start_date)) #extra days length includes the start date @@ -219,7 +214,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date start.row <- ((extra.days - 1) * 86400 / dt) + 1 #subtract to include start.date, add to exclude last half hour of day before tmp <- tmp[start.row:nrow(tmp),] } - } + } if (year == end_year){ if(year == start_year){ extra.days <- length(as.Date(start_date):as.Date(end_date)) @@ -227,7 +222,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date PEcAn.logger::logger.info("Subsetting SIPNET met to match end date") end.row <- nrow(tmp) - ((extra.days - 1) * 86400 / dt) #subtract to include end.date tmp <- tmp[1:end.row,] - } + } } else{ extra.days <- length(as.Date(end_date):as.Date(paste0(end_year, "-12-31"))) #extra days length includes the end date if (extra.days > 1){ @@ -237,17 +232,17 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date } } } - + if (is.null(out)) { out <- tmp } else { out <- rbind(out, tmp) } - + } ## end loop over years - + if (!is.null(out)) { - + ## write output write.table(out, out.file.full, quote = FALSE, sep = "\t", row.names = FALSE, col.names = FALSE) return(invisible(results)) diff --git a/modules/assim.batch/R/get.da.data.R b/modules/assim.batch/R/get.da.data.R index 273cded50a2..af34225e2e4 100644 --- a/modules/assim.batch/R/get.da.data.R +++ b/modules/assim.batch/R/get.da.data.R @@ -1,6 +1,6 @@ ## Carl Davidson code for dealing with flux data for emulator-based DA ## ported by M. Dietze 08/30/12 -## some of this is redundant with other parts of PEcAn and needs to be cleaned up +## some of this is redundant with other parts of PEcAn and needs to be cleaned up #library(hdf5) #source('./code/R/edview.base.R') @@ -17,20 +17,20 @@ calculate.nee.L <- function(yeardoytime, model.i.nee, observed.flux, be, bu) { model.flux <- data.frame(yeardoytime = yeardoytime[seq(model.i.nee)], model.i.nee = model.i.nee) all.fluxes <- merge(observed.flux, model.flux, by = "yeardoytime") - + sigma <- with(all.fluxes, coef(lm(abs(model.i.nee - FC) ~ abs(model.i.nee)))) - + ## calculate likelihood logL <- rep(NA, sum(all.fluxes$model.i.nee != 0)) emissions <- which(all.fluxes$model.i.nee < 0) uptake <- which(all.fluxes$model.i.nee > 0) - + ## are these calculations correct, with respect to slope and intercepts? - logL[emissions] <- with(all.fluxes[emissions, ], + logL[emissions] <- with(all.fluxes[emissions, ], dlaplace(FC, model.i.nee, 1 / (be[1] + be[2] * abs(model.i.nee)), log = TRUE)) - logL[uptake] <- with(all.fluxes[uptake, ], + logL[uptake] <- with(all.fluxes[uptake, ], dlaplace(FC, model.i.nee, 1/(bu[1] + bu[2] * abs(model.i.nee)), log = TRUE)) - + # NEE.acf <- acf(all.fluxes$model.i.nee, 100, plot=FALSE) ar.coef <- ar(model.i.nee, FALSE, 1)$ar weight <- (1 - ar.coef) / (1 + ar.coef) @@ -43,25 +43,25 @@ calculate.nee.L <- function(yeardoytime, model.i.nee, observed.flux, be, bu) { get.da.data <- function(out.dir, ameriflux.dir, years, be, bu, ensemble.size = 199) { ensemble.size <- 500 load(paste(out.dir, "samples.Rdata", sep = "")) - + pfts <- names(ensemble.samples) pfts <- pfts[pfts != "env"] - + # OBSERVED observed <- lapply(years, function(year) { read.ameriflux.L2(paste(ameriflux.dir, year, "L2.csv", sep = "_"), year) }) observed <- do.call(rbind, observed) observed$yeardoytime <- observed$time - + # filter out winter observations March 1 and November 1 are chosen based on Yoshi's methods observed <- observed[observed$DTIME > 60 & observed$DTIME < 305, ] stopifnot(all(abs(observed$FC) <= 500, na.rm = TRUE)) - + # ENSEMBLE ensemble.run.ids <- get.run.id("ENS", left.pad.zeros(1:ensemble.size)) ensemble.x <- do.call(cbind, ensemble.samples[pfts])[1:ensemble.size, ] - + # SENSITIVITY ANALYSIS p.rng <- do.call(rbind, lapply(pfts, function(pft) { t(sa.samples[[pft]][c(1, nrow(sa.samples[[pft]])), ]) @@ -69,7 +69,7 @@ get.da.data <- function(out.dir, ameriflux.dir, years, be, bu, ensemble.size = 1 sa.x <- list() for (pft in pfts) { MEDIAN <- "50" - + median.samples <- list() for (i in seq_along(sa.samples)) { median.samples[[i]] <- sa.samples[[i]][MEDIAN, ] @@ -79,10 +79,10 @@ get.da.data <- function(out.dir, ameriflux.dir, years, be, bu, ensemble.size = 1 sa.x[[run.id]] <- do.call(cbind, trait.samples) ## loop over pfts for (i in seq(names(sa.samples))) { - + traits <- colnames(sa.samples[[i]]) quantiles.str <- rownames(sa.samples[[i]]) - + ## loop over variables for (trait in traits) { for (quantile.str in quantiles.str) { @@ -90,8 +90,8 @@ get.da.data <- function(out.dir, ameriflux.dir, years, be, bu, ensemble.size = 1 quantile <- as.numeric(quantile.str) / 100 trait.samples <- median.samples trait.samples[[i]][trait] <- sa.samples[[i]][quantile.str, trait] - run.id <- get.run.id("SA", round(quantile, 3), - trait = trait, + run.id <- get.run.id("SA", round(quantile, 3), + trait = trait, pft.name = names(trait.samples)[i]) sa.x[[run.id]] <- do.call(cbind, trait.samples) } @@ -103,26 +103,26 @@ get.da.data <- function(out.dir, ameriflux.dir, years, be, bu, ensemble.size = 1 sa.run.ids <- rownames(sa.x) run.ids <- ensemble.run.ids # c(ensemble.run.ids, sa.run.ids) x <- ensemble.x # rbind(ensemble.x, sa.x) - + points.per.day <- 48 dtime <- do.call(c, lapply(years, function(year) { - nodays <- 365 + lubridate::leap_year(year) + nodays <- PEcAn.utils::days_in_year(year) year + seq(1, nodays, by = 1 / points.per.day)[-1] / nodays })) - # run.ids<-ensemble.run.ids + # run.ids<-ensemble.run.ids # x <- ensemble.x y <- t(as.data.frame(lapply(run.ids, function(run.id) { - + outname <- paste0(run.id, "-T-(", paste(paste("(", years, ")", sep = ""), collapse = "|"), ")") data <- read.output.type(out.dir, outname = outname, pattern = "-T-") data <- data$AVG_GPP - data$AVG_PLANT_RESP - data$AVG_HTROPH_RESP - calculate.nee.L(dtime, data, - observed[c("yeardoytime", "FC")], + calculate.nee.L(dtime, data, + observed[c("yeardoytime", "FC")], be, bu) }))) - + save(x, y, file = paste(out.dir, "L.nee.Rdata", sep = "")) print("save sucessful") warnings() @@ -130,6 +130,6 @@ get.da.data <- function(out.dir, ameriflux.dir, years, be, bu, ensemble.size = 1 #get.da.data('./pecan/BarrowDA5param/', 'barrow/validation/usakbarr', years=1998:2006, -# be=c(0.20, 0.04), bu=c(0.31, -0.05)) -#get.da.data('./pecan/AtqasukDA5param/', 'atqasuk/validation/usatqasu', years=2000:2006, +# be=c(0.20, 0.04), bu=c(0.31, -0.05)) +#get.da.data('./pecan/AtqasukDA5param/', 'atqasuk/validation/usatqasu', years=2000:2006, # be=c(0.75, 0.23), bu=c(1.08, -0.21)) diff --git a/modules/data.atmosphere/NAMESPACE b/modules/data.atmosphere/NAMESPACE index 1bf20dd6cbe..b932222dece 100644 --- a/modules/data.atmosphere/NAMESPACE +++ b/modules/data.atmosphere/NAMESPACE @@ -26,6 +26,7 @@ export(download.NEONmet) export(download.NLDAS) export(download.PalEON) export(download.PalEON_ENS) +export(eccentricity_obliquity) export(exner) export(extract.nc) export(gen.subdaily.models) diff --git a/modules/data.atmosphere/R/download.CRUNCEP_Global.R b/modules/data.atmosphere/R/download.CRUNCEP_Global.R index 13ca4cd1013..839c9a7050d 100644 --- a/modules/data.atmosphere/R/download.CRUNCEP_Global.R +++ b/modules/data.atmosphere/R/download.CRUNCEP_Global.R @@ -1,5 +1,5 @@ ##' Download CRUNCEP data -##' +##' ##' Download and convert to CF CRUNCEP single grid point from MSTIMIP server using OPENDAP interface ##' @param outfolder Directory where results should be written ##' @param start_date,end_date Range of years to retrieve. Format is YYYY-MM-DD, @@ -14,9 +14,9 @@ ##' @export ##' ##' @author James Simkins, Mike Dietze -download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, lon.in, +download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, lon.in, overwrite = FALSE, verbose = FALSE, ...) { - + start_date <- as.POSIXlt(start_date, tz = "UTC") end_date <- as.POSIXlt(end_date, tz = "UTC") start_year <- lubridate::year(start_date) @@ -33,36 +33,36 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l site_id <- as.numeric(site_id) # outfolder <- paste0(outfolder, "_site_", paste0(site_id%/%1e+09, "-", site_id %% 1e+09)) - + lat.in <- as.numeric(lat.in) lon.in <- as.numeric(lon.in) # Convert lat-lon to grid row and column lat_grid <- floor(2 * (90 - lat.in)) + 1 lon_grid <- floor(2 * (lon.in + 180)) + 1 dap_base <- "https://thredds.daac.ornl.gov/thredds/dodsC/ornldaac/1220/mstmip_driver_global_hd_climate_" - + dir.create(outfolder, showWarnings = FALSE, recursive = TRUE) - + ylist <- seq(start_year, end_year, by = 1) rows <- length(ylist) - results <- data.frame(file = character(rows), - host = character(rows), - mimetype = character(rows), - formatname = character(rows), - startdate = character(rows), - enddate = character(rows), - dbfile.name = "CRUNCEP", + results <- data.frame(file = character(rows), + host = character(rows), + mimetype = character(rows), + formatname = character(rows), + startdate = character(rows), + enddate = character(rows), + dbfile.name = "CRUNCEP", stringsAsFactors = FALSE) - - var <- data.frame(DAP.name = c("tair", "lwdown", "press", "swdown", "uwind", "vwind", "qair", "rain"), - CF.name = c("air_temperature", "surface_downwelling_longwave_flux_in_air", "air_pressure", - "surface_downwelling_shortwave_flux_in_air", "eastward_wind", "northward_wind", - "specific_humidity", "precipitation_flux"), + + var <- data.frame(DAP.name = c("tair", "lwdown", "press", "swdown", "uwind", "vwind", "qair", "rain"), + CF.name = c("air_temperature", "surface_downwelling_longwave_flux_in_air", "air_pressure", + "surface_downwelling_shortwave_flux_in_air", "eastward_wind", "northward_wind", + "specific_humidity", "precipitation_flux"), units = c("Kelvin", "W/m2", "Pascal", "W/m2", "m/s", "m/s", "g/g", "kg/m2/s")) - + for (i in seq_len(rows)) { year <- ylist[i] - ntime <- ifelse(lubridate::leap_year(year), 366 * 4, 365 * 4) + ntime <- PEcAn.utils::days_in_year(year) * 4 loc.file <- file.path(outfolder, paste("CRUNCEP", year, "nc", sep = ".")) results$file[i] <- loc.file @@ -87,10 +87,10 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l vals = as.array(days_elapsed), create_dimvar = TRUE, unlim = TRUE) dim <- list(lat, lon, time) - + var.list <- list() dat.list <- list() - + ## get data off OpenDAP for (j in seq_len(nrow(var))) { dap_file <- paste0(dap_base, var$DAP.name[j], "_", year, "_v1.nc4") @@ -113,21 +113,21 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l } - dat.list[[j]] <- ncdf4::ncvar_get(dap, - as.character(var$DAP.name[j]), - c(lon_grid, lat_grid, 1), + dat.list[[j]] <- ncdf4::ncvar_get(dap, + as.character(var$DAP.name[j]), + c(lon_grid, lat_grid, 1), c(1, 1, ntime)) - - var.list[[j]] <- ncdf4::ncvar_def(name = as.character(var$CF.name[j]), - units = as.character(var$units[j]), - dim = dim, - missval = -999, + + var.list[[j]] <- ncdf4::ncvar_def(name = as.character(var$CF.name[j]), + units = as.character(var$units[j]), + dim = dim, + missval = -999, verbose = verbose) ncdf4::nc_close(dap) } ## change units of precip to kg/m2/s instead of 6 hour accumulated precip dat.list[[8]] <- dat.list[[8]] / 21600 - + ## put data in new file loc <- ncdf4::nc_create(filename = loc.file, vars = var.list, verbose = verbose) for (j in seq_len(nrow(var))) { @@ -135,6 +135,6 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l } ncdf4::nc_close(loc) } - + return(invisible(results)) } # download.CRUNCEP diff --git a/modules/data.atmosphere/R/download.GLDAS.R b/modules/data.atmosphere/R/download.GLDAS.R index ff9bf40ebbf..b67069081b3 100644 --- a/modules/data.atmosphere/R/download.GLDAS.R +++ b/modules/data.atmosphere/R/download.GLDAS.R @@ -1,7 +1,7 @@ ##' Download GLDAS data -##' +##' ##' Download and convert single grid point GLDAS to CF single grid point from hydro1.sci.gsfc.nasa.gov using OPENDAP interface -##' +##' ##' @export ##' @param outfolder ##' @param start_date @@ -11,7 +11,7 @@ ##' @param lon ##' ##' @author Christy Rollinson -download.GLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon.in, +download.GLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon.in, overwrite = FALSE, verbose = FALSE, ...) { # Date stuff @@ -29,141 +29,138 @@ download.GLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon start_year, end_year, GLDAS_start)) } - + lat.in <- as.numeric(lat.in) lon.in <- as.numeric(lon.in) dap_base <- "http://hydro1.sci.gsfc.nasa.gov/thredds/dodsC/GLDAS_NOAH10SUBP_3H" # Right now changed to 1-degree because it gets us back further dir.create(outfolder, showWarnings = FALSE, recursive = TRUE) - + ylist <- seq(start_year, end_year, by = 1) rows <- length(ylist) results <- data.frame(file = character(rows), - host = character(rows), - mimetype = character(rows), + host = character(rows), + mimetype = character(rows), formatname = character(rows), - startdate = character(rows), + startdate = character(rows), enddate = character(rows), - dbfile.name = "NLDAS", + dbfile.name = "NLDAS", stringsAsFactors = FALSE) - var <- data.frame(DAP.name = c("Near_surface_air_temperature", "Surface_incident_longwave_radiation", - "Surface_pressure", "Surface_incident_shortwave_radiation", "Near_surface_wind_magnitude", + var <- data.frame(DAP.name = c("Near_surface_air_temperature", "Surface_incident_longwave_radiation", + "Surface_pressure", "Surface_incident_shortwave_radiation", "Near_surface_wind_magnitude", "Near_surface_specific_humidity", "Rainfall_rate"), - CF.name = c("air_temperature", "surface_downwelling_longwave_flux_in_air", - "air_pressure", "surface_downwelling_shortwave_flux_in_air", "wind", "specific_humidity", - "precipitation_flux"), + CF.name = c("air_temperature", "surface_downwelling_longwave_flux_in_air", + "air_pressure", "surface_downwelling_shortwave_flux_in_air", "wind", "specific_humidity", + "precipitation_flux"), units = c("Kelvin", "W/m2", "Pascal", "W/m2", "m/s", "g/g", "kg/m2/s")) - + for (i in seq_len(rows)) { year <- ylist[i] - + nday <- PEcAn.utils::days_in_year(year) + # Figure out how many days we're working with. # If we have multiple years and we're not in the first # or last year, we're taking a whole year if (rows > 1 & i != 1 & i != rows) { - nday <- ifelse(lubridate::leap_year(year), 366, 365) # leap year or not; days per year - days.use <- 1:nday + days.use <- seq_len(nday) } else if (rows == 1) { # if we're working with only 1 year, lets only pull what we need to - nday <- ifelse(lubridate::leap_year(year), 366, 365) # leap year or not; days per year day1 <- lubridate::yday(start_date) # Now we need to check whether we're ending on the right day day2 <- lubridate::yday(end_date) - days.use <- day1:day2 + days.use <- seq(day1, day2) nday <- length(days.use) # Update nday } else if (i == 1) { # If this is the first of many years, we only need to worry about the start date - nday <- ifelse(lubridate::leap_year(year), 366, 365) # leap year or not; days per year day1 <- lubridate::yday(start_date) - days.use <- day1:nday + days.use <- seq(day1, nday) nday <- length(days.use) # Update nday } else if (i == rows) { - # If this is the last of many years, we only need to worry about the start date - nday <- ifelse(lubridate::leap_year(year), 366, 365) # leap year or not; days per year + # If this is the last of many years, we only need to worry about the end date day2 <- lubridate::yday(end_date) - days.use <- 1:day2 + days.use <- seq_len(day2) nday <- length(days.use) # Update nday } - ntime <- nday * 8 # leap year or not*time slice (3-hourly) - + ntime <- nday * 24 / 3 # leap year or not*time slice (3-hourly) + loc.file <- file.path(outfolder, paste("GLDAS", year, "nc", sep = ".")) - + ## Create dimensions lat <- ncdf4::ncdim_def(name = "latitude", units = "degree_north", vals = lat.in, create_dimvar = TRUE) lon <- ncdf4::ncdim_def(name = "longitude", units = "degree_east", vals = lon.in, create_dimvar = TRUE) - time <- ncdf4::ncdim_def(name = "time", - units = "sec", - vals = seq((min(days.use + 1 - 1/8) * 24 * 360), (max(days.use) + 1 - 1/8) * 24 * 360, length.out = ntime), - create_dimvar = TRUE, + time <- ncdf4::ncdim_def(name = "time", + units = "sec", + vals = seq((min(days.use + 1 - 1/8) * 24 * 360), (max(days.use) + 1 - 1/8) * 24 * 360, length.out = ntime), + create_dimvar = TRUE, unlim = TRUE) dim <- list(lat, lon, time) - + var.list <- list() dat.list <- list() - + # Defining our dimensions up front for (j in seq_len(nrow(var))) { - var.list[[j]] <- ncdf4::ncvar_def(name = as.character(var$CF.name[j]), - units = as.character(var$units[j]), - dim = dim, - missval = -999, + var.list[[j]] <- ncdf4::ncvar_def(name = as.character(var$CF.name[j]), + units = as.character(var$units[j]), + dim = dim, + missval = -999, verbose = verbose) dat.list[[j]] <- array(NA, dim = c(length(lat.in), length(lon.in), ntime)) # Go ahead and make the arrays } names(var.list) <- names(dat.list) <- var$CF.name - + ## get data off OpenDAP for (j in seq_along(days.use)) { date.now <- as.Date(days.use[j], origin = as.Date(paste0(year - 1, "-12-31"))) mo.now <- stringr::str_pad(lubridate::month(date.now), 2, pad = "0") day.mo <- stringr::str_pad(lubridate::day(date.now), 2, pad = "0") doy <- stringr::str_pad(days.use[j], 3, pad = "0") - + # Because the suffixes are really different for these files, # get a list and go through each day dap.log <- data.frame(XML::readHTMLTable(paste0(dap_base, "/", year, "/", doy, "/catalog.html"))) dap.log <- dap.log[order(dap.log[, 1], decreasing = F), ] # Sort them so that we go from 0 to 21 - + for (h in seq_len(nrow(dap.log))[-1]) { dap_file <- paste0(dap_base, "/", year, "/", doy, "/", dap.log[h, 1], ".ascii?") - + # Query lat/lon latlon <- RCurl::getURL(paste0(dap_file, "lat[0:1:599],lon[0:1:1439]")) lat.ind <- gregexpr("lat", latlon) lon.ind <- gregexpr("lon", latlon) - lats <- as.vector(read.table(con = textConnection(substr(latlon, lat.ind[[1]][3], + lats <- as.vector(read.table(con = textConnection(substr(latlon, lat.ind[[1]][3], lon.ind[[1]][3] - 1)), sep = ",", fileEncoding = "\n", skip = 1)) - lons <- as.vector(read.table(con = textConnection(substr(latlon, lon.ind[[1]][3], + lons <- as.vector(read.table(con = textConnection(substr(latlon, lon.ind[[1]][3], nchar(latlon))), sep = ",", fileEncoding = "\n", skip = 1)) - + lat.use <- which(lats - 0.25 / 2 <= lat.in & lats + 0.25 / 2 >= lat.in) lon.use <- which(lons - 0.25 / 2 <= lon.in & lons + 0.25 / 2 >= lon.in) - + # Set up the query for all of the met variables dap_query <- "" for (v in seq_len(nrow(var))) { - dap_query <- paste(dap_query, + dap_query <- paste(dap_query, paste0(var$DAP.name[v], "[0:1:0]", "[", lat.use, "][", lon.use, "]"), sep = ",") } dap_query <- substr(dap_query, 2, nchar(dap_query)) - + dap.out <- RCurl::getURL(paste0(dap_file, dap_query)) for (v in seq_len(nrow(var))) { var.now <- var$DAP.name[v] ind.1 <- gregexpr(paste(var.now, var.now, sep = "."), dap.out) end.1 <- gregexpr(paste(var.now, "time", sep = "."), dap.out) - dat.list[[v]][, , (j * 8) - 8 + h - 1] <- + dat.list[[v]][, , (j * 8) - 8 + h - 1] <- read.delim(con = textConnection(substr(dap.out, ind.1[[1]][1], end.1[[1]][2])), sep = ",", fileEncoding = "\n")[1, 1] } # end variable loop } # end hour } # end day - + ## put data in new file loc <- ncdf4::nc_create(filename = loc.file, vars = var.list, verbose = verbose) for (j in seq_len(nrow(var))) { ncdf4::ncvar_put(nc = loc, varid = as.character(var$CF.name[j]), vals = dat.list[[j]]) } ncdf4::nc_close(loc) - + results$file[i] <- loc.file results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year, "-01-01 00:00:00") @@ -171,6 +168,6 @@ download.GLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon results$mimetype[i] <- "application/x-netcdf" results$formatname[i] <- "CF Meteorology" } - + return(invisible(results)) } # download.GLDAS diff --git a/modules/data.atmosphere/R/download.MsTMIP_NARR.R b/modules/data.atmosphere/R/download.MsTMIP_NARR.R index f3c79a85002..e6b7a5f97bd 100644 --- a/modules/data.atmosphere/R/download.MsTMIP_NARR.R +++ b/modules/data.atmosphere/R/download.MsTMIP_NARR.R @@ -49,7 +49,7 @@ download.MsTMIP_NARR <- function(outfolder, start_date, end_date, site_id, lat.i for (i in seq_len(rows)) { year <- ylist[i] - ntime <- ifelse(lubridate::leap_year(year), 2923, 2919) + ntime <- ifelse(lubridate::leap_year(year), 2923, 2919) ## ANS: Where do these numbers come from? loc.file <- file.path(outfolder, paste("MsTMIP_NARR", year, "nc", sep = ".")) diff --git a/modules/data.atmosphere/R/download.NLDAS.R b/modules/data.atmosphere/R/download.NLDAS.R index 34531161e4b..ee158f33a1a 100644 --- a/modules/data.atmosphere/R/download.NLDAS.R +++ b/modules/data.atmosphere/R/download.NLDAS.R @@ -1,7 +1,7 @@ ##' Download NLDAS met data -##' +##' ##' Download and convert single grid point NLDAS to CF single grid point from hydro1.sci.gsfc.nasa.gov using OPENDAP interface -##' +##' ##' @param outfolder ##' @param start_date ##' @param end_date @@ -11,11 +11,11 @@ ##' @export ##' ##' @author Christy Rollinson (with help from Ankur Desai) -download.NLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon.in, +download.NLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon.in, overwrite = FALSE, verbose = FALSE, ...) { library(PEcAn.utils) library(RCurl) - + # Date stuff start_date <- as.POSIXlt(start_date, tz = "UTC") end_date <- as.POSIXlt(end_date, tz = "UTC") @@ -30,38 +30,38 @@ download.NLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon start_year, end_year, NLDAS_start)) } - + lat.in <- as.numeric(lat.in) lon.in <- as.numeric(lon.in) dap_base <- "http://hydro1.sci.gsfc.nasa.gov/thredds/dodsC/NLDAS_FORA0125_H.002" dir.create(outfolder, showWarnings = FALSE, recursive = TRUE) - + ylist <- seq(start_year, end_year, by = 1) rows <- length(ylist) - results <- data.frame(file = character(rows), + results <- data.frame(file = character(rows), host = character(rows), - mimetype = character(rows), - formatname = character(rows), - startdate = character(rows), - enddate = character(rows), - dbfile.name = "NLDAS", + mimetype = character(rows), + formatname = character(rows), + startdate = character(rows), + enddate = character(rows), + dbfile.name = "NLDAS", stringsAsFactors = FALSE) - - var <- data.frame(DAP.name = c("N2-m_above_ground_Temperature", "LW_radiation_flux_downwards_surface", - "Pressure", "SW_radiation_flux_downwards_surface", "N10-m_above_ground_Zonal_wind_speed", - "N10-m_above_ground_Meridional_wind_speed", "N2-m_above_ground_Specific_humidity", "Precipitation_hourly_total"), - DAP.dim = c(2, 1, 1, 1, 2, 2, 2, 1), - CF.name = c("air_temperature", "surface_downwelling_longwave_flux_in_air", - "air_pressure", "surface_downwelling_shortwave_flux_in_air", "eastward_wind", "northward_wind", + + var <- data.frame(DAP.name = c("N2-m_above_ground_Temperature", "LW_radiation_flux_downwards_surface", + "Pressure", "SW_radiation_flux_downwards_surface", "N10-m_above_ground_Zonal_wind_speed", + "N10-m_above_ground_Meridional_wind_speed", "N2-m_above_ground_Specific_humidity", "Precipitation_hourly_total"), + DAP.dim = c(2, 1, 1, 1, 2, 2, 2, 1), + CF.name = c("air_temperature", "surface_downwelling_longwave_flux_in_air", + "air_pressure", "surface_downwelling_shortwave_flux_in_air", "eastward_wind", "northward_wind", "specific_humidity", "precipitation_flux"), units = c("Kelvin", "W/m2", "Pascal", "W/m2", "m/s", "m/s", "g/g", "kg/m2/s")) time.stamps <- seq(0, 2300, by = 100) for (i in seq_len(rows)) { year <- ylist[i] - + # figure out how many days we're working with If we have multiple years and we're not in the first # or last year, we're taking a whole year - nday <- ifelse(lubridate::leap_year(year), 366, 365) # leap year or not; days per year + nday <- PEcAn.utils::days_in_year(year) if (rows > 1 & i != 1 & i != rows) { days.use <- 1:nday } else if (rows == 1) { @@ -83,32 +83,32 @@ download.NLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon nday <- length(days.use) # Update nday } ntime <- nday * 24 # leap year or not;time slice (hourly) - + loc.file <- file.path(outfolder, paste("NLDAS", year, "nc", sep = ".")) - + ## Create dimensions lat <- ncdf4::ncdim_def(name = "latitude", units = "degree_north", vals = lat.in, create_dimvar = TRUE) lon <- ncdf4::ncdim_def(name = "longitude", units = "degree_east", vals = lon.in, create_dimvar = TRUE) - time <- ncdf4::ncdim_def(name = "time", units = "sec", - vals = seq((min(days.use) + 1 - 1 / 24) * 24 * 360, (max(days.use) + 1 - 1/24) * 24 * 360, length.out = ntime), - create_dimvar = TRUE, + time <- ncdf4::ncdim_def(name = "time", units = "sec", + vals = seq((min(days.use) + 1 - 1 / 24) * 24 * 360, (max(days.use) + 1 - 1/24) * 24 * 360, length.out = ntime), + create_dimvar = TRUE, unlim = TRUE) dim <- list(lat, lon, time) - + var.list <- list() dat.list <- list() - + # Defining our dimensions up front for (j in 1:nrow(var)) { var.list[[j]] <- ncvar_def(name = as.character(var$CF.name[j]), - units = as.character(var$units[j]), - dim = dim, + units = as.character(var$units[j]), + dim = dim, missval = -999, verbose = verbose) dat.list[[j]] <- array(NA, dim = c(length(lat.in), length(lon.in), ntime)) # Go ahead and make the arrays } names(var.list) <- names(dat.list) <- var$CF.name - + ## get data off OpenDAP for (j in seq_along(days.use)) { date.now <- as.Date(days.use[j], origin = as.Date(paste0(year - 1, "-12-31"))) @@ -117,21 +117,21 @@ download.NLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon doy <- stringr::str_pad(days.use[j], 3, pad = "0") for (h in seq_along(time.stamps)) { hr <- stringr::str_pad(time.stamps[h], 4, pad = "0") - dap_file <- paste0(dap_base, "/", year, "/", doy, "/", "NLDAS_FORA0125_H.A", year, + dap_file <- paste0(dap_base, "/", year, "/", doy, "/", "NLDAS_FORA0125_H.A", year, mo.now, day.mo, ".", hr, ".002.grb.ascii?") - + # Query lat/lon latlon <- getURL(paste0(dap_file, "lat[0:1:223],lon[0:1:463]")) lat.ind <- gregexpr("lat", latlon) lon.ind <- gregexpr("lon", latlon) - lats <- as.vector(read.table(con <- textConnection(substr(latlon, lat.ind[[1]][3], + lats <- as.vector(read.table(con <- textConnection(substr(latlon, lat.ind[[1]][3], lon.ind[[1]][3] - 1)), sep = ",", fileEncoding = "\n", skip = 1)) - lons <- as.vector(read.table(con <- textConnection(substr(latlon, lon.ind[[1]][3], + lons <- as.vector(read.table(con <- textConnection(substr(latlon, lon.ind[[1]][3], nchar(latlon))), sep = ",", fileEncoding = "\n", skip = 1)) - + lat.use <- which(lats - 0.125 / 2 <= lat.in & lats + 0.125 / 2 >= lat.in) lon.use <- which(lons - 0.125 / 2 <= lon.in & lons + 0.125 / 2 >= lon.in) - + # Set up the query for all of the met variables dap_query <- "" for (v in seq_len(nrow(var))) { @@ -139,32 +139,32 @@ download.NLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon for (i in seq_len(var$DAP.dim[v])) { time.string <- paste0(time.string, "[0:1:0]") } - dap_query <- paste(dap_query, + dap_query <- paste(dap_query, paste0(var$DAP.name[v], time.string, "[", lat.use, "][", lon.use, "]"), sep = ",") } dap_query <- substr(dap_query, 2, nchar(dap_query)) - + dap.out <- getURL(paste0(dap_file, dap_query)) for (v in seq_len(nrow(var))) { var.now <- var$DAP.name[v] ind.1 <- gregexpr(paste(var.now, var.now, sep = "."), dap.out) end.1 <- gregexpr(paste(var.now, "time", sep = "."), dap.out) - dat.list[[v]][, , j * 24 - 24 + h] <- - read.delim(con <- textConnection(substr(dap.out, + dat.list[[v]][, , j * 24 - 24 + h] <- + read.delim(con <- textConnection(substr(dap.out, ind.1[[1]][1], end.1[[1]][2])), sep = ",", fileEncoding = "\n")[1, 1] } # end variable loop } # end hour } # end day ## change units of precip to kg/m2/s instead of hour accumulated precip dat.list[["precipitation_flux"]] <- dat.list[["precipitation_flux"]] / 3600 - + ## put data in new file loc <- ncdf4::nc_create(filename = loc.file, vars = var.list, verbose = verbose) for (j in seq_len(nrow(var))) { ncdf4::ncvar_put(nc = loc, varid = as.character(var$CF.name[j]), vals = dat.list[[j]]) } ncdf4::nc_close(loc) - + results$file[i] <- loc.file results$host[i] <- PEcAn.utils::fqdn() results$startdate[i] <- paste0(year, "-01-01 00:00:00") @@ -172,6 +172,6 @@ download.NLDAS <- function(outfolder, start_date, end_date, site_id, lat.in, lon results$mimetype[i] <- "application/x-netcdf" results$formatname[i] <- "CF Meteorology" } - + return(invisible(results)) } # download.NLDAS diff --git a/modules/data.atmosphere/R/eccentricity_obliquity.R b/modules/data.atmosphere/R/eccentricity_obliquity.R new file mode 100644 index 00000000000..33d2deb2781 --- /dev/null +++ b/modules/data.atmosphere/R/eccentricity_obliquity.R @@ -0,0 +1,13 @@ +#' Equation of time: Eccentricity and obliquity +#' +#' @author Alexey Shiklomanov +#' @param doy Day of year +#' @export +eccentricity_obliquity <- function(doy) { + stopifnot(doy <= 366) + f <- pi / 180 * (279.5 + 0.9856 * doy) + et <- (-104.7 * sin(f) + 596.2 * sin(2 * f) + 4.3 * + sin(4 * f) - 429.3 * cos(f) - 2 * + cos(2 * f) + 19.3 * cos(3 * f)) / 3600 # equation of time -> eccentricity and obliquity + return(et) +} diff --git a/modules/data.atmosphere/R/metgapfill.R b/modules/data.atmosphere/R/metgapfill.R index 155340cf760..72ec1a21cfa 100644 --- a/modules/data.atmosphere/R/metgapfill.R +++ b/modules/data.atmosphere/R/metgapfill.R @@ -160,20 +160,12 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst ## make night dark - based on met2model.ED2.R in models/ed/R First: calculate potential radiation sec <- nc$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") - dt <- ifelse(lubridate::leap_year(year), - (366 * 24 * 60 * 60) / length(sec), - (365 * 24 * 60 * 60) / length(sec)) - doy <- if (lubridate::leap_year(year) == TRUE) - { rep(1:366, each = 86400 / dt) } - else { rep(1:365, each = 86400 / dt) } - hr <- if (lubridate::leap_year(year) == TRUE) - { rep(seq(0, length = 86400 / dt, by = dt / 86400 * 24), 366) } - else { rep(seq(0, length = 86400 / dt, by = dt / 86400 * 24), 365) } - - f <- pi / 180 * (279.5 + 0.9856 * doy) - et <- (-104.7 * sin(f) + 596.2 * sin(2 * f) + 4.3 * - sin(4 * f) - 429.3 * cos(f) - 2 * - cos(2 * f) + 19.3 * cos(3 * f)) / 3600 # equation of time -> eccentricity and obliquity + diy <- PEcAn.utils::days_in_year(year) + dt <- diy * 24 * 60 * 60 / length(sec) + doy <- rep(seq_len(diy), each = 86400 / dt) + hr <- rep(seq(0, length = 86400 / dt, by = 24 * dt / 86400), diy) + + et <- eccentricity_obliquity(doy) merid <- floor(lon / 15) * 15 merid[merid < 0] <- merid[merid < 0] + 15 lc <- (lon - merid) * -4/60 ## longitude correction @@ -185,9 +177,9 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst cosz <- sin(lat * pi / 180) * sin(dec) + cos(lat * pi / 180) * cos(dec) * cos(h) cosz[cosz < 0] <- 0 rpot <- 1366 * cosz #in UTC - tz = as.numeric(lst) + tz <- as.numeric(lst) if(is.na(tz)){ - tz = PEcAn.utils::timezone_hour(lst) + tz <- PEcAn.utils::timezone_hour(lst) } toff <- tz * 3600/dt #timezone offset correction if (toff < 0) { diff --git a/modules/data.atmosphere/R/tdm_predict_subdaily_met.R b/modules/data.atmosphere/R/tdm_predict_subdaily_met.R index 9ddbd85d96c..35cdfd801ff 100644 --- a/modules/data.atmosphere/R/tdm_predict_subdaily_met.R +++ b/modules/data.atmosphere/R/tdm_predict_subdaily_met.R @@ -1,20 +1,20 @@ ##' Predict Subdaily Meteorology ##' Predict Subdaily Meteorology based off of statistics created in gen.subdaily.models() -# ----------------------------------- +# ----------------------------------- # Description # ----------------------------------- ##' @title predict_subdaily_met ##' @family tdm - Temporally Downscale Meteorology ##' @author Christy Rollinson, James Simkins ##' @description This is the main function of the tdm family workflow. This function predicts subdaily meteorology -##' from daily means using a linear regression modeling approach. It takes a dataset with +##' from daily means using a linear regression modeling approach. It takes a dataset with ##' daily resolution and temporally downscales it to hourly resolution using the statistics ##' generated by gen.subdaily.models(). It references the predict.subdaily.function ##' located in lm_ensemble_sims() which uses a linear regression based approach to downscale. -##' We generate multiple ensembles of possible hourly values dictated from the models and betas +##' We generate multiple ensembles of possible hourly values dictated from the models and betas ##' generated in gen.subdaily.models. Each ensemble member is saved as a netCDF file ##' in CF conventions and these files are ready to be used in the general PEcAn workflow. -# ----------------------------------- +# ----------------------------------- # Parameters # ----------------------------------- ##' @param outfolder - directory where output file will be stored @@ -24,10 +24,10 @@ ##' @param lm.models.base - path to linear regression model folder from 3_gen_subdaily ##' @param start_date - yyyy-mm-dd ##' @param end_date - yyyy-mm-dd -##' @param n.ens - integer selecting number of hourly ensemble members +##' @param n.ens - integer selecting number of hourly ensemble members ##' @param cores.max - 12 ##' @param resids - logical stating whether to pass on residual data or not -##' @param parallel - logical stating whether to run temporal_downscale_functions.R in parallel +##' @param parallel - logical stating whether to run temporal_downscale_functions.R in parallel ##' @param n.cores - deals with parallelization ##' @param overwrite ##' @param verbose @@ -49,18 +49,18 @@ # Begin Fcript #---------------------------------------------------------------------- -predict_subdaily_met <- function(outfolder, in.path, in.prefix, lm.models.base, - dat.train_file, start_date, end_date, cores.max = 12, - n.ens = 3, resids = FALSE, parallel = FALSE, n.cores = NULL, +predict_subdaily_met <- function(outfolder, in.path, in.prefix, lm.models.base, + dat.train_file, start_date, end_date, cores.max = 12, + n.ens = 3, resids = FALSE, parallel = FALSE, n.cores = NULL, overwrite = FALSE, verbose = FALSE) { - + years <- seq(lubridate::year(start_date), lubridate::year(end_date)) - + # Load the training dataset and make sure to pull in dimensions and # save as dim - vars.info <- data.frame(CF.name = c("air_temperature", "precipitation_flux", - "air_temperature_max", "air_temperature_min", "surface_downwelling_shortwave_flux_in_air", - "surface_downwelling_longwave_flux_in_air", "air_pressure", "specific_humidity", + vars.info <- data.frame(CF.name = c("air_temperature", "precipitation_flux", + "air_temperature_max", "air_temperature_min", "surface_downwelling_shortwave_flux_in_air", + "surface_downwelling_longwave_flux_in_air", "air_pressure", "specific_humidity", "eastward_wind", "northward_wind", "wind_speed")) dat.train <- list() tem <- ncdf4::nc_open(dat.train_file) @@ -76,59 +76,59 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, lm.models.base, } names(dat.train) <- vars.info$CF.name dat.train <- data.frame(dat.train) - + # Create wind speed variable if it doesn't exist if (all(is.na(dat.train$wind_speed) == TRUE)) { dat.train$wind_speed <- sqrt(dat.train$eastward_wind^2 + dat.train$northward_wind^2) } - + # Create a date variable that will help us organize our workflow if (dim$time$units == "sec") { sub_string <- substrRight(dat.train_file, 7) start_year <- substr(sub_string, 1, 4) - dat.train$date <- as.POSIXct(dim$time$vals, tz = "GMT", origin = paste0(start_year, - "-01-01 ", udunits2::ud.convert(dim$time$vals[1], "seconds", + dat.train$date <- as.POSIXct(dim$time$vals, tz = "GMT", origin = paste0(start_year, + "-01-01 ", udunits2::ud.convert(dim$time$vals[1], "seconds", "hour"), ":00:00")) } else { start_year <- substr(dim$time$units, start = 12, stop = 15) - dat.train$date <- as.POSIXct(udunits2::ud.convert((dim$time$vals - - ((dim$time$vals[2] - dim$time$vals[1])/2)), "days", "seconds"), - tz = "GMT", origin = paste0(start_year, "-01-01 ", udunits2::ud.convert(dim$time$vals[1], + dat.train$date <- as.POSIXct(udunits2::ud.convert((dim$time$vals - + ((dim$time$vals[2] - dim$time$vals[1])/2)), "days", "seconds"), + tz = "GMT", origin = paste0(start_year, "-01-01 ", udunits2::ud.convert(dim$time$vals[1], "days", "hours"), ":00:00")) } - + dat.train$year <- lubridate::year(dat.train$date) dat.train$doy <- lubridate::yday(dat.train$date) dat.train$hour <- lubridate::hour(dat.train$date) - + df.hour <- data.frame(hour = unique(dat.train$hour)) # match this to whatever your 'hourly' timestep is - + # Set up the appropriate seed set.seed(format(Sys.time(), "%m%d")) seed.vec <- sample.int(1e+06, size = 500, replace = F) - + # Defining variable names, longname & units - nc.info <- data.frame(CF.name = c("air_temperature", "precipitation_flux", - "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", - "air_pressure", "specific_humidity", "wind_speed"), longname = c("2 meter mean air temperature", - "cumulative precipitation (water equivalent)", "incident (downwelling) showtwave radiation", - "incident (downwelling) longwave radiation", "air_pressureure at the surface", - "Specific humidity measured at the lowest level of the atmosphere", - "Wind speed"), units = c("K", "kg m-2 s-1", "W m-2", "W m-2", "Pa", + nc.info <- data.frame(CF.name = c("air_temperature", "precipitation_flux", + "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", + "air_pressure", "specific_humidity", "wind_speed"), longname = c("2 meter mean air temperature", + "cumulative precipitation (water equivalent)", "incident (downwelling) showtwave radiation", + "incident (downwelling) longwave radiation", "air_pressureure at the surface", + "Specific humidity measured at the lowest level of the atmosphere", + "Wind speed"), units = c("K", "kg m-2 s-1", "W m-2", "W m-2", "Pa", "kg kg-1", "m s-1")) # ---------------------------------- for (y in years) { - + path.gcm <- file.path(in.path, paste0(in.prefix, ".", y, ".nc")) - + # ----------------------------------- 1. Format output so all ensemble # members can be run at once NOTE: Need to start with the last and work # to the first ----------------------------------- - + # Read the lags nc.now <- ncdf4::nc_open(path.gcm) nc.time <- ncdf4::ncvar_get(nc.now, "time") - + for (j in seq_along(vars.info$CF.name)) { if (exists(as.character(vars.info$CF.name[j]), tem$var)) { lags.list[[j]] <- ncdf4::ncvar_get(nc.now, as.character(vars.info$CF.name[j])) @@ -138,30 +138,30 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, lm.models.base, } names(lags.list) <- vars.info$CF.name lags.list <- data.frame(lags.list) - + # Define the lags.init list, the values that will initialize the entire # downscaling procedure lags.init <- list() for (v in vars.info$CF.name) { if (all(is.na(lags.list$air_temperature))) { - lags.init[[v]] <- data.frame(array((dat.yr$air_temperature_max + + lags.init[[v]] <- data.frame(array((dat.yr$air_temperature_max + dat.yr$air_temperature_min)/2), dim = c(1, n.ens)) } if (all(is.na(lags.list$wind_speed))) { - lags.init[[v]] <- data.frame(array(sqrt((lags.list$eastward_wind^2) + + lags.init[[v]] <- data.frame(array(sqrt((lags.list$eastward_wind^2) + (lags.list$northward_wind^2)), dim = c(1, n.ens))) } else { - lags.init[[v]] <- data.frame(array(lags.list[[v]], dim = c(1, + lags.init[[v]] <- data.frame(array(lags.list[[v]], dim = c(1, n.ens))) } } - - + + # Now we read in the data we wish to downscale and leave it as is dat.ens <- list() # a new list for each ensemble member as a new layer - ens.sims <- list() # this will propogate that spread through each year, so instead of + ens.sims <- list() # this will propogate that spread through each year, so instead of # restarting every January 1, it will propogate those lag values - + # Create a list layer for each ensemble member dat.yr <- list() nc.now <- ncdf4::nc_open(path.gcm) @@ -175,7 +175,7 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, lm.models.base, } names(dat.yr) <- vars.info$CF.name dat.yr <- data.frame(dat.yr) - + # We need to fill these variables if they aren't available if (all(is.na(dat.yr$air_temperature))) { dat.yr$air_temperature <- ((dat.yr$air_temperature_max + dat.yr$air_temperature_min)/2) @@ -184,112 +184,111 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, lm.models.base, dat.yr$wind_speed <- sqrt(dat.yr$eastward_wind^2 + dat.yr$northward_wind^2) } ncdf4::nc_close(nc.now) - + # We need to create a date variable to help us organize everything dat.yr$year <- y if (dim$time$units == "sec") { - dat.yr$date <- as.Date((dim$time$vals/(dim$time$vals[2] - dim$time$vals[1])), + dat.yr$date <- as.Date((dim$time$vals/(dim$time$vals[2] - dim$time$vals[1])), tz = "GMT", origin = paste0(y - 1, "-12-31")) } if (dim$time$units == paste0("days since ", y, "-01-01T00:00:00Z")) { - dat.train$date <- as.POSIXct(udunits2::ud.convert((dim$time$vals - - ((dim$time$vals[2] - dim$time$vals[1])/2)), "days", "seconds"), + dat.train$date <- as.POSIXct(udunits2::ud.convert((dim$time$vals - + ((dim$time$vals[2] - dim$time$vals[1])/2)), "days", "seconds"), tz = "GMT", origin = paste0(y, "-01-01 00:00:00")) } dat.yr$doy <- lubridate::yday(dat.yr$date) - + # Create the data frame for the 'next' values dat.nxt <- dat.yr # Shift everyting up by a day to get the preview of the next day - dat.nxt[2:(nrow(dat.nxt)), c("air_temperature_max", "air_temperature_min", - "precipitation_flux", "surface_downwelling_shortwave_flux_in_air", - "surface_downwelling_longwave_flux_in_air", "air_pressure", - "specific_humidity", "wind_speed")] <- dat.nxt[1:(nrow(dat.nxt) - - 1), c("air_temperature_max", "air_temperature_min", "precipitation_flux", - "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", + dat.nxt[2:(nrow(dat.nxt)), c("air_temperature_max", "air_temperature_min", + "precipitation_flux", "surface_downwelling_shortwave_flux_in_air", + "surface_downwelling_longwave_flux_in_air", "air_pressure", + "specific_humidity", "wind_speed")] <- dat.nxt[1:(nrow(dat.nxt) - + 1), c("air_temperature_max", "air_temperature_min", "precipitation_flux", + "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", "air_pressure", "specific_humidity", "wind_speed")] - + # Need to add in the 'next' value Note: if we're past the end of our # daily data, the best we can do is leave things as is (copy the last # day's value) if (y < max(years)) { - - path.gcm <- file.path(in.path, paste0(in.prefix, ".", y + 1, + + path.gcm <- file.path(in.path, paste0(in.prefix, ".", y + 1, ".nc")) nc.nxt <- ncdf4::nc_open(path.gcm) - + dat.nxt$time <- ncdf4::ncvar_get(nc.nxt, "time") for (j in vars.info$CF.name) { - dat.nxt[dat.nxt$time == max(dat.nxt$time), j] <- ncdf4::ncvar_get(nc.nxt, + dat.nxt[dat.nxt$time == max(dat.nxt$time), j] <- ncdf4::ncvar_get(nc.nxt, j)[length(nxt.time)] } ncdf4::nc_close(nc.nxt) } - + # Now we put everything into 1 main data.frame - dat.ens <- data.frame(year = dat.yr$year, doy = dat.yr$doy, date = dat.yr$date, - air_temperature_max.day = dat.yr$air_temperature_max, air_temperature_min.day = dat.yr$air_temperature_min, - precipitation_flux.day = dat.yr$precipitation_flux, surface_downwelling_shortwave_flux_in_air.day = dat.yr$surface_downwelling_shortwave_flux_in_air, - surface_downwelling_longwave_flux_in_air.day = dat.yr$surface_downwelling_longwave_flux_in_air, - air_pressure.day = dat.yr$air_pressure, specific_humidity.day = dat.yr$specific_humidity, - wind_speed.day = dat.yr$wind_speed, next.air_temperature_max = dat.nxt$air_temperature_max, - next.air_temperature_min = dat.nxt$air_temperature_min, next.precipitation_flux = dat.nxt$precipitation_flux, - next.surface_downwelling_shortwave_flux_in_air = dat.nxt$surface_downwelling_shortwave_flux_in_air, - next.surface_downwelling_longwave_flux_in_air = dat.nxt$surface_downwelling_longwave_flux_in_air, - next.air_pressure = dat.nxt$air_pressure, next.specific_humidity = dat.nxt$specific_humidity, + dat.ens <- data.frame(year = dat.yr$year, doy = dat.yr$doy, date = dat.yr$date, + air_temperature_max.day = dat.yr$air_temperature_max, air_temperature_min.day = dat.yr$air_temperature_min, + precipitation_flux.day = dat.yr$precipitation_flux, surface_downwelling_shortwave_flux_in_air.day = dat.yr$surface_downwelling_shortwave_flux_in_air, + surface_downwelling_longwave_flux_in_air.day = dat.yr$surface_downwelling_longwave_flux_in_air, + air_pressure.day = dat.yr$air_pressure, specific_humidity.day = dat.yr$specific_humidity, + wind_speed.day = dat.yr$wind_speed, next.air_temperature_max = dat.nxt$air_temperature_max, + next.air_temperature_min = dat.nxt$air_temperature_min, next.precipitation_flux = dat.nxt$precipitation_flux, + next.surface_downwelling_shortwave_flux_in_air = dat.nxt$surface_downwelling_shortwave_flux_in_air, + next.surface_downwelling_longwave_flux_in_air = dat.nxt$surface_downwelling_longwave_flux_in_air, + next.air_pressure = dat.nxt$air_pressure, next.specific_humidity = dat.nxt$specific_humidity, next.wind_speed = dat.nxt$wind_speed) - - dat.ens$time.day <- as.numeric(difftime(dat.ens$date, paste0(y - + + dat.ens$time.day <- as.numeric(difftime(dat.ens$date, paste0(y - 1, "-12-31"), tz = "GMT", units = "day")) dat.ens <- merge(dat.ens, df.hour, all = T) - - dat.ens$date <- strptime(paste(dat.ens$year, dat.ens$doy, dat.ens$hour, + + dat.ens$date <- strptime(paste(dat.ens$year, dat.ens$doy, dat.ens$hour, sep = "-"), "%Y-%j-%H", tz = "GMT") - dat.ens$time.hr <- as.numeric(difftime(dat.ens$date, paste0(y - + dat.ens$time.hr <- as.numeric(difftime(dat.ens$date, paste0(y - 1, "-12-31"), tz = "GMT", units = "hour")) #+ minute(dat.train$date)/60 dat.ens <- dat.ens[order(dat.ens$time.hr), ] - + # ----------------------------------- 2. Predict met vars for each # ensemble member Note: Using a loop for each ensemble member for now, # but this will get parallelized to speed it up soon, but we'll # prototype in parallel ----------------------------------- - - ens.sims <- lm_ensemble_sims(dat.ens, n.ens = n.ens, - path.model = file.path(lm.models.base), lags.list = NULL, lags.init = lags.init, + + ens.sims <- lm_ensemble_sims(dat.ens, n.ens = n.ens, + path.model = file.path(lm.models.base), lags.list = NULL, lags.init = lags.init, dat.train = dat.train) - + # Set up the time dimension for this year - hrs.now <- as.numeric(difftime(dat.ens$date, paste0(y, "-01-01"), + hrs.now <- as.numeric(difftime(dat.ens$date, paste0(y, "-01-01"), tz = "GMT", units = "hour")) - + for (v in names(ens.sims)) { - lags.init[[v]] <- data.frame(ens.sims[[v]][length(ens.sims[[v]]), + lags.init[[v]] <- data.frame(ens.sims[[v]][length(ens.sims[[v]]), ]) } - + # Write each year for each ensemble member into its own .nc file - lat <- ncdf4::ncdim_def(name = "latitude", units = "degree_north", + lat <- ncdf4::ncdim_def(name = "latitude", units = "degree_north", vals = lat.in, create_dimvar = TRUE) - lon <- ncdf4::ncdim_def(name = "longitude", units = "degree_east", + lon <- ncdf4::ncdim_def(name = "longitude", units = "degree_east", vals = lon.in, create_dimvar = TRUE) - + ntime <- nrow(dat.ens) - days_elapsed <- ((1:ntime) * (ifelse(lubridate::leap_year(y), 1/(ntime/366), - 1/(ntime/365))) - (ifelse(lubridate::leap_year(y), 0.5/(ntime/366), - 0.5/(ntime/365)))) - time <- ncdf4::ncdim_def(name = "time", units = paste0("days since ", - y, "-01-01T00:00:00Z"), vals = as.array(days_elapsed), create_dimvar = TRUE, + diy <- PEcAn.utils::days_in_year(y) + days_elapsed <- (seq_len(ntime) * diy / ntime) - (0.5 * diy / ntime) + time <- ncdf4::ncdim_def(name = "time", units = paste0("days since ", + y, "-01-01T00:00:00Z"), vals = as.array(days_elapsed), create_dimvar = TRUE, unlim = TRUE) - + dim <- list(lat, lon, time) - + var.list <- list() for (j in seq_along(nc.info$CF.name)) { - var.list[[j]] <- ncdf4::ncvar_def(name = as.character(nc.info$CF.name[j]), - units = as.character(nc.info$units[j]), dim = dim, missval = -9999, + var.list[[j]] <- ncdf4::ncvar_def(name = as.character(nc.info$CF.name[j]), + units = as.character(nc.info$units[j]), dim = dim, missval = -9999, verbose = verbose) } - + for (i in seq_len(n.ens)) { df <- data.frame(matrix(ncol = length(nc.info$name), nrow = nrow(dat.ens))) colnames(df) <- nc.info$name @@ -298,24 +297,24 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, lm.models.base, e <- paste0("X", i) df[[j]] <- ens.sims[[j]][[e]] } - - df <- df[, c("air_temperature", "precipitation_flux", "surface_downwelling_shortwave_flux_in_air", - "surface_downwelling_longwave_flux_in_air", "air_pressure", + + df <- df[, c("air_temperature", "precipitation_flux", "surface_downwelling_shortwave_flux_in_air", + "surface_downwelling_longwave_flux_in_air", "air_pressure", "specific_humidity", "wind_speed")] colnames(df) <- nc.info$CF.name - + dir.create(outfolder, showWarnings = FALSE, recursive = TRUE) - loc.file <- file.path(outfolder, paste0(in.prefix, "_ens", + loc.file <- file.path(outfolder, paste0(in.prefix, "_ens", i, "_", y, ".nc")) - loc <- ncdf4::nc_create(filename = loc.file, vars = var.list, + loc <- ncdf4::nc_create(filename = loc.file, vars = var.list, verbose = verbose) - + for (j in nc.info$CF.name) { ncdf4::ncvar_put(nc = loc, varid = as.character(j), vals = df[[j]][seq_len(nrow(df))]) } ncdf4::nc_close(loc) } print(paste0("finished year ", y)) - + } } diff --git a/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R b/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R index 729f34ac0e6..a85c108c97a 100644 --- a/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R +++ b/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R @@ -38,7 +38,7 @@ dat <- read.table(fname,header=TRUE) prateA <- num(dat$Rainf.) hgtA <- rep(50,n) # geopotential height [m] SW <- num(dat$SWdown.) #w/m2 - shA <- num(dat$Qair.) + shA <- num(dat$Qair.) dlwrfA <- num(dat$LWdown.) # downward long wave radiation [W/m2] presA <- num(dat$PSurf.) # pressure [Pa] @@ -49,11 +49,10 @@ dat <- read.table(fname,header=TRUE) doy <- num(dat$doy.) hr <- num(dat$hod.) mo <- day2mo(yr,doy) - + ## calculate potential radiation ## in order to estimate diffuse/direct - f <- pi/180*(279.5+0.9856*doy) - et <- (-104.7*sin(f)+596.2*sin(2*f)+4.3*sin(4*f)-429.3*cos(f)-2.0*cos(2*f)+19.3*cos(3*f))/3600 #equation of time -> eccentricity and obliquity + et <- eccentricity_obliquity(doy) merid <- floor(lon/15)*15 if(merid<0) merid <- merid+15 lc <- (lon-merid)*-4/60 ## longitude correction @@ -65,11 +64,11 @@ dat <- read.table(fname,header=TRUE) cosz <- sin(lat*pi/180)*sin(dec)+cos(lat*pi/180)*cos(dec)*cos(h) cosz[cosz<0] <- 0 - + rpot <- 1366*cosz rpot <- rpot[1:n] rpotL <-(rpot[c(9:n,1:8)])#rad in local time - + SW[rpotL < SW] <- rpotL[rpotL 700] <- 550 AMB[AMB > 700] <- 360 - + sely = which(yr == cyr) for(m in unique(mo)){ selm <- sely[which(mo[sely] == m)]-8 @@ -124,7 +123,7 @@ for(i in 1:length(cname)){ sh <- array(shA[selm],dim=dims) tmp <- array(tmpA[selm],dim=dims) # co2 <- array(co2A[selm],dim=dims) - + ## grab & fill in other vars ## ncep <- read.table(paste("ncep/",mon_num[m],year,".dat",sep="")) ## dlwrf <- rep(ncep[,11],each=6) @@ -150,14 +149,14 @@ for(i in 1:length(cname)){ selcm[selcm < 1] <- 1 ##ambient co2 <- array(AMB[selcm],dim=c(1,1,length(selcm))) - mout <- paste("NCDF/AMB_",year,month[m],".h5",sep="") + mout <- paste("NCDF/AMB_",year,month[m],".h5",sep="") hdf5save(mout,"nbdsf","nddsf","vbdsf","vddsf","prate","dlwrf","pres","hgt" ,"ugrd","vgrd","sh","tmp","co2") ## elevated co2 <- array(ELEV[selcm],dim=c(1,1,length(selcm))) - mout <- paste("NCDF/ELEV_",year,month[m],".h5",sep="") + mout <- paste("NCDF/ELEV_",year,month[m],".h5",sep="") hdf5save(mout,"nbdsf","nddsf","vbdsf","vddsf","prate","dlwrf","pres","hgt" ,"ugrd","vgrd","sh","tmp","co2") - + } } diff --git a/modules/data.atmosphere/inst/scripts/ncep/Globalmet.R b/modules/data.atmosphere/inst/scripts/ncep/Globalmet.R index b0f60a4bed0..7d80a43b34c 100644 --- a/modules/data.atmosphere/inst/scripts/ncep/Globalmet.R +++ b/modules/data.atmosphere/inst/scripts/ncep/Globalmet.R @@ -1,4 +1,4 @@ -## Outputs the following data as .csv +## Outputs the following data as .csv ## shum:long_name = "mean Daily Specific Humidity at 2 m" ; ## shum:units = "kg/kg" ; ## shum CF: surface_specific_humidity @@ -58,56 +58,56 @@ load("/home/dlebauer/met/ncep/latlon.RData") for(loni in 1:192){ result <- list() - + currentlat <- round(Lat[lati], 2) currentlon <- round(Lon[loni], 2) print(currentlat) print(currentlon) for (i in seq(years)){ year <- years[i] - ndays <- ifelse(lubridate::leap_year(year), 366, 365) + ndays <- PEcAn.utils::days_in_year(year) days <- 1:ndays - + shum.nc <- open.ncdf(paste("/home/djaiswal/database/NCEP/SpecificHumidity/shum.2m.gauss.",year,".nc",sep="")) shum <- get.var.ncdf(shum.nc, start = c(loni, lati, 1), count = c(1, 1, ndays)) close.ncdf(shum.nc) - + rh.nc <- open.ncdf(paste("/home/djaiswal/database/NCEP/RelativeHumidity/rhum.sig995.",year,".nc",sep="")) rh <- get.var.ncdf(rh.nc, start = c(loni, lati, 1), count = c(1, 1, ndays)) close.ncdf(rh.nc) - - + + tair.nc <- open.ncdf(paste("/home/djaiswal/database/NCEP/Temperature/air.2m.gauss.",year,".nc",sep="")) temp <- get.var.ncdf(tair.nc, start = c(loni, lati, 1), count = c(1, 1, ndays)) close.ncdf(tair.nc) - + tmin.nc <- open.ncdf(paste("/home/djaiswal/database/NCEP/MinTemperature/tmin.2m.gauss.",year,".nc",sep="")) tempmin <- get.var.ncdf(tmin.nc, start = c(loni, lati, 1), count = c(1, 1, ndays)) close.ncdf(tmin.nc) - + tmax.nc <- open.ncdf(paste("/home/djaiswal/database/NCEP/MaxTemperature/tmax.2m.gauss.",year,".nc",sep="")) tempmax <- get.var.ncdf(tmax.nc, start = c(loni, lati, 1), count = c(1, 1, ndays)) close.ncdf(tmax.nc) - + uwind.nc <- open.ncdf(paste("/home/djaiswal/database/NCEP/WindspeedU/uwnd.10m.gauss.",year,".nc",sep="")) vwind.nc <- open.ncdf(paste("/home/djaiswal/database/NCEP/WindspeedV/vwnd.10m.gauss.",year,".nc",sep="")) - # need to combine these / calculate hyp. + # need to combine these / calculate hyp. vwind <- get.var.ncdf(uwind.nc, start = c(loni, lati, 1), count = c(1, 1, ndays)) uwind <- get.var.ncdf(vwind.nc, start = c(loni, lati, 1), count = c(1, 1, ndays)) close.ncdf(vwind.nc) close.ncdf(uwind.nc) - - + + solar.nc <- open.ncdf(paste("/home/djaiswal/database/NCEP/SolarRadiation/dswrf.sfc.gauss.",year,".nc",sep="")) solar <- get.var.ncdf(solar.nc, start = c(loni, lati, 1), count = c(1, 1, ndays)) close.ncdf(solar.nc) - + prate.nc <- open.ncdf(paste("/home/djaiswal/database/NCEP/Precipitation/prate.sfc.gauss.",year,".nc",sep="")) precip <- get.var.ncdf(prate.nc, start = c(loni, lati, 1), count = c(1, 1, ndays)) close.ncdf(prate.nc) - - - result[[as.character(year)]] <- data.frame(year = rep(year,ndays), day = 1:ndays, shum, rh, temp, tempmin, tempmax, uwind, vwind, solar, precip) + + + result[[as.character(year)]] <- data.frame(year = rep(year,ndays), day = 1:ndays, shum, rh, temp, tempmin, tempmax, uwind, vwind, solar, precip) } weather.dir <- file.path("/home/dlebauer/met/ncep/", paste0(abs(currentlat), diff --git a/modules/data.atmosphere/man/eccentricity_obliquity.Rd b/modules/data.atmosphere/man/eccentricity_obliquity.Rd new file mode 100644 index 00000000000..baa9cb8c701 --- /dev/null +++ b/modules/data.atmosphere/man/eccentricity_obliquity.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/eccentricity_obliquity.R +\name{eccentricity_obliquity} +\alias{eccentricity_obliquity} +\title{Equation of time: Eccentricity and obliquity} +\usage{ +eccentricity_obliquity(doy) +} +\arguments{ +\item{doy}{Day of year} +} +\description{ +Equation of time: Eccentricity and obliquity +} +\author{ +Alexey Shiklomanov +} diff --git a/modules/data.atmosphere/man/predict_subdaily_met.Rd b/modules/data.atmosphere/man/predict_subdaily_met.Rd index 66858ede3ef..b6defafc64a 100644 --- a/modules/data.atmosphere/man/predict_subdaily_met.Rd +++ b/modules/data.atmosphere/man/predict_subdaily_met.Rd @@ -36,11 +36,11 @@ predict_subdaily_met(outfolder, in.path, in.prefix, lm.models.base, } \description{ This is the main function of the tdm family workflow. This function predicts subdaily meteorology - from daily means using a linear regression modeling approach. It takes a dataset with + from daily means using a linear regression modeling approach. It takes a dataset with daily resolution and temporally downscales it to hourly resolution using the statistics generated by gen.subdaily.models(). It references the predict.subdaily.function located in lm_ensemble_sims() which uses a linear regression based approach to downscale. - We generate multiple ensembles of possible hourly values dictated from the models and betas + We generate multiple ensembles of possible hourly values dictated from the models and betas generated in gen.subdaily.models. Each ensemble member is saved as a netCDF file in CF conventions and these files are ready to be used in the general PEcAn workflow. } From 998350949a0b22f3ccedcc77fc3c15191db54b33 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 1 Sep 2017 09:30:06 -0500 Subject: [PATCH 522/771] Update Changelog. --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index abf2d76d51d..f6620482e9c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Debugged python script in call_MODIS in data.remote to allow MODIS downloads - Fixed FATES build script to work on ubuntu - SIPNET output netcdf now includes LAI; some variable names changed to match standard +- Cleanup of leap year logic, including new `PEcAn.utils::days_in_year(year)` function (#801). ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) From 6516e96098dbb7a37b0ce1d63cf9a70651c54b88 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 1 Sep 2017 09:33:21 -0500 Subject: [PATCH 523/771] Add leap year fix to `met2model.CLM45`. For completeness, even though it doesn't actually do anything yet. --- models/clm45/R/met2model.CLM45.R | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/models/clm45/R/met2model.CLM45.R b/models/clm45/R/met2model.CLM45.R index 9d7b7c890a5..f855dc8b033 100644 --- a/models/clm45/R/met2model.CLM45.R +++ b/models/clm45/R/met2model.CLM45.R @@ -61,15 +61,11 @@ met2model.CLM45 <- function(in.path,in.prefix,outfolder,start_date, end_date, ls # # ##build day and year # -# ifelse(leap_year(year)==TRUE, -# dt <- (366*24*60*60)/length(sec), #leap year -# dt <- (365*24*60*60)/length(sec)) #non-leap year +# diy <- PEcAn.utils::days_in_year(year) +# dt <- diy * 24 * 60 * 60 / length(sec) # tstep = round(timestep.s/dt) #time steps per day # -# doy <- rep(1:365,each=tstep)[1:length(sec)] -# if(lubridate::leap_year(year)){ -# doy <- rep(1:366,each=tstep)[1:length(sec)] -# } +# doy <- rep(seq_len(diy), each=tstep)[1:length(sec)] # ## extract variables. These need to be read in and converted to CLM standards From 98df91feda4717a0f17c1995a77567c08c8b0ae0 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Fri, 1 Sep 2017 10:55:53 -0400 Subject: [PATCH 524/771] delete unecessary unit --- models/gday/R/model2netcdf.GDAY.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/gday/R/model2netcdf.GDAY.R b/models/gday/R/model2netcdf.GDAY.R index ee0c8af4e9f..c05931322c3 100644 --- a/models/gday/R/model2netcdf.GDAY.R +++ b/models/gday/R/model2netcdf.GDAY.R @@ -99,7 +99,7 @@ model2netcdf.GDAY <- function(outdir, sitelat, sitelon, start_date, end_date) { ## C-State var[[7]] <- PEcAn.utils::to_ncvar("AbvGrndWood", dims) var[[8]] <- PEcAn.utils::to_ncvar("TotSoilCarb", dims) - var[[9]] <- PEcAn.utils::to_ncvar("LAI","m2/m2", dims) + var[[9]] <- PEcAn.utils::to_ncvar("LAI", dims) ## Water fluxes var[[10]] <- PEcAn.utils::to_ncvar("Evap", dims) From a1505685b8e2390f05aa04f4c409d9b3a0fad501 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 1 Sep 2017 10:08:06 -0500 Subject: [PATCH 525/771] Met: Add `PEcAn.data.atmosphere::solar_angle` function --- models/ed/R/met2model.ED2.R | 13 +------ modules/data.atmosphere/NAMESPACE | 1 + .../R/eccentricity_obliquity.R | 13 ------- modules/data.atmosphere/R/metgapfill.R | 13 ++----- modules/data.atmosphere/R/solar_angle.R | 36 +++++++++++++++++++ .../inst/scripts/ORNL_FACE_MET.v2.R | 13 +------ .../man/eccentricity_obliquity.Rd | 2 +- modules/data.atmosphere/man/solar_angle.Rd | 23 ++++++++++++ 8 files changed, 65 insertions(+), 49 deletions(-) delete mode 100644 modules/data.atmosphere/R/eccentricity_obliquity.R create mode 100644 modules/data.atmosphere/R/solar_angle.R create mode 100644 modules/data.atmosphere/man/solar_angle.Rd diff --git a/models/ed/R/met2model.ED2.R b/models/ed/R/met2model.ED2.R index ae8090ff2f9..f613258ea17 100644 --- a/models/ed/R/met2model.ED2.R +++ b/models/ed/R/met2model.ED2.R @@ -194,18 +194,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l ## calculate potential radiation in order to estimate diffuse/direct - et <- PEcAn.data.atmosphere::eccentricity_obliquity(doy) - merid <- floor(lon/15) * 15 - merid[merid < 0] <- merid[merid < 0] + 15 - lc <- (lon - merid) * -4 / 60 ## longitude correction - tz <- merid / 360 * 24 ## time zone - midbin <- 0.5 * dt / 86400 * 24 ## shift calc to middle of bin - t0 <- 12 + lc - et - tz - midbin ## solar time - h <- pi/12 * (hr - t0) ## solar hour - dec <- -23.45 * pi/180 * cos(2 * pi * (doy + 10) / 365) ## declination - - cosz <- sin(lat * pi/180) * sin(dec) + cos(lat * pi/180) * cos(dec) * cos(h) - cosz[cosz < 0] <- 0 + cosz <- PEcAn.data.atmosphere::solar_angle(doy, lat, lon, dt) rpot <- 1366 * cosz rpot <- rpot[1:length(SW)] diff --git a/modules/data.atmosphere/NAMESPACE b/modules/data.atmosphere/NAMESPACE index b932222dece..a48b9b7c945 100644 --- a/modules/data.atmosphere/NAMESPACE +++ b/modules/data.atmosphere/NAMESPACE @@ -64,6 +64,7 @@ export(save.model) export(site.lst) export(site_from_tag) export(solarMJ2ppfd) +export(solar_angle) export(spin.met) export(split_wind) export(subdaily_pred) diff --git a/modules/data.atmosphere/R/eccentricity_obliquity.R b/modules/data.atmosphere/R/eccentricity_obliquity.R deleted file mode 100644 index 33d2deb2781..00000000000 --- a/modules/data.atmosphere/R/eccentricity_obliquity.R +++ /dev/null @@ -1,13 +0,0 @@ -#' Equation of time: Eccentricity and obliquity -#' -#' @author Alexey Shiklomanov -#' @param doy Day of year -#' @export -eccentricity_obliquity <- function(doy) { - stopifnot(doy <= 366) - f <- pi / 180 * (279.5 + 0.9856 * doy) - et <- (-104.7 * sin(f) + 596.2 * sin(2 * f) + 4.3 * - sin(4 * f) - 429.3 * cos(f) - 2 * - cos(2 * f) + 19.3 * cos(3 * f)) / 3600 # equation of time -> eccentricity and obliquity - return(et) -} diff --git a/modules/data.atmosphere/R/metgapfill.R b/modules/data.atmosphere/R/metgapfill.R index 72ec1a21cfa..17a624e878f 100644 --- a/modules/data.atmosphere/R/metgapfill.R +++ b/modules/data.atmosphere/R/metgapfill.R @@ -165,17 +165,8 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst doy <- rep(seq_len(diy), each = 86400 / dt) hr <- rep(seq(0, length = 86400 / dt, by = 24 * dt / 86400), diy) - et <- eccentricity_obliquity(doy) - merid <- floor(lon / 15) * 15 - merid[merid < 0] <- merid[merid < 0] + 15 - lc <- (lon - merid) * -4/60 ## longitude correction - tz <- merid / 360 * 24 ## time zone - midbin <- 0.5 * dt / 86400 * 24 ## shift calc to middle of bin - t0 <- 12 + lc - et - tz - midbin ## solar time - h <- pi/12 * (hr - t0) ## solar hour - dec <- -23.45 * pi / 180 * cos(2 * pi * (doy + 10) / 365) ## declination - cosz <- sin(lat * pi / 180) * sin(dec) + cos(lat * pi / 180) * cos(dec) * cos(h) - cosz[cosz < 0] <- 0 + cosz <- PEcAn.data.atmosphere::solar_angle(doy, lat, lon, dt) + rpot <- 1366 * cosz #in UTC tz <- as.numeric(lst) if(is.na(tz)){ diff --git a/modules/data.atmosphere/R/solar_angle.R b/modules/data.atmosphere/R/solar_angle.R new file mode 100644 index 00000000000..4f078ae67d4 --- /dev/null +++ b/modules/data.atmosphere/R/solar_angle.R @@ -0,0 +1,36 @@ +#' Calculate solar angle +#' +#' @author Alexey Shiklomanov +#' @param doy Day of year +#' @param lat Latitude +#' @param lon Longitude +#' @param dt Timestep +#' @export +solar_angle <- function(doy, lat, lon, dt) { + et <- eccentricity_obliquity(doy) + merid <- floor(lon / 15) * 15 + merid[merid < 0] <- merid[merid < 0] + 15 + lc <- (lon - merid) * -4/60 ## longitude correction + tz <- merid / 360 * 24 ## time zone + midbin <- 0.5 * dt / 86400 * 24 ## shift calc to middle of bin + t0 <- 12 + lc - et - tz - midbin ## solar time + h <- pi/12 * (hr - t0) ## solar hour + dec <- -23.45 * pi / 180 * cos(2 * pi * (doy + 10) / 365) ## declination + cosz <- sin(lat * pi / 180) * sin(dec) + cos(lat * pi / 180) * cos(dec) * cos(h) + cosz[cosz < 0] <- 0 + return(cosz) +} + +#' Equation of time: Eccentricity and obliquity +#' +#' @author Alexey Shiklomanov +#' @param doy Day of year +#' @export +eccentricity_obliquity <- function(doy) { + stopifnot(doy <= 366) + f <- pi / 180 * (279.5 + 0.9856 * doy) + et <- (-104.7 * sin(f) + 596.2 * sin(2 * f) + 4.3 * + sin(4 * f) - 429.3 * cos(f) - 2 * + cos(2 * f) + 19.3 * cos(3 * f)) / 3600 # equation of time -> eccentricity and obliquity + return(et) +} diff --git a/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R b/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R index a85c108c97a..9aa165c708d 100644 --- a/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R +++ b/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R @@ -52,18 +52,7 @@ dat <- read.table(fname,header=TRUE) ## calculate potential radiation ## in order to estimate diffuse/direct - et <- eccentricity_obliquity(doy) - merid <- floor(lon/15)*15 - if(merid<0) merid <- merid+15 - lc <- (lon-merid)*-4/60 ## longitude correction - tz <- merid/360*24 ## time zone - midbin <- 0.5*dt/86400*24 ## shift calc to middle of bin - t0 <- 12+lc-et-tz-midbin ## solar time - h <- pi/12*(hr-t0) ## solar hour - dec <- -23.45*pi/180*cos(2*pi*(doy+10)/365) ## declination - - cosz <- sin(lat*pi/180)*sin(dec)+cos(lat*pi/180)*cos(dec)*cos(h) - cosz[cosz<0] <- 0 + cosz <- PEcAn.data.atmosphere::solar_angle(doy, lat, lon, dt) rpot <- 1366*cosz rpot <- rpot[1:n] diff --git a/modules/data.atmosphere/man/eccentricity_obliquity.Rd b/modules/data.atmosphere/man/eccentricity_obliquity.Rd index baa9cb8c701..b5e4d55987c 100644 --- a/modules/data.atmosphere/man/eccentricity_obliquity.Rd +++ b/modules/data.atmosphere/man/eccentricity_obliquity.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/eccentricity_obliquity.R +% Please edit documentation in R/solar_angle.R \name{eccentricity_obliquity} \alias{eccentricity_obliquity} \title{Equation of time: Eccentricity and obliquity} diff --git a/modules/data.atmosphere/man/solar_angle.Rd b/modules/data.atmosphere/man/solar_angle.Rd new file mode 100644 index 00000000000..fb81501e944 --- /dev/null +++ b/modules/data.atmosphere/man/solar_angle.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/solar_angle.R +\name{solar_angle} +\alias{solar_angle} +\title{Calculate solar angle} +\usage{ +solar_angle(doy, lat, lon, dt) +} +\arguments{ +\item{doy}{Day of year} + +\item{lat}{Latitude} + +\item{lon}{Longitude} + +\item{dt}{Timestep} +} +\description{ +Calculate solar angle +} +\author{ +Alexey Shiklomanov +} From 9625c841775d3e9e0bd86e616efb62a7f4291a97 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 1 Sep 2017 11:16:32 -0400 Subject: [PATCH 526/771] Update changelog --- CHANGELOG.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f6620482e9c..08b7ff463f5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,10 +17,12 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Debugged python script in call_MODIS in data.remote to allow MODIS downloads - Fixed FATES build script to work on ubuntu - SIPNET output netcdf now includes LAI; some variable names changed to match standard -- Cleanup of leap year logic, including new `PEcAn.utils::days_in_year(year)` function (#801). +- Cleanup of leap year logic, using new `PEcAn.utils::days_in_year(year)` function (#801). ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) +- New `PEcAn.utils::days_in_year(year)` function that should make it easier to work with leap years. +- New `PEcAn.data.atmosphere::solar_angle` function that replaces math that occurs in some models. - #1594 shiny/workflowPlot Adding interactiveness using ggploltly - #1594 shiny/workflowPlot Load outputs from multiple runs of the model From 1ea481773fc7c60be46d89f2179abd6b969429ec Mon Sep 17 00:00:00 2001 From: annethomas Date: Fri, 1 Sep 2017 13:04:16 -0400 Subject: [PATCH 527/771] Reformat netcdf time variable/dimension --- modules/data.remote/inst/modisWSDL.py | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 96cd3b52b5c..954b069942f 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -352,16 +352,25 @@ def m_data_to_netCDF(filename, m, k, kmLR, kmAB): rootgrp.createDimension('nrow', nrow) rootgrp.createDimension('ncol', ncol) rootgrp.createDimension('time', len(m.dateInt)) - m_data = rootgrp.createVariable('LAI', 'f8', ('nrow', 'ncol','time')) - m_std = rootgrp.createVariable('LAIStd', 'f8', ('nrow', 'ncol','time')) - m_date = rootgrp.createVariable('Dates', 'i8', ('time')) + + m_date = rootgrp.createVariable('time', 'i8', ('time')) + start=str(m.dateInt[0]) + startDate = datetime.datetime.strptime(start, '%Y%j') + year = startDate.year + m_date.units = 'days since %d 00:00:00.0'%(year) + + m_data = rootgrp.createVariable('LAI', 'f8', ('time', 'ncol', 'nrow')) + m_std = rootgrp.createVariable('LAIStd', 'f8', ('time', 'ncol', 'nrow')) + + str_dates = [str(d) for d in m.dateInt] + datetimes = [(datetime.datetime.strptime(d, '%Y%j')- datetime.datetime(year,1,1)).days for d in str_dates] + m_date[:] = datetimes + __debugPrint( "populated dates in netcdf" ) m_data[:] = m.data __debugPrint( "populated LAI data in netcdf" ) if k is not None: m_std[:] = 0.1*k.data __debugPrint( "populated LAIstd data in netcdf" ) - m_date[:] = m.dateInt - __debugPrint( "populated dates in netcdf" ) rootgrp.close() #def m_date_to_netCDF(filename, varname, data): From f50ee489a0281d2f4527b5b8aaa8a2d70edb7935 Mon Sep 17 00:00:00 2001 From: annethomas Date: Fri, 1 Sep 2017 13:09:09 -0400 Subject: [PATCH 528/771] Import datetime --- modules/data.remote/inst/modisWSDL.py | 2 ++ 1 file changed, 2 insertions(+) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 954b069942f..bf55e392a04 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -346,6 +346,8 @@ def dateInt_to_posix(date): return temp.strftime('%Y-%m-%d') def m_data_to_netCDF(filename, m, k, kmLR, kmAB): + import datetime + rootgrp = netCDF4.Dataset(filename, 'w', format='NETCDF4') nrow = 1 + 2*kmAB ncol = 1 + 2*kmLR From b30d92d05fcfbf0090d863ee661a5fc27f19d0d2 Mon Sep 17 00:00:00 2001 From: annethomas Date: Fri, 1 Sep 2017 13:20:21 -0400 Subject: [PATCH 529/771] Date fixes --- modules/data.remote/inst/modisWSDL.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index bf55e392a04..84c66bcc6bb 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -359,13 +359,13 @@ def m_data_to_netCDF(filename, m, k, kmLR, kmAB): start=str(m.dateInt[0]) startDate = datetime.datetime.strptime(start, '%Y%j') year = startDate.year - m_date.units = 'days since %d 00:00:00.0'%(year) + m_date.units = 'days since %d-01-01 00:00:00.0'%(year) m_data = rootgrp.createVariable('LAI', 'f8', ('time', 'ncol', 'nrow')) m_std = rootgrp.createVariable('LAIStd', 'f8', ('time', 'ncol', 'nrow')) str_dates = [str(d) for d in m.dateInt] - datetimes = [(datetime.datetime.strptime(d, '%Y%j')- datetime.datetime(year,1,1)).days for d in str_dates] + datetimes = [(datetime.datetime.strptime(d, '%Y%j')- datetime.datetime(year,1,1)).days+1 for d in str_dates] m_date[:] = datetimes __debugPrint( "populated dates in netcdf" ) m_data[:] = m.data From b767d8886a67024c11a09be4b348f5b27ce33505 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 1 Sep 2017 13:32:05 -0400 Subject: [PATCH 530/771] Fix documentation --- models/jules/man/detect.timestep.Rd | 4 ---- 1 file changed, 4 deletions(-) diff --git a/models/jules/man/detect.timestep.Rd b/models/jules/man/detect.timestep.Rd index e715f4d7743..86f77712086 100644 --- a/models/jules/man/detect.timestep.Rd +++ b/models/jules/man/detect.timestep.Rd @@ -7,10 +7,6 @@ detect.timestep(met.dir, met.regexp, start_date) } \arguments{ -\item{met.dir}{} - -\item{met.regexp}{} - \item{start_date}{} } \description{ From 00b2bc7ed87a1613c15d0b2f32fe30b784db77ba Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Fri, 1 Sep 2017 14:46:45 -0400 Subject: [PATCH 531/771] Change outdir per @robkooper 's request --- tests/pecan64.ed.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/pecan64.ed.xml b/tests/pecan64.ed.xml index 19e91c2253f..36e88af37e4 100644 --- a/tests/pecan64.ed.xml +++ b/tests/pecan64.ed.xml @@ -1,6 +1,6 @@ - /home/carya/pecan_tests/pecan64.ed.xml + pecan_ed_test From 08f895719de24c862431d26b6f759c6fba005549 Mon Sep 17 00:00:00 2001 From: adesai Date: Mon, 4 Sep 2017 13:07:21 -0500 Subject: [PATCH 532/771] Bug fix on get.id call --- base/db/R/dbfiles.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/db/R/dbfiles.R b/base/db/R/dbfiles.R index 8649ec58567..3f9867a136e 100644 --- a/base/db/R/dbfiles.R +++ b/base/db/R/dbfiles.R @@ -186,7 +186,7 @@ dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, f } # find appropriate format - formatid <- get.id(table = 'formats', values = c("mimetype_id", "name"), colnames = c(mimetypeid, formatname), con = con) + formatid <- get.id(table = 'formats', colnames = c("mimetype_id", "name"), values = c(mimetypeid, formatname), con = con) if (is.null(formatid)) { invisible(data.frame()) } From d70d9115d68b38242da00997bb5f2c739cbe5614 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Mon, 4 Sep 2017 16:52:40 -0400 Subject: [PATCH 533/771] Changed from fluidpage to shinydashboard format --- shiny/Data-Ingest/app.R | 45 +++++++++++++++++++++++++++++------------ 1 file changed, 32 insertions(+), 13 deletions(-) diff --git a/shiny/Data-Ingest/app.R b/shiny/Data-Ingest/app.R index eab9229bc69..a776258d81a 100644 --- a/shiny/Data-Ingest/app.R +++ b/shiny/Data-Ingest/app.R @@ -10,22 +10,41 @@ library(shiny) library(PEcAn.data.land) library(shinyDND) +library(shinydashboard) + # Define UI for application -ui <- fluidPage( - - titlePanel("Data Ingest"), - - textInput("id", label = h3("Import From DataONE"), placeholder = "Enter doi or id here"), - actionButton(inputId = "D1Button", label = "Upload"), - - hr(), - fluidRow(column(3, verbatimTextOutput("identifier"))), - - # https://github.com/rstudio/shiny-examples/blob/master/009-upload/app.R - fileInput(inputId = "file", label = h3("Select Local Files for Upload"), accept = NULL, multiple = TRUE), - p("One or more files") +ui <- dashboardPage( + dashboardHeader(title = "Data Ingest"), + dashboardSidebar(), + dashboardBody( + + fluidRow( + box( + textInput("id", label = h3("Import From DataONE"), placeholder = "Enter doi or id here"), + actionButton(inputId = "D1Button", label = "Upload"), + hr(), + fluidRow(column(12, verbatimTextOutput("identifier"))) + ), + + box( + # https://github.com/rstudio/shiny-examples/blob/master/009-upload/app.R + fileInput(inputId = "file", label = h3("Upload Local Files"), accept = NULL, multiple = TRUE), + p("One or more files") + ) + ), + + dashboardSidebar( + sidebarMenu( + menuItem("Import Data", tabName = "importData", icon = icon("file")), + menuItem("Step 2 -- dbfiles record", tabName = "step2", icon = icon("cog")), + menuItem("Step 3 -- format record", tabName = "step3", icon = icon("cog")), + menuItem("Step 4 -- etc.", tabName = "step4", icon = icon("cog")) + ) + ) + + ) ) server <- function(input, output) { From 41571362f6a74b8c2381f9314f572dda0fee6095 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Tue, 5 Sep 2017 00:38:09 -0400 Subject: [PATCH 534/771] remove importFrom --- models/biocro/NAMESPACE | 3 --- models/biocro/R/met2model.BIOCRO.R | 11 ++++++----- 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/models/biocro/NAMESPACE b/models/biocro/NAMESPACE index d22030b66cb..5c01df54ab9 100644 --- a/models/biocro/NAMESPACE +++ b/models/biocro/NAMESPACE @@ -11,7 +11,4 @@ export(run.biocro) export(write.config.BIOCRO) import(PEcAn.utils) import(data.table) -importFrom(PEcAn.data.atmosphere,par2ppfd) -importFrom(PEcAn.data.atmosphere,qair2rh) -importFrom(PEcAn.data.atmosphere,sw2par) importFrom(data.table,":=") diff --git a/models/biocro/R/met2model.BIOCRO.R b/models/biocro/R/met2model.BIOCRO.R index 47d6b97be71..e34c89e48ba 100644 --- a/models/biocro/R/met2model.BIOCRO.R +++ b/models/biocro/R/met2model.BIOCRO.R @@ -135,7 +135,6 @@ met2model.BIOCRO <- function(in.path, in.prefix, outfolder, overwrite = FALSE, ##' } ##' @export cf2biocro ##' @import PEcAn.utils -##' @importFrom PEcAn.data.atmosphere qair2rh sw2par par2ppfd ##' @importFrom data.table := ##' @author David LeBauer cf2biocro <- function(met, longitude = NULL, zulu2solarnoon = FALSE) { @@ -146,8 +145,10 @@ cf2biocro <- function(met, longitude = NULL, zulu2solarnoon = FALSE) { } if (!"relative_humidity" %in% colnames(met)) { if (all(c("air_temperature", "air_pressure", "specific_humidity") %in% colnames(met))) { - rh <- qair2rh(qair = met$specific_humidity, temp = udunits2::ud.convert(met$air_temperature, - "Kelvin", "Celsius"), press = udunits2::ud.convert(met$air_pressure, "Pa", "hPa")) + rh <- PEcAn.data.atmosphere::qair2rh( + qair = met$specific_humidity, + temp = udunits2::ud.convert(met$air_temperature, "Kelvin", "Celsius"), + press = udunits2::ud.convert(met$air_pressure, "Pa", "hPa")) met <- cbind(met, relative_humidity = rh * 100) } else { PEcAn.logger::logger.error("neither relative_humidity nor [air_temperature, air_pressure, and specific_humidity]", @@ -158,8 +159,8 @@ cf2biocro <- function(met, longitude = NULL, zulu2solarnoon = FALSE) { if ("surface_downwelling_photosynthetic_photon_flux_in_air" %in% colnames(met)) { ppfd <- udunits2::ud.convert(met$surface_downwelling_photosynthetic_photon_flux_in_air, "mol", "umol") } else if ("surface_downwelling_shortwave_flux_in_air" %in% colnames(met)) { - par <- sw2par(met$surface_downwelling_shortwave_flux_in_air) - ppfd <- par2ppfd(par) + par <- PEcAn.data.atmosphere::sw2par(met$surface_downwelling_shortwave_flux_in_air) + ppfd <- PEcAn.data.atmosphere::par2ppfd(par) } else { PEcAn.logger::logger.error("Need either ppfd or surface_downwelling_shortwave_flux_in_air in met dataset") } From f0a44ff59d67d79dc24d9df7289078e07f3ff086 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Tue, 5 Sep 2017 00:38:20 -0400 Subject: [PATCH 535/771] typo --- models/biocro/R/met2model.BIOCRO.R | 2 +- models/biocro/man/met2model.BIOCRO.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/models/biocro/R/met2model.BIOCRO.R b/models/biocro/R/met2model.BIOCRO.R index e34c89e48ba..b6c0c885b17 100644 --- a/models/biocro/R/met2model.BIOCRO.R +++ b/models/biocro/R/met2model.BIOCRO.R @@ -10,7 +10,7 @@ .datatable.aware <- TRUE ##-------------------------------------------------------------------------------------------------# ##' Converts a met CF file to a model specific met file. The input -##' files are calld /.YYYY.cf +##' files are called /.YYYY.cf ##' ##' @name met2model.BIOCRO ##' @title Write BioCro met files diff --git a/models/biocro/man/met2model.BIOCRO.Rd b/models/biocro/man/met2model.BIOCRO.Rd index ea0d133d287..49e18797939 100644 --- a/models/biocro/man/met2model.BIOCRO.Rd +++ b/models/biocro/man/met2model.BIOCRO.Rd @@ -27,7 +27,7 @@ a dataframe of information about the written file } \description{ Converts a met CF file to a model specific met file. The input -files are calld /.YYYY.cf +files are called /.YYYY.cf } \author{ Rob Kooper, David LeBauer From a04a3d1cb47797bd59c82598afb8e3ee1d401aa7 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 5 Sep 2017 09:41:29 -0400 Subject: [PATCH 536/771] Improve documentation for solar angle math Per @dlebauer recommendations. --- modules/data.atmosphere/NAMESPACE | 4 +-- modules/data.atmosphere/R/metgapfill.R | 2 +- modules/data.atmosphere/R/solar_angle.R | 14 +++++++--- .../inst/scripts/ORNL_FACE_MET.v2.R | 2 +- .../man/cos_solar_zenith_angle.Rd | 26 +++++++++++++++++++ .../man/eccentricity_obliquity.Rd | 17 ------------ .../data.atmosphere/man/equation_of_time.Rd | 20 ++++++++++++++ modules/data.atmosphere/man/solar_angle.Rd | 23 ---------------- 8 files changed, 60 insertions(+), 48 deletions(-) create mode 100644 modules/data.atmosphere/man/cos_solar_zenith_angle.Rd delete mode 100644 modules/data.atmosphere/man/eccentricity_obliquity.Rd create mode 100644 modules/data.atmosphere/man/equation_of_time.Rd delete mode 100644 modules/data.atmosphere/man/solar_angle.Rd diff --git a/modules/data.atmosphere/NAMESPACE b/modules/data.atmosphere/NAMESPACE index a48b9b7c945..07f9b211132 100644 --- a/modules/data.atmosphere/NAMESPACE +++ b/modules/data.atmosphere/NAMESPACE @@ -8,6 +8,7 @@ export(cfmet.downscale.daily) export(cfmet.downscale.subdaily) export(cfmet.downscale.time) export(closest_xy) +export(cos_solar_zenith_angle) export(db.site.lat.lon) export(debias.met) export(download.Ameriflux) @@ -26,7 +27,7 @@ export(download.NEONmet) export(download.NLDAS) export(download.PalEON) export(download.PalEON_ENS) -export(eccentricity_obliquity) +export(equation_of_time) export(exner) export(extract.nc) export(gen.subdaily.models) @@ -64,7 +65,6 @@ export(save.model) export(site.lst) export(site_from_tag) export(solarMJ2ppfd) -export(solar_angle) export(spin.met) export(split_wind) export(subdaily_pred) diff --git a/modules/data.atmosphere/R/metgapfill.R b/modules/data.atmosphere/R/metgapfill.R index 17a624e878f..07d660150bd 100644 --- a/modules/data.atmosphere/R/metgapfill.R +++ b/modules/data.atmosphere/R/metgapfill.R @@ -165,7 +165,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst doy <- rep(seq_len(diy), each = 86400 / dt) hr <- rep(seq(0, length = 86400 / dt, by = 24 * dt / 86400), diy) - cosz <- PEcAn.data.atmosphere::solar_angle(doy, lat, lon, dt) + cosz <- PEcAn.data.atmosphere::cos_solar_zenith_angle(doy, lat, lon, dt) rpot <- 1366 * cosz #in UTC tz <- as.numeric(lst) diff --git a/modules/data.atmosphere/R/solar_angle.R b/modules/data.atmosphere/R/solar_angle.R index 4f078ae67d4..4b64d393eec 100644 --- a/modules/data.atmosphere/R/solar_angle.R +++ b/modules/data.atmosphere/R/solar_angle.R @@ -1,13 +1,16 @@ -#' Calculate solar angle +#' Cosine of solar zenith angle +#' +#' For explanations of formulae, see http://www.itacanet.org/the-sun-as-a-source-of-energy/part-3-calculating-solar-angles/ #' #' @author Alexey Shiklomanov #' @param doy Day of year #' @param lat Latitude #' @param lon Longitude #' @param dt Timestep +#' @return `numeric(1)` of cosine of solar zenith angle #' @export -solar_angle <- function(doy, lat, lon, dt) { - et <- eccentricity_obliquity(doy) +cos_solar_zenith_angle <- function(doy, lat, lon, dt) { + et <- equation_of_time(doy) merid <- floor(lon / 15) * 15 merid[merid < 0] <- merid[merid < 0] + 15 lc <- (lon - merid) * -4/60 ## longitude correction @@ -23,10 +26,13 @@ solar_angle <- function(doy, lat, lon, dt) { #' Equation of time: Eccentricity and obliquity #' +#' For description of calculations, see https://en.wikipedia.org/wiki/Equation_of_time#Calculating_the_equation_of_time +#' #' @author Alexey Shiklomanov #' @param doy Day of year +#' @return `numeric(1)` length of the solar day, in hours. #' @export -eccentricity_obliquity <- function(doy) { +equation_of_time <- function(doy) { stopifnot(doy <= 366) f <- pi / 180 * (279.5 + 0.9856 * doy) et <- (-104.7 * sin(f) + 596.2 * sin(2 * f) + 4.3 * diff --git a/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R b/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R index 9aa165c708d..7ed9f0b9f5f 100644 --- a/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R +++ b/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R @@ -52,7 +52,7 @@ dat <- read.table(fname,header=TRUE) ## calculate potential radiation ## in order to estimate diffuse/direct - cosz <- PEcAn.data.atmosphere::solar_angle(doy, lat, lon, dt) + cosz <- PEcAn.data.atmosphere::cos_solar_zenith_angle(doy, lat, lon, dt) rpot <- 1366*cosz rpot <- rpot[1:n] diff --git a/modules/data.atmosphere/man/cos_solar_zenith_angle.Rd b/modules/data.atmosphere/man/cos_solar_zenith_angle.Rd new file mode 100644 index 00000000000..e07ed88b670 --- /dev/null +++ b/modules/data.atmosphere/man/cos_solar_zenith_angle.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/solar_angle.R +\name{cos_solar_zenith_angle} +\alias{cos_solar_zenith_angle} +\title{Cosine of solar zenith angle} +\usage{ +cos_solar_zenith_angle(doy, lat, lon, dt) +} +\arguments{ +\item{doy}{Day of year} + +\item{lat}{Latitude} + +\item{lon}{Longitude} + +\item{dt}{Timestep} +} +\value{ +`numeric(1)` of cosine of solar zenith angle +} +\description{ +For explanations of formulae, see http://www.itacanet.org/the-sun-as-a-source-of-energy/part-3-calculating-solar-angles/ +} +\author{ +Alexey Shiklomanov +} diff --git a/modules/data.atmosphere/man/eccentricity_obliquity.Rd b/modules/data.atmosphere/man/eccentricity_obliquity.Rd deleted file mode 100644 index b5e4d55987c..00000000000 --- a/modules/data.atmosphere/man/eccentricity_obliquity.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/solar_angle.R -\name{eccentricity_obliquity} -\alias{eccentricity_obliquity} -\title{Equation of time: Eccentricity and obliquity} -\usage{ -eccentricity_obliquity(doy) -} -\arguments{ -\item{doy}{Day of year} -} -\description{ -Equation of time: Eccentricity and obliquity -} -\author{ -Alexey Shiklomanov -} diff --git a/modules/data.atmosphere/man/equation_of_time.Rd b/modules/data.atmosphere/man/equation_of_time.Rd new file mode 100644 index 00000000000..ad0621b0861 --- /dev/null +++ b/modules/data.atmosphere/man/equation_of_time.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/solar_angle.R +\name{equation_of_time} +\alias{equation_of_time} +\title{Equation of time: Eccentricity and obliquity} +\usage{ +equation_of_time(doy) +} +\arguments{ +\item{doy}{Day of year} +} +\value{ +`numeric(1)` length of the solar day, in hours. +} +\description{ +For description of calculations, see https://en.wikipedia.org/wiki/Equation_of_time#Calculating_the_equation_of_time +} +\author{ +Alexey Shiklomanov +} diff --git a/modules/data.atmosphere/man/solar_angle.Rd b/modules/data.atmosphere/man/solar_angle.Rd deleted file mode 100644 index fb81501e944..00000000000 --- a/modules/data.atmosphere/man/solar_angle.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/solar_angle.R -\name{solar_angle} -\alias{solar_angle} -\title{Calculate solar angle} -\usage{ -solar_angle(doy, lat, lon, dt) -} -\arguments{ -\item{doy}{Day of year} - -\item{lat}{Latitude} - -\item{lon}{Longitude} - -\item{dt}{Timestep} -} -\description{ -Calculate solar angle -} -\author{ -Alexey Shiklomanov -} From b5ce0582afba9e163248d9faf7305cc590e8f023 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 5 Sep 2017 09:54:28 -0400 Subject: [PATCH 537/771] Add `utils::seconds_in_year` function Use it in all the `met2model` code instead of hard-coded math. --- base/utils/NAMESPACE | 1 + base/utils/R/days_in_year.R | 2 +- base/utils/R/seconds_in_year.R | 14 ++++++++++++++ base/utils/man/days_in_year.Rd | 2 +- base/utils/man/seconds_in_year.Rd | 22 ++++++++++++++++++++++ models/clm45/R/met2model.CLM45.R | 4 ++-- models/dalec/R/met2model.DALEC.R | 4 ++-- models/ed/R/met2model.ED2.R | 5 ++--- models/linkages/R/met2model.LINKAGES.R | 3 +-- models/maat/R/met2model.MAAT.R | 3 +-- models/maespa/R/met2model.MAESPA.R | 3 +-- models/preles/R/runPRELES.jobsh.R | 4 ++-- models/sipnet/R/met2model.SIPNET.R | 6 +----- modules/data.atmosphere/R/metgapfill.R | 2 +- 14 files changed, 52 insertions(+), 23 deletions(-) create mode 100644 base/utils/R/seconds_in_year.R create mode 100644 base/utils/man/seconds_in_year.Rd diff --git a/base/utils/NAMESPACE b/base/utils/NAMESPACE index 5fed2312189..cde2e4dd9ad 100644 --- a/base/utils/NAMESPACE +++ b/base/utils/NAMESPACE @@ -72,6 +72,7 @@ export(run.write.configs) export(runModule.get.results) export(runModule.run.write.configs) export(runModule.start.model.runs) +export(seconds_in_year) export(sendmail) export(sensitivity.filename) export(ssh) diff --git a/base/utils/R/days_in_year.R b/base/utils/R/days_in_year.R index 46112fdb080..4192f4f8459 100644 --- a/base/utils/R/days_in_year.R +++ b/base/utils/R/days_in_year.R @@ -2,7 +2,7 @@ #' #' Calculate number of days in a year based on whether it is a leap year or not. #' -#' @param year Numeric year +#' @param year Numeric year (can be a vector) #' #' @author Alexey Shiklomanov #' @return diff --git a/base/utils/R/seconds_in_year.R b/base/utils/R/seconds_in_year.R new file mode 100644 index 00000000000..1703462a1d9 --- /dev/null +++ b/base/utils/R/seconds_in_year.R @@ -0,0 +1,14 @@ +#' Number of seconds in a given year +#' +#' @author Alexey Shiklomanov +#' @param year Numeric year (can be a vector) +#' @examples +#' seconds_in_year(2000) # Leap year -- 366 x 24 x 60 x 60 = 31622400 +#' seconds_in_year(2001) # Regular year -- 365 x 24 x 60 x 60 = 31536000 +#' seconds_in_year(2000:2005) # Vectorized over year +#' @export +seconds_in_year <- function(year) { + diy <- days_in_year(year) + siy <- udunits2::ud.convert(diy, 'days', 'seconds') + return(siy) +} diff --git a/base/utils/man/days_in_year.Rd b/base/utils/man/days_in_year.Rd index 3f715982270..8ddb24ff2e5 100644 --- a/base/utils/man/days_in_year.Rd +++ b/base/utils/man/days_in_year.Rd @@ -7,7 +7,7 @@ days_in_year(year) } \arguments{ -\item{year}{Numeric year} +\item{year}{Numeric year (can be a vector)} } \description{ Calculate number of days in a year based on whether it is a leap year or not. diff --git a/base/utils/man/seconds_in_year.Rd b/base/utils/man/seconds_in_year.Rd new file mode 100644 index 00000000000..66498a0cd67 --- /dev/null +++ b/base/utils/man/seconds_in_year.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/seconds_in_year.R +\name{seconds_in_year} +\alias{seconds_in_year} +\title{Number of seconds in a given year} +\usage{ +seconds_in_year(year) +} +\arguments{ +\item{year}{Numeric year (can be a vector)} +} +\description{ +Number of seconds in a given year +} +\examples{ +seconds_in_year(2000) # Leap year -- 366 x 24 x 60 x 60 = 31622400 +seconds_in_year(2001) # Regular year -- 365 x 24 x 60 x 60 = 31536000 +seconds_in_year(2000:2005) # Vectorized over year +} +\author{ +Alexey Shiklomanov +} diff --git a/models/clm45/R/met2model.CLM45.R b/models/clm45/R/met2model.CLM45.R index f855dc8b033..c246f20326b 100644 --- a/models/clm45/R/met2model.CLM45.R +++ b/models/clm45/R/met2model.CLM45.R @@ -61,10 +61,10 @@ met2model.CLM45 <- function(in.path,in.prefix,outfolder,start_date, end_date, ls # # ##build day and year # -# diy <- PEcAn.utils::days_in_year(year) -# dt <- diy * 24 * 60 * 60 / length(sec) +# dt <- PEcAn.utils::seconds_in_year(year) / length(sec) # tstep = round(timestep.s/dt) #time steps per day # +# diy <- PEcAn.utils::days_in_year(year) # doy <- rep(seq_len(diy), each=tstep)[1:length(sec)] # diff --git a/models/dalec/R/met2model.DALEC.R b/models/dalec/R/met2model.DALEC.R index bde12e127d9..2d93176e82f 100644 --- a/models/dalec/R/met2model.DALEC.R +++ b/models/dalec/R/met2model.DALEC.R @@ -110,8 +110,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, sec <- nc$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") timestep.s <- 86400 # seconds in a day - diy <- PEcAn.utils::days_in_year(year) - dt <- diy * 24 * 60 * 60 / length(sec) + dt <- PEcAn.utils::seconds_in_year(year) / length(sec) tstep <- round(timestep.s / dt) dt <- timestep.s / tstep #dt is now an integer @@ -149,6 +148,7 @@ met2model.DALEC <- function(in.path, in.prefix, outfolder, start_date, end_date, } ## build day of year + diy <- PEcAn.utils::days_in_year(year) doy <- rep(seq_len(diy), each = timestep.s / dt)[seq_along(sec)] ## Aggregate variables up to daily diff --git a/models/ed/R/met2model.ED2.R b/models/ed/R/met2model.ED2.R index f613258ea17..695a039d2a9 100644 --- a/models/ed/R/met2model.ED2.R +++ b/models/ed/R/met2model.ED2.R @@ -127,8 +127,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l ncdf4::nc_close(nc) - diy <- PEcAn.utils::days_in_year(year) - dt <- diy * 24 * 60 * 60 / length(sec) + dt <- PEcAn.utils::seconds_in_year(year) / length(sec) toff <- -as.numeric(lst) * 3600 / dt @@ -194,7 +193,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l ## calculate potential radiation in order to estimate diffuse/direct - cosz <- PEcAn.data.atmosphere::solar_angle(doy, lat, lon, dt) + cosz <- PEcAn.data.atmosphere::cos_solar_zenith_angle(doy, lat, lon, dt) rpot <- 1366 * cosz rpot <- rpot[1:length(SW)] diff --git a/models/linkages/R/met2model.LINKAGES.R b/models/linkages/R/met2model.LINKAGES.R index 7624d2d46d0..57691e3d011 100644 --- a/models/linkages/R/met2model.LINKAGES.R +++ b/models/linkages/R/met2model.LINKAGES.R @@ -77,8 +77,7 @@ met2model.LINKAGES <- function(in.path, in.prefix, outfolder, start_date, end_da ## convert time to seconds sec <- ncin$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(ncin$dim$time$units, " "))[1], "seconds") - diy <- PEcAn.utils::days_in_year(as.numeric(year[i])) - dt <- diy * 24 * 60 * 60 / length(sec) + dt <- PEcAn.utils::seconds_in_year(as.numeric(year[i])) / length(sec) tstep <- 86400 / dt ncprecipf <- ncdf4::ncvar_get(ncin, "precipitation_flux") # units are kg m-2 s-1 diff --git a/models/maat/R/met2model.MAAT.R b/models/maat/R/met2model.MAAT.R index 874b955e3d4..2c1a0984bbd 100644 --- a/models/maat/R/met2model.MAAT.R +++ b/models/maat/R/met2model.MAAT.R @@ -96,8 +96,7 @@ met2model.MAAT <- function(in.path, in.prefix, outfolder, start_date, end_date, frac.day <- nc$dim$time$vals sec <- ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") - diy <- PEcAn.utils::days_in_year(year) - dt <- diy * 24 * 60 * 60 / length(sec) + dt <- PEcAn.utils::seconds_in_year(year) / length(sec) tstep <- round(86400 / dt) dt <- 86400 / tstep diff --git a/models/maespa/R/met2model.MAESPA.R b/models/maespa/R/met2model.MAESPA.R index 7a716f83919..37f16ff19f9 100755 --- a/models/maespa/R/met2model.MAESPA.R +++ b/models/maespa/R/met2model.MAESPA.R @@ -88,8 +88,7 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date sec <- nc$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") - diy <- PEcAn.utils::days_in_year(year) - dt <- diy * 24 * 60 * 60 / length(sec) + dt <- PEcAn.utils::seconds_in_year(year) / length(sec) tstep <- round(86400 / dt) dt <- 86400 / tstep diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index 4bc7b0ee5d9..aecacabf8be 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -49,10 +49,10 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star ## build day and year - diy <- PEcAn.utils::days_in_year(year) - dt <- diy * 24 * 60 * 60 / length(sec) + dt <- PEcAn.utils::seconds_in_year(year) / length(sec) tstep <- round(timestep.s / dt) #time steps per day + diy <- PEcAn.utils::days_in_year(year) doy <- seq_len(diy, each = tstep)[seq_along(sec)] ## Get variables from netcdf file diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index 3b21ad395f0..e250eb10a9a 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -27,8 +27,6 @@ ##' @importFrom ncdf4 ncvar_get met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { - library(PEcAn.utils) - PEcAn.logger::logger.info("START met2model.SIPNET") start_date <- as.POSIXlt(start_date, tz = "UTC") end_date <- as.POSIXlt(end_date, tz = "UTC") @@ -54,8 +52,6 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date return(invisible(results)) } - library(PEcAn.data.atmosphere) - ## check to see if the outfolder is defined, if not create directory for output if (!file.exists(outfolder)) { dir.create(outfolder) @@ -85,7 +81,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date sec <- nc$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") - dt <- diy * 24 * 60 * 60 / length(sec) + dt <- PEcAn.utils::seconds_in_year(year) / length(sec) tstep <- round(86400 / dt) dt <- 86400 / tstep diff --git a/modules/data.atmosphere/R/metgapfill.R b/modules/data.atmosphere/R/metgapfill.R index 07d660150bd..47cc67225a8 100644 --- a/modules/data.atmosphere/R/metgapfill.R +++ b/modules/data.atmosphere/R/metgapfill.R @@ -160,8 +160,8 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst ## make night dark - based on met2model.ED2.R in models/ed/R First: calculate potential radiation sec <- nc$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") + dt <- PEcAn.utils::seconds_in_year(year) / length(sec) diy <- PEcAn.utils::days_in_year(year) - dt <- diy * 24 * 60 * 60 / length(sec) doy <- rep(seq_len(diy), each = 86400 / dt) hr <- rep(seq(0, length = 86400 / dt, by = 24 * dt / 86400), diy) From cfaeda04bf0f1377b75d437852121149a2f82588 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 5 Sep 2017 10:21:52 -0400 Subject: [PATCH 538/771] Replace +/- 273.15 with `udunits` T conversions Also, Rstudio removed trailing whitespace from a bunch of files. --- base/utils/R/utils.R | 176 ++++----- base/utils/man/get.parameter.stat.Rd | 5 - base/utils/man/get.run.id.Rd | 2 +- base/utils/man/get.stats.mcmc.Rd | 5 - base/utils/man/listToXml.default.Rd | 2 - base/utils/man/newxtable.Rd | 10 - base/utils/man/paste.stats.Rd | 9 - base/utils/man/ssh.Rd | 7 - base/utils/man/temp.settings.Rd | 3 - base/utils/man/test.remote.Rd | 3 - base/utils/man/trait.lookup.Rd | 4 +- base/utils/man/zero.bounded.density.Rd | 2 - models/sipnet/R/met2model.SIPNET.R | 10 +- modules/data.atmosphere/R/met2CF.ALMA.R | 366 +++++++++--------- modules/data.atmosphere/R/met2CF.Ameriflux.R | 174 ++++----- modules/data.atmosphere/R/metgapfill.R | 26 +- modules/data.atmosphere/R/metutils.R | 32 +- modules/data.atmosphere/man/qair2rh.Rd | 2 +- modules/data.atmosphere/man/sw2par.Rd | 2 +- .../uncertainty/R/run.sensitivity.analysis.R | 70 ++-- .../man/run.sensitivity.analysis.Rd | 2 +- 21 files changed, 438 insertions(+), 474 deletions(-) diff --git a/base/utils/R/utils.R b/base/utils/R/utils.R index c89145f3f7d..b2105787d64 100644 --- a/base/utils/R/utils.R +++ b/base/utils/R/utils.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -30,7 +30,7 @@ mstmipvar <- function(name, lat = NA, lon = NA, time = NA, nsoil = NA, silent = data(mstmip_vars, package = "PEcAn.utils") var <- mstmip_vars[mstmip_vars$Variable.Name == name, ] dims <- list() - + if (nrow(var) == 0) { data(mstmip_local, package = "PEcAn.utils") var <- mstmip_local[mstmip_local$Variable.Name == name, ] @@ -39,13 +39,13 @@ mstmipvar <- function(name, lat = NA, lon = NA, time = NA, nsoil = NA, silent = PEcAn.logger::logger.info("Don't know about variable", name, " in mstmip_vars in PEcAn.utils") } if (is.na(time)) { - time <- ncdf4::ncdim_def(name = "time", units = "days since 1900-01-01 00:00:00", + time <- ncdf4::ncdim_def(name = "time", units = "days since 1900-01-01 00:00:00", vals = 1:365, calendar = "standard", unlim = TRUE) } return(ncdf4::ncvar_def(name, "", list(time), -999, name)) } } - + for (i in 1:4) { vd <- var[[paste0("dim", i)]] if (vd == "lon" && !is.na(lon)) { @@ -75,7 +75,7 @@ mstmipvar <- function(name, lat = NA, lon = NA, time = NA, nsoil = NA, silent = #--------------------------------------------------------------------------------------------------# ##' left padded by zeros up to a given number of digits. ##' -##' returns a string representing a given number +##' returns a string representing a given number ##' @title Left Pad Zeros ##' @export ##' @param num number to be padded (integer) @@ -91,7 +91,7 @@ left.pad.zeros <- function(num, digits = 5) { ##' Truncates vector at 0 ##' @name zero.truncate -##' @title Zero Truncate +##' @title Zero Truncate ##' @param y numeric vector ##' @return numeric vector with all values less than 0 set to 0 ##' @export @@ -106,12 +106,12 @@ zero.truncate <- function(y) { ##' R implementation of rsync ##' ##' rsync is a file copying tool in bash -##' @title rsync +##' @title rsync ##' @param args rsync arguments (see man rsync) -##' @param from source +##' @param from source ##' @param to destination -##' @param pattern file pattern to be matched -##' @return nothing, transfers files as a side effect +##' @param pattern file pattern to be matched +##' @return nothing, transfers files as a side effect ##' @export ##' @author David LeBauer ##' @author Shawn Serbin @@ -126,9 +126,9 @@ rsync <- function(args, from, to, pattern = "") { ##' R implementation of SSH ##' ##' @title SSH -##' @param host -##' @param ... -##' @param args +##' @param host +##' @param ... +##' @param args ##' @export #--------------------------------------------------------------------------------------------------# ssh <- function(host, ..., args = "") { @@ -159,8 +159,8 @@ vecpaste <- function(x) paste(paste0("'", x, "'"), collapse = ",") ##' Provides a consistent method of naming runs; for use in model input files and indices ##' @title Get Run ID ##' @param run.type character, can be any character; currently 'SA' is used for sensitivity analysis, 'ENS' for ensemble run. -##' @param index unique index for different runs, e.g. integer counting members of an -##' ensemble or a quantile used to which a trait has been perturbed for sensitivity analysis +##' @param index unique index for different runs, e.g. integer counting members of an +##' ensemble or a quantile used to which a trait has been perturbed for sensitivity analysis ##' @param trait name of trait being sampled (for sensitivity analysis) ##' @param pft.name name of PFT (value from pfts.names field in database) ##' @return id representing a model run @@ -187,14 +187,14 @@ listToXml <- function(x, ...) { ##' ##' Can convert list or other object to an xml object using xmlNode ##' @title List to XML -##' @param item +##' @param item ##' @param tag xml tag ##' @return xmlNode ##' @export ##' @author David LeBauer, Carl Davidson, Rob Kooper #--------------------------------------------------------------------------------------------------# listToXml.default <- function(item, tag) { - + # just a textnode, or empty node with attributes if (typeof(item) != "list") { if (length(item) > 1) { @@ -207,7 +207,7 @@ listToXml.default <- function(item, tag) { return(XML::xmlNode(tag, item)) } } - + # create the node if (identical(names(item), c("text", ".attrs"))) { # special case a node with text and attributes @@ -221,7 +221,7 @@ listToXml.default <- function(item, tag) { } } } - + # add attributes to node attrs <- item[[".attrs"]] for (name in names(attrs)) { @@ -237,9 +237,9 @@ listToXml.default <- function(item, tag) { ##' Provides a zero bounded density estimate of a parameter. ##' Kernel Density Estimation used by the \code{\link{stats::density}} function will cause problems at the left hand end because it will put some weight on negative values. One useful approach is to transform to logs, estimate the density using KDE, and then transform back. ##' @title Zero Bounded Density -##' @param x +##' @param x ##' @param bw The smoothing bandwidth to be used. See 'bw.nrd' -##' @return data frame with back-transformed log density estimate +##' @return data frame with back-transformed log density estimate ##' @author \href{http://stats.stackexchange.com/q/6588/2750}{Rob Hyndman} ##' @references M. P. Wand, J. S. Marron and D. Ruppert, 1991. Transformations in Density Estimation. Journal of the American Statistical Association. 86(414):343-353 \url{http://www.jstor.org/stable/2290569} zero.bounded.density <- function(x, bw = "SJ", n = 1001) { @@ -261,12 +261,12 @@ zero.bounded.density <- function(x, bw = "SJ", n = 1001) { ##' @export ##' @author David LeBauer summarize.result <- function(result) { - ans1 <- plyr::ddply(result[result$n == 1, ], - plyr::.(citation_id, site_id, trt_id, control, greenhouse, - date, time, cultivar_id, specie_id), - plyr::summarise, n = length(n), - mean = mean(mean), - statname = ifelse(length(n) == 1, "none", "SE"), + ans1 <- plyr::ddply(result[result$n == 1, ], + plyr::.(citation_id, site_id, trt_id, control, greenhouse, + date, time, cultivar_id, specie_id), + plyr::summarise, n = length(n), + mean = mean(mean), + statname = ifelse(length(n) == 1, "none", "SE"), stat = sd(mean) / sqrt(length(n))) ans2 <- result[result$n != 1, colnames(ans1)] return(rbind(ans1, ans2)) @@ -277,8 +277,8 @@ summarize.result <- function(result) { ##' Further summarizes output from summary.mcmc ##' ##' @title Get stats for parameters in MCMC output -##' @param mcmc.summary -##' @param sample.size +##' @param mcmc.summary +##' @param sample.size ##' @return list with summary statistics for parameters in an MCMC chain ##' @author David LeBauer get.stats.mcmc <- function(mcmc.summary, sample.size) { @@ -301,16 +301,16 @@ get.stats.mcmc <- function(mcmc.summary, sample.size) { ##' Used by \code{\link{get.parameter.stat}}. ##' @title Paste Stats ##' @name paste.stats -##' @param mcmc.summary -##' @param median -##' @param lcl -##' @param ucl +##' @param mcmc.summary +##' @param median +##' @param lcl +##' @param ucl ##' @param n ##' @export ##' @author David LeBauer paste.stats <- function(mcmc.summary, median, lcl, ucl, n = 2) { - paste0("$", tabnum(median, n), - "(", tabnum(lcl, n), ",", tabnum(ucl, n), ")", + paste0("$", tabnum(median, n), + "(", tabnum(lcl, n), ",", tabnum(ucl, n), ")", "$") } # paste.stats @@ -319,8 +319,8 @@ paste.stats <- function(mcmc.summary, median, lcl, ucl, n = 2) { ##' Gets statistics for LaTeX - formatted table ##' ##' @title Get Parameter Statistics -##' @param mcmc.summary -##' @param parameter +##' @param mcmc.summary +##' @param parameter ##' @return table with parameter statistics ##' @author David LeBauer ##' @export @@ -328,34 +328,34 @@ paste.stats <- function(mcmc.summary, median, lcl, ucl, n = 2) { ##' \dontrun{get.parameter.stat(mcmc.summaries[[1]], 'beta.o')} get.parameter.stat <- function(mcmc.summary, parameter) { paste.stats(median = mcmc.summary$quantiles[parameter, "50%"], - lcl = mcmc.summary$quantiles[parameter, c("2.5%")], - ucl = mcmc.summary$quantiles[parameter, c("97.5%")], + lcl = mcmc.summary$quantiles[parameter, c("2.5%")], + ucl = mcmc.summary$quantiles[parameter, c("97.5%")], n = 2) } # get.parameter.stat #--------------------------------------------------------------------------------------------------# -##' Calculate mean, variance statistics, and CI from a known distribution +##' Calculate mean, variance statistics, and CI from a known distribution ##' ##' @title Probability Distirbution Function Statistics -##' @param distn name of distribution used by R (beta, f, gamma, lnorm, norm, weibull) -##' @param A first parameter +##' @param distn name of distribution used by R (beta, f, gamma, lnorm, norm, weibull) +##' @param A first parameter ##' @param B second parameter ##' @return list with mean, variance, and 95 CI ##' @author David LeBauer ## in future, perhaps create S3 functions: get.stats.pdf <- pdf.stats pdf.stats <- function(distn, A, B) { distn <- as.character(distn) - mean <- switch(distn, gamma = A/B, lnorm = exp(A + 1/2 * B^2), beta = A/(A + - B), weibull = B * gamma(1 + 1/A), norm = A, f = ifelse(B > 2, B/(B - 2), + mean <- switch(distn, gamma = A/B, lnorm = exp(A + 1/2 * B^2), beta = A/(A + + B), weibull = B * gamma(1 + 1/A), norm = A, f = ifelse(B > 2, B/(B - 2), mean(rf(10000, A, B)))) - var <- switch(distn, gamma = A/B^2, - lnorm = exp(2 * A + B ^ 2) * (exp(B ^ 2) - 1), - beta = A * B/((A + B) ^ 2 * (A + B + 1)), - weibull = B ^ 2 * (gamma(1 + 2 / A) - - gamma(1 + 1 / A) ^ 2), - norm = B ^ 2, f = ifelse(B > 4, - 2 * B^2 * (A + B - 2) / (A * (B - 2) ^ 2 * (B - 4)), + var <- switch(distn, gamma = A/B^2, + lnorm = exp(2 * A + B ^ 2) * (exp(B ^ 2) - 1), + beta = A * B/((A + B) ^ 2 * (A + B + 1)), + weibull = B ^ 2 * (gamma(1 + 2 / A) - + gamma(1 + 1 / A) ^ 2), + norm = B ^ 2, f = ifelse(B > 4, + 2 * B^2 * (A + B - 2) / (A * (B - 2) ^ 2 * (B - 4)), var(rf(1e+05, A, B)))) qci <- get(paste0("q", distn)) ci <- qci(c(0.025, 0.975), A, B) @@ -367,10 +367,10 @@ pdf.stats <- function(distn, A, B) { #--------------------------------------------------------------------------------------------------# -##' Dictionary of terms used to identify traits in ed, filenames, and figures +##' Dictionary of terms used to identify traits in ed, filenames, and figures ##' -##' @return a dataframe with id, the name used by ED and PEcAn database for a parameter; fileid, an abbreviated -##' name used for files; figid, the parameter name written out as best known in english for figures +##' @return a dataframe with id, the name used by ED and PEcAn database for a parameter; fileid, an abbreviated +##' name used for files; figid, the parameter name written out as best known in english for figures ##' and tables. ##' ##' @param traits a vector of trait names, if traits = NULL, all of the traits will be returned. @@ -419,24 +419,26 @@ tabnum <- function(x, n = 3) { #--------------------------------------------------------------------------------------------------# -##' Scale temperature dependent trait from measurement temperature to reference temperature +##' Scale temperature dependent trait from measurement temperature to reference temperature ##' -##' @title Arrhenius scaling +##' @title Arrhenius scaling ##' @param observed.value observed value of temperature dependent trait, e.g. Vcmax, root respiration rate ##' @param old.temp temperature at which measurement was taken or previously scaled to -##' @param new.temp temperature to be scaled to, default = 25 C +##' @param new.temp temperature to be scaled to, default = 25 C ##' @return numeric value at reference temperature ##' @export ##' @author unknown arrhenius.scaling <- function(observed.value, old.temp, new.temp = 25) { - return(observed.value / exp(3000 * (1 / (273.15 + new.temp) - 1 / (273.15 + old.temp)))) + new.temp.K <- udunits2::ud.convert(new.temp, "degC", "K") + old.temp.K <- udunits2::ud.convert(old.temp, "degC", "K") + return(observed.value / exp(3000 * (1 / (new.temp.K) - 1 / (old.temp.K)))) } # arrhenius.scaling #--------------------------------------------------------------------------------------------------# ##' Capitalize a string ##' -##' @title Capitalize a string +##' @title Capitalize a string ##' @param x string ##' @return x, capitalized ##' @author David LeBauer @@ -457,14 +459,14 @@ isFALSE <- function(x) !isTRUE(x) ##' @title newxtable ##' @param x data.frame to be converted to latex table ##' @param environment can be 'table'; 'sidewaystable' if using latex rotating package -##' @param table.placement -##' @param label -##' @param caption -##' @param caption.placement -##' @param align -##' @return Latex version of table, with percentages properly formatted +##' @param table.placement +##' @param label +##' @param caption +##' @param caption.placement +##' @param align +##' @return Latex version of table, with percentages properly formatted ##' @author David LeBauer -newxtable <- function(x, environment = "table", table.placement = "ht", label = NULL, +newxtable <- function(x, environment = "table", table.placement = "ht", label = NULL, caption = NULL, caption.placement = NULL, align = NULL) { print(xtable(x, label = label, caption = caption, align = align), floating.environment = environment, @@ -498,7 +500,7 @@ bibtexify <- function(author, year, title) { ##' This transformation is required for using data in BUGS/JAGS ##' @title as.sequence ##' @param x categorical variable as vector -##' @param na.rm logical: return NA's or replace with max(x) + 1 +##' @param na.rm logical: return NA's or replace with max(x) + 1 ##' @return sequence from 1:length(unique(x)) ##' @export ##' @author David LeBauer @@ -520,8 +522,8 @@ as.sequence <- function(x, na.rm = TRUE) { ##' Test to determine if access to a remote server is available. ##' Can be used to exclude / include tests or to prevent / identify access errors ##' @title Test Remote -##' @param host -##' @return logical - TRUE if remote connection is available +##' @param host +##' @return logical - TRUE if remote connection is available ##' @author Rob Kooper test.remote <- function(host) { return(try(remote.execute.cmd(host, "/bin/true")) == 0) @@ -534,7 +536,7 @@ test.remote <- function(host) { ##' Useful for testing functions that depend on settings file ##' Reference: http://stackoverflow.com/a/12940705/199217 ##' @title temp.settings -##' @param settings.txt +##' @param settings.txt ##' @return character vector written to and read from a temporary file ##' @export ##' @author David LeBauer @@ -548,7 +550,7 @@ temp.settings <- function(settings.txt) { ##' Test if function gives an error -##' +##' ##' adaptation of try that returns a logical value (FALSE if error) ##' @title tryl ##' @param FUN function to be evaluated for error @@ -596,14 +598,14 @@ load.modelpkg <- function(model) { ##' @return val converted values ##' @author Istem Fer, Shawn Serbin misc.convert <- function(x, u1, u2) { - + amC <- PeriodicTable::mass("C") # atomic mass of carbon mmH2O <- sum(PeriodicTable::mass(c("H", "H", "O"))) # molar mass of H2O, g/mol - + if (u1 == "umol C m-2 s-1" & u2 == "kg C m-2 s-1") { - val <- udunits2::ud.convert(x, "ug", "kg") * amC + val <- udunits2::ud.convert(x, "ug", "kg") * amC } else if (u1 == "kg C m-2 s-1" & u2 == "umol C m-2 s-1") { - val <- udunits2::ud.convert(x, "kg", "ug") / amC + val <- udunits2::ud.convert(x, "kg", "ug") / amC } else if (u1 == "mol H2O m-2 s-1" & u2 == "kg H2O m-2 s-1") { val <- udunits2::ud.convert(x, "g", "kg") * mmH2O } else if (u1 == "kg H2O m-2 s-1" & u2 == "mol H2O m-2 s-1") { @@ -616,8 +618,8 @@ misc.convert <- function(x, u1, u2) { u1 <- gsub("gC","g*12",u1) u2 <- gsub("gC","g*12",u2) val <- udunits2::ud.convert(x,u1,u2) - - + + # PEcAn.logger::logger.severe(paste("Unknown units", u1, u2)) } return(val) @@ -632,15 +634,15 @@ misc.convert <- function(x, u1, u2) { ##' @return logical ##' @author Istem Fer, Shawn Serbin misc.are.convertible <- function(u1, u2) { - + # make sure the order of vectors match - units.from <- c("umol C m-2 s-1", "kg C m-2 s-1", - "mol H2O m-2 s-1", "kg H2O m-2 s-1", + units.from <- c("umol C m-2 s-1", "kg C m-2 s-1", + "mol H2O m-2 s-1", "kg H2O m-2 s-1", "Mg ha-1", "kg C m-2") - units.to <- c("kg C m-2 s-1", "umol C m-2 s-1", - "kg H2O m-2 s-1", "mol H2O m-2 s-1", + units.to <- c("kg C m-2 s-1", "umol C m-2 s-1", + "kg H2O m-2 s-1", "mol H2O m-2 s-1", "kg C m-2", "Mg ha-1") - + if(u1 %in% units.from & u2 %in% units.to) { if (which(units.from == u1) == which(units.to == u2)) { return(TRUE) @@ -686,17 +688,17 @@ convert.expr <- function(expression) { ##' @param filename destination file name ##' @param method Method of file retrieval. Can set this using the options(download.ftp.method=[method]) in your Rprofile. ##' example options(download.ftp.method="ncftpget") -##' +##' ##' @examples ##' download.file("http://lib.stat.cmu.edu/datasets/csb/ch11b.txt","~/test.download.txt") -##' +##' ##' @examples ##' \dontrun{ ##' download.file("ftp://ftp.cdc.noaa.gov/Datasets/NARR/monolevel/pres.sfc.2000.nc", "~/pres.sfc.2000.nc") ##' } ##' ##' @export -##' +##' ##' @author Shawn Serbin, Rob Kooper download.file <- function(url, filename, method) { if (startsWith(url, "ftp://")) { @@ -716,5 +718,5 @@ download.file <- function(url, filename, method) { #################################################################################################### -### EOF. End of R script file. +### EOF. End of R script file. #################################################################################################### diff --git a/base/utils/man/get.parameter.stat.Rd b/base/utils/man/get.parameter.stat.Rd index aec26ef7386..68b6c7bc337 100644 --- a/base/utils/man/get.parameter.stat.Rd +++ b/base/utils/man/get.parameter.stat.Rd @@ -6,11 +6,6 @@ \usage{ get.parameter.stat(mcmc.summary, parameter) } -\arguments{ -\item{mcmc.summary}{} - -\item{parameter}{} -} \value{ table with parameter statistics } diff --git a/base/utils/man/get.run.id.Rd b/base/utils/man/get.run.id.Rd index b78efbcb91b..5247043066a 100644 --- a/base/utils/man/get.run.id.Rd +++ b/base/utils/man/get.run.id.Rd @@ -9,7 +9,7 @@ get.run.id(run.type, index, trait = NULL, pft.name = NULL) \arguments{ \item{run.type}{character, can be any character; currently 'SA' is used for sensitivity analysis, 'ENS' for ensemble run.} -\item{index}{unique index for different runs, e.g. integer counting members of an +\item{index}{unique index for different runs, e.g. integer counting members of an ensemble or a quantile used to which a trait has been perturbed for sensitivity analysis} \item{trait}{name of trait being sampled (for sensitivity analysis)} diff --git a/base/utils/man/get.stats.mcmc.Rd b/base/utils/man/get.stats.mcmc.Rd index d7a1f9b8cb2..fc2f83426c0 100644 --- a/base/utils/man/get.stats.mcmc.Rd +++ b/base/utils/man/get.stats.mcmc.Rd @@ -6,11 +6,6 @@ \usage{ get.stats.mcmc(mcmc.summary, sample.size) } -\arguments{ -\item{mcmc.summary}{} - -\item{sample.size}{} -} \value{ list with summary statistics for parameters in an MCMC chain } diff --git a/base/utils/man/listToXml.default.Rd b/base/utils/man/listToXml.default.Rd index 8bfeaf47831..855fb47f31c 100644 --- a/base/utils/man/listToXml.default.Rd +++ b/base/utils/man/listToXml.default.Rd @@ -7,8 +7,6 @@ \method{listToXml}{default}(item, tag) } \arguments{ -\item{item}{} - \item{tag}{xml tag} } \value{ diff --git a/base/utils/man/newxtable.Rd b/base/utils/man/newxtable.Rd index 970332ca1bd..4e769656bcc 100644 --- a/base/utils/man/newxtable.Rd +++ b/base/utils/man/newxtable.Rd @@ -11,16 +11,6 @@ newxtable(x, environment = "table", table.placement = "ht", label = NULL, \item{x}{data.frame to be converted to latex table} \item{environment}{can be 'table'; 'sidewaystable' if using latex rotating package} - -\item{table.placement}{} - -\item{label}{} - -\item{caption}{} - -\item{caption.placement}{} - -\item{align}{} } \value{ Latex version of table, with percentages properly formatted diff --git a/base/utils/man/paste.stats.Rd b/base/utils/man/paste.stats.Rd index c1924f14aff..22116462cd9 100644 --- a/base/utils/man/paste.stats.Rd +++ b/base/utils/man/paste.stats.Rd @@ -6,15 +6,6 @@ \usage{ paste.stats(mcmc.summary, median, lcl, ucl, n = 2) } -\arguments{ -\item{mcmc.summary}{} - -\item{median}{} - -\item{lcl}{} - -\item{ucl}{} -} \description{ A helper function for building a LaTex table. } diff --git a/base/utils/man/ssh.Rd b/base/utils/man/ssh.Rd index 85fb523f525..48e35cd3a8b 100644 --- a/base/utils/man/ssh.Rd +++ b/base/utils/man/ssh.Rd @@ -6,13 +6,6 @@ \usage{ ssh(host, ..., args = "") } -\arguments{ -\item{host}{} - -\item{...}{} - -\item{args}{} -} \description{ R implementation of SSH } diff --git a/base/utils/man/temp.settings.Rd b/base/utils/man/temp.settings.Rd index 1a4596382a7..7490477900b 100644 --- a/base/utils/man/temp.settings.Rd +++ b/base/utils/man/temp.settings.Rd @@ -6,9 +6,6 @@ \usage{ temp.settings(settings.txt) } -\arguments{ -\item{settings.txt}{} -} \value{ character vector written to and read from a temporary file } diff --git a/base/utils/man/test.remote.Rd b/base/utils/man/test.remote.Rd index bc8a5ca8fe3..4ce69126d92 100644 --- a/base/utils/man/test.remote.Rd +++ b/base/utils/man/test.remote.Rd @@ -6,9 +6,6 @@ \usage{ test.remote(host) } -\arguments{ -\item{host}{} -} \value{ logical - TRUE if remote connection is available } diff --git a/base/utils/man/trait.lookup.Rd b/base/utils/man/trait.lookup.Rd index 477bb3b8da9..159670b4923 100644 --- a/base/utils/man/trait.lookup.Rd +++ b/base/utils/man/trait.lookup.Rd @@ -10,8 +10,8 @@ trait.lookup(traits = NULL) \item{traits}{a vector of trait names, if traits = NULL, all of the traits will be returned.} } \value{ -a dataframe with id, the name used by ED and PEcAn database for a parameter; fileid, an abbreviated - name used for files; figid, the parameter name written out as best known in english for figures +a dataframe with id, the name used by ED and PEcAn database for a parameter; fileid, an abbreviated + name used for files; figid, the parameter name written out as best known in english for figures and tables. } \description{ diff --git a/base/utils/man/zero.bounded.density.Rd b/base/utils/man/zero.bounded.density.Rd index 52d0effd8aa..76ae5a3f87e 100644 --- a/base/utils/man/zero.bounded.density.Rd +++ b/base/utils/man/zero.bounded.density.Rd @@ -7,8 +7,6 @@ zero.bounded.density(x, bw = "SJ", n = 1001) } \arguments{ -\item{x}{} - \item{bw}{The smoothing bandwidth to be used. See 'bw.nrd'} } \value{ diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index e250eb10a9a..534a636eee1 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -89,6 +89,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date lat <- ncvar_get(nc, "latitude") lon <- ncvar_get(nc, "longitude") Tair <- ncvar_get(nc, "air_temperature") ## in Kelvin + Tair_C <- udunits2::ud.convert(Tair, "K", "degC") Qair <- ncvar_get(nc, "specific_humidity") #humidity (kg/kg) ws <- try(ncvar_get(nc, "wind_speed")) if (!is.numeric(ws)) { @@ -115,15 +116,16 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date filt <- exp(-(1:length(Tair)) / tau) filt <- (filt / sum(filt)) soilT <- convolve(Tair, filt) - 273.15 + soilT <- udunits2::ud.convert(soilT, "K", "degC") PEcAn.logger::logger.info("soil_temperature absent; soilT approximated from Tair") } else { - soilT <- soilT - 273.15 + soilT <- udunits2::ud.convert(soilT, "K", "degC") } - SVP <- udunits2::ud.convert(get.es(Tair - 273.15), "millibar", "Pa") ## Saturation vapor pressure + SVP <- udunits2::ud.convert(get.es(Tair_C), "millibar", "Pa") ## Saturation vapor pressure VPD <- try(ncvar_get(nc, "water_vapor_saturation_deficit")) ## in Pa if (!is.numeric(VPD)) { - VPD <- SVP * (1 - qair2rh(Qair, Tair - 273.15)) + VPD <- SVP * (1 - qair2rh(Qair, Tair_C)) PEcAn.logger::logger.info("water_vapor_saturation_deficit absent; VPD calculated from Qair, Tair, and SVP (saturation vapor pressure) ") } e_a <- SVP - VPD @@ -186,7 +188,7 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date doy[1:n], hr[1:n], rep(dt / 86400, n), - Tair - 273.15, + Tair_C, soilT, PAR * dt, # mol/m2/hr Rain * dt, # converts from mm/s to mm diff --git a/modules/data.atmosphere/R/met2CF.ALMA.R b/modules/data.atmosphere/R/met2CF.ALMA.R index 6a889846521..6a851ae5472 100644 --- a/modules/data.atmosphere/R/met2CF.ALMA.R +++ b/modules/data.atmosphere/R/met2CF.ALMA.R @@ -1,4 +1,4 @@ -insertPmet <- function(vals, nc2, var2, dim2, units2 = NA, conv = NULL, +insertPmet <- function(vals, nc2, var2, dim2, units2 = NA, conv = NULL, missval = -6999, verbose = FALSE, ...) { vals[vals == -6999 | vals == -9999] <- NA if (!is.null(conv)) { @@ -20,42 +20,42 @@ insertPmet <- function(vals, nc2, var2, dim2, units2 = NA, conv = NULL, ##' @param start_date the start date of the data to be downloaded (will only use the year part of the date) ##' @param end_date the end date of the data to be downloaded (will only use the year part of the date) ##' @param overwrite should existing files be overwritten -##' +##' ##' @author Mike Dietze ##' @importFrom ncdf4 ncvar_get ncdim_def ncatt_get ncvar_add ncvar_put -met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, +met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { - + # get start/end year code works on whole years only start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - + if (!file.exists(outfolder)) { dir.create(outfolder) } - + ## check file organization by.folder <- list.dirs(in.path, recursive = FALSE, full.names = FALSE) if (length(by.folder) == 0) { PEcAn.logger::logger.severe("met2CF.PalEON, could not detect input folders", in.path) } - + rows <- end_year - start_year + 1 results <- data.frame(file = character(rows), host = character(rows), - mimetype = character(rows), - formatname = character(rows), - startdate = character(rows), - enddate = character(rows), - dbfile.name = in.prefix, + mimetype = character(rows), + formatname = character(rows), + startdate = character(rows), + enddate = character(rows), + dbfile.name = in.prefix, stringsAsFactors = FALSE) for (year in start_year:end_year) { my.prefix <- in.prefix if (nchar(my.prefix) > 0) { my.prefix <- paste0(my.prefix, ".") - } + } new.file <- file.path(outfolder, sprintf("%s%04d.nc", my.prefix, year)) - + row <- year - start_year + 1 results$file[row] <- new.file results$host[row] <- PEcAn.utils::fqdn() @@ -63,22 +63,22 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" results$formatname[row] <- "CF" - + if (file.exists(new.file) && !overwrite) { PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping to next file.") next } - + ### ASSUMING PALEON ORGANIZATION ONE FILE PER VARIABLE PER MONTH EACH VARIABLE IN A FOLDER WITH IT'S ### OWN NAME - + met <- list() for (i in seq_along(by.folder)) { met[[i]] <- NA } names(met) <- by.folder met[["time"]] <- NA - + for (v in by.folder) { fnames <- dir(file.path(in.path, v), full.names = TRUE) for (m in 1:12) { @@ -89,7 +89,7 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end } old.file <- fnames[sel] nc1 <- ncdf4::nc_open(old.file, write = FALSE) - + if (length(met[[v]]) <= 1) { met[[v]] <- aperm(ncdf4::ncvar_get(nc = nc1, varid = v),c(2,1,3)) ## switch order from lon/lat/time to lat/lon/time } else { @@ -107,7 +107,7 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end ncdf4::nc_close(nc1) } ## end loop over months } ## end loop over variables - + # create new coordinate dimensions based on site location lat/lon nc1 <- ncdf4::nc_open(old.file) tdim <- nc1$dim[["time"]] @@ -117,56 +117,56 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end tdim$len <- length(tdim$vals) lat <- ncdf4::ncdim_def(name = "latitude", units = "degrees", vals = nc1$dim[["lat"]]$vals, create_dimvar = TRUE) lon <- ncdf4::ncdim_def(name = "longitude", units = "degrees", vals = nc1$dim[["lon"]]$vals, create_dimvar = TRUE) - time <- ncdf4::ncdim_def(name = "time", units = tdim$units, vals = tdim$vals, + time <- ncdf4::ncdim_def(name = "time", units = tdim$units, vals = tdim$vals, create_dimvar = TRUE, unlim = TRUE) dim <- list(lat, lon, time) cp.global.atts <- ncdf4::ncatt_get(nc = nc1, varid = 0) ncdf4::nc_close(nc1) - + # Open new file and fill in air_temperature print(year) - var <- ncdf4::ncvar_def(name = "air_temperature", units = "degrees K", dim = dim, + var <- ncdf4::ncvar_def(name = "air_temperature", units = "degrees K", dim = dim, missval = as.numeric(-9999)) nc2 <- ncdf4::nc_create(filename = new.file, vars = var, verbose = verbose) ncdf4::ncvar_put(nc = nc2, varid = "air_temperature", vals = met[["tair"]]) - + # air_pressure - insertPmet(met[["psurf"]], nc2 = nc2, var2 = "air_pressure", units2 = "Pa", dim2 = dim, + insertPmet(met[["psurf"]], nc2 = nc2, var2 = "air_pressure", units2 = "Pa", dim2 = dim, verbose = verbose) - - # convert CO2 to mole_fraction_of_carbon_dioxide_in_air + + # convert CO2 to mole_fraction_of_carbon_dioxide_in_air # insertPmet(nc1=nc1, var1='CO2', nc2=nc2, var2='mole_fraction_of_carbon_dioxide_in_air', units2='mole/mole', dim2=dim, conv=function(x) { # x * 1e6 }, verbose=verbose) - + # specific_humidity - insertPmet(met[["qair"]], nc2 = nc2, var2 = "specific_humidity", units2 = "kg/kg", dim2 = dim, + insertPmet(met[["qair"]], nc2 = nc2, var2 = "specific_humidity", units2 = "kg/kg", dim2 = dim, verbose = verbose) - + # surface_downwelling_shortwave_flux_in_air - insertPmet(met[["swdown"]], nc2 = nc2, var2 = "surface_downwelling_shortwave_flux_in_air", + insertPmet(met[["swdown"]], nc2 = nc2, var2 = "surface_downwelling_shortwave_flux_in_air", units2 = "W m-2", dim2 = dim, verbose = verbose) - + # surface_downwelling_longwave_flux_in_air - insertPmet(met[["lwdown"]], nc2 = nc2, var2 = "surface_downwelling_longwave_flux_in_air", + insertPmet(met[["lwdown"]], nc2 = nc2, var2 = "surface_downwelling_longwave_flux_in_air", units2 = "W m-2", dim2 = dim, verbose = verbose) - + # wind_speed insertPmet(met[["wind"]], nc2 = nc2, var2 = "wind_speed", units2 = "m s-1", dim2 = dim, verbose = verbose) - + # precipitation_flux - insertPmet(met[["precipf"]], nc2 = nc2, var2 = "precipitation_flux", units2 = "kg/m^2/s", + insertPmet(met[["precipf"]], nc2 = nc2, var2 = "precipitation_flux", units2 = "kg/m^2/s", dim2 = dim, verbose = verbose) - + # add global attributes from original file for (j in seq_along(cp.global.atts)) { ncdf4::ncatt_put(nc = nc2, varid = 0, attname = names(cp.global.atts)[j], attval = cp.global.atts[[j]]) } - + # done, close file ncdf4::nc_close(nc2) # save(results,file="met2CF.PalEON.RData") } ## end loop over years - + return(invisible(results)) } # met2CF.PalEONregional @@ -182,46 +182,46 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end ##' @param start_date the start date of the data to be downloaded (will only use the year part of the date) ##' @param end_date the end date of the data to be downloaded (will only use the year part of the date) ##' @param overwrite should existing files be overwritten -##' +##' ##' @author Mike Dietze ##' @importFrom ncdf4 ncvar_get ncdim_def ncatt_get ncvar_add ncvar_put -met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, lat, lon, overwrite = FALSE, +met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, lat, lon, overwrite = FALSE, verbose = FALSE, ...) { - + #---------------- Load libraries. -----------------------------------------------------------------# library(PEcAn.utils) - #--------------------------------------------------------------------------------------------------# - + #--------------------------------------------------------------------------------------------------# + # get start/end year code works on whole years only start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - + if (!file.exists(outfolder)) { dir.create(outfolder) } - + ## check file organization by.folder <- list.dirs(in.path, recursive = FALSE, full.names = FALSE) if (length(by.folder) == 0) { PEcAn.logger::logger.severe("met2CF.PalEON, could not detect input folders", in.path) } - + rows <- end_year - start_year + 1 results <- data.frame(file = character(rows), host = character(rows), - mimetype = character(rows), - formatname = character(rows), - startdate = character(rows), - enddate = character(rows), - dbfile.name = in.prefix, + mimetype = character(rows), + formatname = character(rows), + startdate = character(rows), + enddate = character(rows), + dbfile.name = in.prefix, stringsAsFactors = FALSE) for (year in start_year:end_year) { my.prefix <- in.prefix if (nchar(my.prefix) > 0) { my.prefix <- paste0(my.prefix, ".") - } + } new.file <- file.path(outfolder, sprintf("%s%04d.nc", my.prefix, year)) - + row <- year - start_year + 1 results$file[row] <- new.file results$host[row] <- PEcAn.utils::fqdn() @@ -229,22 +229,22 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" results$formatname[row] <- "CF" - + if (file.exists(new.file) && !overwrite) { PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping to next file.") next } - + ### ASSUMING PALEON ORGANIZATION ONE FILE PER VARIABLE PER MONTH EACH VARIABLE IN A FOLDER WITH IT'S ### OWN NAME - + met <- list() for (i in seq_along(by.folder)) { met[[i]] <- NA } names(met) <- by.folder met[["time"]] <- NA - + for (v in by.folder) { fnames <- dir(file.path(in.path, v), full.names = TRUE) for (m in 1:12) { @@ -272,7 +272,7 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l ncdf4::nc_close(nc1) } ## end loop over months } ## end loop over variables - + # create new coordinate dimensions based on site location lat/lon nc1 <- ncdf4::nc_open(old.file) tdim <- nc1$dim[["time"]] @@ -284,65 +284,65 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l latlon[2] <- lon # nc1$dim$lon$vals lat <- ncdim_def(name = "latitude", units = "", vals = 1:1, create_dimvar = FALSE) lon <- ncdim_def(name = "longitude", units = "", vals = 1:1, create_dimvar = FALSE) - time <- ncdim_def(name = "time", units = tdim$units, vals = tdim$vals, + time <- ncdim_def(name = "time", units = tdim$units, vals = tdim$vals, create_dimvar = TRUE, unlim = TRUE) dim <- list(lat, lon, time) cp.global.atts <- ncatt_get(nc = nc1, varid = 0) ncdf4::nc_close(nc1) - + # Open new file and copy lat attribute to latitude print(c(latlon, year)) - var <- ncdf4::ncvar_def(name = "latitude", units = "degree_north", dim = (list(lat, lon, time)), + var <- ncdf4::ncvar_def(name = "latitude", units = "degree_north", dim = (list(lat, lon, time)), missval = as.numeric(-9999)) nc2 <- ncdf4::nc_create(filename = new.file, vars = var, verbose = verbose) ncvar_put(nc = nc2, varid = "latitude", vals = rep(latlon[1], tdim$len)) - + # copy lon attribute to longitude - var <- ncdf4::ncvar_def(name = "longitude", units = "degree_east", dim = (list(lat, lon, time)), + var <- ncdf4::ncvar_def(name = "longitude", units = "degree_east", dim = (list(lat, lon, time)), missval = as.numeric(-9999)) nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) ncvar_put(nc = nc2, varid = "longitude", vals = rep(latlon[2], tdim$len)) - + # air_temperature - insertPmet(met[["tair"]], nc2 = nc2, var2 = "air_temperature", units2 = "degrees K", dim2 = dim, + insertPmet(met[["tair"]], nc2 = nc2, var2 = "air_temperature", units2 = "degrees K", dim2 = dim, verbose = verbose) - + # air_pressure - insertPmet(met[["psurf"]], nc2 = nc2, var2 = "air_pressure", units2 = "Pa", dim2 = dim, + insertPmet(met[["psurf"]], nc2 = nc2, var2 = "air_pressure", units2 = "Pa", dim2 = dim, verbose = verbose) - - # convert CO2 to mole_fraction_of_carbon_dioxide_in_air + + # convert CO2 to mole_fraction_of_carbon_dioxide_in_air # insertPmet(nc1=nc1, var1='CO2', nc2=nc2, var2='mole_fraction_of_carbon_dioxide_in_air', units2='mole/mole', dim2=dim, conv=function(x) { # x * 1e6 }, verbose=verbose) - + # specific_humidity - insertPmet(met[["qair"]], nc2 = nc2, var2 = "specific_humidity", units2 = "kg/kg", dim2 = dim, + insertPmet(met[["qair"]], nc2 = nc2, var2 = "specific_humidity", units2 = "kg/kg", dim2 = dim, verbose = verbose) - + # surface_downwelling_shortwave_flux_in_air - insertPmet(met[["swdown"]], nc2 = nc2, var2 = "surface_downwelling_shortwave_flux_in_air", + insertPmet(met[["swdown"]], nc2 = nc2, var2 = "surface_downwelling_shortwave_flux_in_air", units2 = "W m-2", dim2 = dim, verbose = verbose) - + # surface_downwelling_longwave_flux_in_air - insertPmet(met[["lwdown"]], nc2 = nc2, var2 = "surface_downwelling_longwave_flux_in_air", + insertPmet(met[["lwdown"]], nc2 = nc2, var2 = "surface_downwelling_longwave_flux_in_air", units2 = "W m-2", dim2 = dim, verbose = verbose) - + # wind_speed insertPmet(met[["wind"]], nc2 = nc2, var2 = "wind_speed", units2 = "m s-1", dim2 = dim, verbose = verbose) - + # precipitation_flux - insertPmet(met[["precipf"]], nc2 = nc2, var2 = "precipitation_flux", units2 = "kg/m^2/s", + insertPmet(met[["precipf"]], nc2 = nc2, var2 = "precipitation_flux", units2 = "kg/m^2/s", dim2 = dim, verbose = verbose) - + # add global attributes from original file for (j in seq_along(cp.global.atts)) { ncatt_put(nc = nc2, varid = 0, attname = names(cp.global.atts)[j], attval = cp.global.atts[[j]]) } - + # done, close file ncdf4::nc_close(nc2) } ## end loop over years - + return(invisible(results)) } # met2CF.PalEON @@ -358,7 +358,7 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l ##' @param start_date the start date of the data to be downloaded (will only use the year part of the date) ##' @param end_date the end date of the data to be downloaded (will only use the year part of the date) ##' @param overwrite should existing files be overwritten -##' +##' ##' @author Mike Dietze ##' @importFrom ncdf4 ncvar_get ncdim_def ncatt_get ncvar_add ncvar_put met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE) { @@ -366,11 +366,11 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove # get start/end year code works on whole years only start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - + if (!file.exists(outfolder)) { dir.create(outfolder) } - + ## check file organization by.file <- dir(in.path, pattern = ".nc") if (length(by.file) == 0) { @@ -382,19 +382,19 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove } else { by.file <- TRUE } - + rows <- end_year - start_year + 1 results <- data.frame(file = character(rows), host = character(rows), - mimetype = character(rows), + mimetype = character(rows), formatname = character(rows), startdate = character(rows), - enddate = character(rows), - dbfile.name = in.prefix, + enddate = character(rows), + dbfile.name = in.prefix, stringsAsFactors = FALSE) for (year in start_year:end_year) { new.file <- file.path(outfolder, paste(in.prefix, year, "nc", sep = ".")) - + row <- year - start_year + 1 results$file[row] <- new.file results$host[row] <- PEcAn.utils::fqdn() @@ -402,37 +402,37 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" results$formatname[row] <- "CF" - + if (file.exists(new.file) && !overwrite) { PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping to next file.") next } - + # create array with results if (by.file) { old.file <- file.path(in.path, paste(in.prefix, year, "nc", sep = ".")) - + # open original annual file nc1 <- ncdf4::nc_open(old.file, write = TRUE) - + # get dimension and site info tdim <- nc1$dim[["DTIME"]] - + ### LOTS MORE TO DO TO IMPLEMENT - + ncdf4::nc_close(nc1) } else { - - ### ASSUMING PALEON ORGANIZATION ONE FILE PER VARIABLE PER MONTH EACH VARIABLE + + ### ASSUMING PALEON ORGANIZATION ONE FILE PER VARIABLE PER MONTH EACH VARIABLE ### IN A FOLDER WITH ITS OWN NAME - + met <- list() for (i in seq_along(by.folder)) { met[[i]] <- NA } names(met) <- by.folder met[["time"]] <- NA - + for (v in by.folder) { fnames <- dir(file.path(in.path, v), full.names = TRUE) for (m in 1:12) { @@ -457,7 +457,7 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove } } } - + # create new coordinate dimensions based on site location lat/lon nc1 <- ncdf4::nc_open(old.file) tdim <- nc1$dim[["time"]] @@ -465,145 +465,145 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove latlon[2] <- nc1$dim$lon$vals lat <- ncdim_def(name = "latitude", units = "", vals = 1:1, create_dimvar = FALSE) lon <- ncdim_def(name = "longitude", units = "", vals = 1:1, create_dimvar = FALSE) - time <- ncdim_def(name = "time", units = tdim$units, vals = met[["time"]], + time <- ncdim_def(name = "time", units = tdim$units, vals = met[["time"]], create_dimvar = TRUE, unlim = TRUE) dim <- list(lat, lon, time) - + # copy lat attribute to latitude print(latlon) - var <- ncdf4::ncvar_def(name = "latitude", units = "degree_north", dim = (list(lat, lon, time)), + var <- ncdf4::ncvar_def(name = "latitude", units = "degree_north", dim = (list(lat, lon, time)), missval = as.numeric(-9999)) nc2 <- nc_create(filename = new.file, vars = var, verbose = verbose) ncvar_put(nc = nc2, varid = "latitude", vals = rep(latlon[1], tdim$len)) - + # copy lon attribute to longitude - var <- ncdf4::ncvar_def(name = "longitude", units = "degree_east", dim = (list(lat, lon, time)), + var <- ncdf4::ncvar_def(name = "longitude", units = "degree_east", dim = (list(lat, lon, time)), missval = as.numeric(-9999)) nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) ncvar_put(nc = nc2, varid = "longitude", vals = rep(latlon[2], tdim$len)) - + # Convert all variables # This will include conversions or computations to create values from - # original file. In case of conversions the steps will pretty much always be: - # a) get values from original file - # b) set -6999 and -9999 to NA - # c) do unit conversions - # d) create output variable + # original file. In case of conversions the steps will pretty much always be: + # a) get values from original file + # b) set -6999 and -9999 to NA + # c) do unit conversions + # d) create output variable # e) write results to new file - + # convert TA to air_temperature copyvals(nc1 = nc1, - var1 = "TA", - nc2 = nc2, - var2 = "air_temperature", units2 = "degrees K", - dim2 = dim, - conv = function(x) { x + 273.15 }, + var1 = "TA", + nc2 = nc2, + var2 = "air_temperature", units2 = "degrees K", + dim2 = dim, + conv = function(x) { udunits2::ud.convert(x, "degC", "K") }, verbose = verbose) - + # convert PRESS to air_pressure - copyvals(nc1 = nc1, - var1 = "PRESS", - nc2 = nc2, - var2 = "air_pressure", units2 = "Pa", - dim2 = dim, - conv = function(x) { x * 1000 }, + copyvals(nc1 = nc1, + var1 = "PRESS", + nc2 = nc2, + var2 = "air_pressure", units2 = "Pa", + dim2 = dim, + conv = function(x) { x * 1000 }, verbose = verbose) - + # convert CO2 to mole_fraction_of_carbon_dioxide_in_air - copyvals(nc1 = nc1, + copyvals(nc1 = nc1, var1 = "CO2", nc2 = nc2, var2 = "mole_fraction_of_carbon_dioxide_in_air", units2 = "mole/mole", - dim2 = dim, conv = function(x) { x * 1e+06 }, + dim2 = dim, conv = function(x) { x * 1e+06 }, verbose = verbose) - + # convert TS1 to soil_temperature copyvals(nc1 = nc1, - var1 = "TS1", - nc2 = nc2, - var2 = "soil_temperature", units2 = "degrees K", - dim2 = dim, - conv = function(x) { x + 273.15 }, + var1 = "TS1", + nc2 = nc2, + var2 = "soil_temperature", units2 = "degrees K", + dim2 = dim, + conv = function(x) { udunits2::ud.convert(x, "degC", "K") }, verbose = verbose) - + # copy RH to relative_humidity - copyvals(nc1 = nc1, - var1 = "RH", - nc2 = nc2, - var2 = "relative_humidity", dim2 = dim, + copyvals(nc1 = nc1, + var1 = "RH", + nc2 = nc2, + var2 = "relative_humidity", dim2 = dim, verbose = verbose) - + # convert RH to SH rh <- ncvar_get(nc = nc1, varid = "RH") rh[rh == -6999 | rh == -9999] <- NA rh <- rh/100 ta <- ncvar_get(nc = nc1, varid = "TA") ta[ta == -6999 | ta == -9999] <- NA - ta <- ta + 273.15 + ta <- udunits2::ud.convert(ta, "degC", "K") sh <- rh2qair(rh = rh, T = ta) - var <- ncdf4::ncvar_def(name = "specific_humidity", units = "kg/kg", dim = dim, missval = -6999, + var <- ncdf4::ncvar_def(name = "specific_humidity", units = "kg/kg", dim = dim, missval = -6999, verbose = verbose) nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) ncvar_put(nc = nc2, varid = "specific_humidity", vals = sh) - - # convert VPD to water_vapor_saturation_deficit + + # convert VPD to water_vapor_saturation_deficit # HACK : conversion will make all values < 0 to be NA - copyvals(nc1 = nc1, - var1 = "VPD", - nc2 = nc2, - var2 = "water_vapor_saturation_deficit", units2 = "mol m-2 s-1", - dim2 = dim, - conv = function(x) { ifelse(x < 0, NA, x * 1000) }, + copyvals(nc1 = nc1, + var1 = "VPD", + nc2 = nc2, + var2 = "water_vapor_saturation_deficit", units2 = "mol m-2 s-1", + dim2 = dim, + conv = function(x) { ifelse(x < 0, NA, x * 1000) }, verbose = verbose) - + # copy Rg to surface_downwelling_shortwave_flux_in_air - copyvals(nc1 = nc1, - var1 = "Rg", - nc2 = nc2, + copyvals(nc1 = nc1, + var1 = "Rg", + nc2 = nc2, var2 = "surface_downwelling_shortwave_flux_in_air", dim2 = dim, verbose = verbose) - + # copy Rgl to surface_downwelling_longwave_flux_in_air - copyvals(nc1 = nc1, + copyvals(nc1 = nc1, var1 = "Rgl", - nc2 = nc2, - var2 = "surface_downwelling_longwave_flux_in_air", dim2 = dim, + nc2 = nc2, + var2 = "surface_downwelling_longwave_flux_in_air", dim2 = dim, verbose = verbose) - + # convert PAR to surface_downwelling_photosynthetic_photon_flux_in_air - copyvals(nc1 = nc1, + copyvals(nc1 = nc1, var1 = "PAR", - nc2 = nc2, - var2 = "surface_downwelling_photosynthetic_photon_flux_in_air", units2 = "mol m-2 s-1", - dim2 = dim, + nc2 = nc2, + var2 = "surface_downwelling_photosynthetic_photon_flux_in_air", units2 = "mol m-2 s-1", + dim2 = dim, conv = function(x) { x / 1e+06 }, verbose = verbose) - + # copy WD to wind_direction (not official CF) - copyvals(nc1 = nc1, - var1 = "WD", - nc2 = nc2, - var2 = "wind_direction", dim2 = dim, + copyvals(nc1 = nc1, + var1 = "WD", + nc2 = nc2, + var2 = "wind_direction", dim2 = dim, verbose = verbose) - + # copy WS to wind_speed - copyvals(nc1 = nc1, + copyvals(nc1 = nc1, var1 = "WS", - nc2 = nc2, - var2 = "wind_speed", dim2 = dim, + nc2 = nc2, + var2 = "wind_speed", dim2 = dim, verbose = verbose) - + # convert PREC to precipitation_flux t <- tdim$vals min <- 0.02083 / 30 # 0.02083 time = 30 minutes timestep <- round(x = mean(diff(t)) / min, digits = 1) # round to nearest 0.1 minute - copyvals(nc1 = nc1, - var1 = "PREC", - nc2 = nc2, - var2 = "precipitation_flux", units2 = "kg/m^2/s", + copyvals(nc1 = nc1, + var1 = "PREC", + nc2 = nc2, + var2 = "precipitation_flux", units2 = "kg/m^2/s", dim2 = dim, conv = function(x) { x / timestep / 60 }, verbose = verbose) - + # convert wind speed and wind direction to eastward_wind and northward_wind wd <- ncvar_get(nc = nc1, varid = "WD") #wind direction wd[wd == -6999 | wd == -9999] <- NA @@ -612,29 +612,29 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove ew <- ws * cos(wd * (pi / 180)) nw <- ws * sin(wd * (pi / 180)) max <- ncatt_get(nc = nc1, varid = "WS", "valid_max")$value - + var <- ncdf4::ncvar_def(name = "eastward_wind", units = "m/s", dim = dim, missval = -6999, verbose = verbose) nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) ncvar_put(nc = nc2, varid = "eastward_wind", vals = ew) ncatt_put(nc = nc2, varid = "eastward_wind", attname = "valid_min", attval = -max) ncatt_put(nc = nc2, varid = "eastward_wind", attname = "valid_max", attval = max) - + var <- ncdf4::ncvar_def(name = "northward_wind", units = "m/s", dim = dim, missval = -6999, verbose = verbose) nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) ncvar_put(nc = nc2, varid = "northward_wind", vals = nw) ncatt_put(nc = nc2, varid = "northward_wind", attname = "valid_min", attval = -max) ncatt_put(nc = nc2, varid = "northward_wind", attname = "valid_max", attval = max) - + # add global attributes from original file cp.global.atts <- ncatt_get(nc = nc1, varid = 0) for (j in seq_along(cp.global.atts)) { ncatt_put(nc = nc2, varid = 0, attname = names(cp.global.atts)[j], attval = cp.global.atts[[j]]) } - + # done, close both files ncdf4::nc_close(nc1) ncdf4::nc_close(nc2) } ## end loop over years - + return(invisible(results)) } # met2CF.ALMA diff --git a/modules/data.atmosphere/R/met2CF.Ameriflux.R b/modules/data.atmosphere/R/met2CF.Ameriflux.R index 3e15983e62e..82b3ffb3337 100644 --- a/modules/data.atmosphere/R/met2CF.Ameriflux.R +++ b/modules/data.atmosphere/R/met2CF.Ameriflux.R @@ -1,14 +1,14 @@ # helper function to copy variables and attributes from one nc file to another. This will do # conversion of the variables as well as on the min/max values copyvals <- function(nc1, var1, nc2, var2, dim2, units2 = NA, conv = NULL, missval = -6999, verbose = FALSE) { - + ncvar_get <- ncdf4::ncvar_get ncatt_get <- ncdf4::ncatt_get ncvar_add <- ncdf4::ncvar_add ncvar_def <- ncdf4::ncvar_def ncatt_put <- ncdf4::ncatt_put ncvar_put <- ncdf4::ncvar_put - + vals <- ncvar_get(nc = nc1, varid = var1) vals[vals == -6999 | vals == -9999] <- NA if (!is.null(conv)) { @@ -20,26 +20,26 @@ copyvals <- function(nc1, var1, nc2, var2, dim2, units2 = NA, conv = NULL, missv var <- ncvar_def(name = var2, units = units2, dim = dim2, missval = missval, verbose = verbose) nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) ncvar_put(nc = nc2, varid = var2, vals = vals) - + # copy and convert attributes att <- ncatt_get(nc1, var1, "long_name") if (att$hasatt) { val <- att$value ncatt_put(nc = nc2, varid = var2, attname = "long_name", attval = val) } - + att <- ncatt_get(nc1, var1, "valid_min") if (att$hasatt) { val <- ifelse(is.null(conv), att$value, conv(att$value)) ncatt_put(nc = nc2, varid = var2, attname = "valid_min", attval = val) } - + att <- ncatt_get(nc1, var1, "valid_max") if (att$hasatt) { val <- ifelse(is.null(conv), att$value, conv(att$value)) ncatt_put(nc = nc2, varid = var2, attname = "valid_max", attval = val) } - + att <- ncatt_get(nc1, var1, "comment") if (att$hasatt) { val <- sub(", -9999.* = missing value, -6999.* = unreported value", "", att$value) @@ -49,7 +49,7 @@ copyvals <- function(nc1, var1, nc2, var2, dim2, units2 = NA, conv = NULL, missv getLatLon <- function(nc1) { ncatt_get <- ncdf4::ncatt_get - + loc <- ncatt_get(nc = nc1, varid = 0, attname = "site_location") if (loc$hasatt) { lat <- as.numeric(substr(loc$value, 20, 28)) @@ -78,38 +78,38 @@ getLatLon <- function(nc1) { ##' @param end_date the end date of the data to be downloaded (will only use the year part of the date) ##' @param overwrite should existing files be overwritten ##' @param verbose should ouput of function be extra verbose -##' +##' ##' @author Josh Mantooth, Mike Dietze, Elizabeth Cowdery, Ankur Desai ##' @importFrom ncdf4 ncvar_get ncatt_get ncdim_def ncvar_def ncvar_add ncvar_put ncatt_put met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { - + #---------------- Load libraries. -----------------------------------------------------------------# library(PEcAn.utils) library(geonames) ## has to be loaded as a library - #--------------------------------------------------------------------------------------------------# - + #--------------------------------------------------------------------------------------------------# + # get start/end year code works on whole years only start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - + if (!file.exists(outfolder)) { dir.create(outfolder) } - + rows <- end_year - start_year + 1 results <- data.frame(file = character(rows), - host = character(rows), - mimetype = character(rows), + host = character(rows), + mimetype = character(rows), formatname = character(rows), - startdate = character(rows), - enddate = character(rows), - dbfile.name = in.prefix, + startdate = character(rows), + enddate = character(rows), + dbfile.name = in.prefix, stringsAsFactors = FALSE) for (year in start_year:end_year) { old.file <- file.path(in.path, paste(in.prefix, year, "nc", sep = ".")) new.file <- file.path(outfolder, paste(in.prefix, year, "nc", sep = ".")) - + # create array with results row <- year - start_year + 1 results$file[row] <- new.file @@ -118,21 +118,21 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date results$enddate[row] <- paste0(year, "-12-31 23:59:59") results$mimetype[row] <- "application/x-netcdf" results$formatname[row] <- "CF" - + if (file.exists(new.file) && !overwrite) { PEcAn.logger::logger.debug("File '", new.file, "' already exists, skipping to next file.") next } - + # open raw ameriflux nc1 <- ncdf4::nc_open(old.file, write = TRUE) - + # get dimension and site info tdim <- nc1$dim[["DTIME"]] - + # create new coordinate dimensions based on site location lat/lon latlon <- getLatLon(nc1) - + # Ameriflux L2 files are in 'local time' - figure this out and add to time units attribute Check # if timezone is already in time units, if not, figure it out from lat/lon and add it in tdimunit <- unlist(strsplit(tdim$units, " ")) @@ -149,124 +149,124 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date } tdim$units <- paste(tdim$units, lststr, sep = " ") } - + lat <- ncdim_def(name = "latitude", units = "", vals = 1:1, create_dimvar = FALSE) lon <- ncdim_def(name = "longitude", units = "", vals = 1:1, create_dimvar = FALSE) time <- ncdim_def(name = "time", units = tdim$units, vals = tdim$vals, create_dimvar = TRUE, unlim = TRUE) dim <- list(lat, lon, time) - + # copy lat attribute to latitude var <- ncvar_def(name = "latitude", units = "degree_north", dim = list(lat, lon), missval = as.numeric(-9999)) nc2 <- ncdf4::nc_create(filename = new.file, vars = var, verbose = verbose) ncvar_put(nc = nc2, varid = "latitude", vals = latlon[1]) - + # copy lon attribute to longitude var <- ncvar_def(name = "longitude", units = "degree_east", dim = list(lat, lon), missval = as.numeric(-9999)) nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) ncvar_put(nc = nc2, varid = "longitude", vals = latlon[2]) - + # Convert all variables - # This will include conversions or computations to create values from original file. - # In case of conversions the steps will pretty much always be: - # a) get values from original file - # b) set -6999 and -9999 to NA - # c) do unit conversions - # d) create output variable + # This will include conversions or computations to create values from original file. + # In case of conversions the steps will pretty much always be: + # a) get values from original file + # b) set -6999 and -9999 to NA + # c) do unit conversions + # d) create output variable # e) write results to new file - - # convert RH to SH + + # convert RH to SH # this conversion needs to come before others to reinitialize dimension used by copyvals (lat/lon/time) rh <- ncvar_get(nc = nc1, varid = "RH") rh[rh == -6999 | rh == -9999] <- NA rh <- rh/100 ta <- ncvar_get(nc = nc1, varid = "TA") ta[ta == -6999 | ta == -9999] <- NA - ta <- ta + 273.15 + ta <- udunits2::ud.convert(ta, "degC", "K") sh <- rh2qair(rh = rh, T = ta) - var <- ncvar_def(name = "specific_humidity", units = "kg/kg", dim = dim, + var <- ncvar_def(name = "specific_humidity", units = "kg/kg", dim = dim, missval = -6999, verbose = verbose) nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) ncvar_put(nc = nc2, varid = "specific_humidity", vals = sh) - + # convert TA to air_temperature - copyvals(nc1 = nc1, var1 = "TA", nc2 = nc2, - var2 = "air_temperature", units2 = "degrees K", - dim2 = dim, conv = function(x) { x + 273.15 }, + copyvals(nc1 = nc1, var1 = "TA", nc2 = nc2, + var2 = "air_temperature", units2 = "degrees K", + dim2 = dim, conv = function(x) { udunits2::ud.convert(x, "degC", "K") }, verbose = verbose) - + # convert PRESS to air_pressure copyvals(nc1 = nc1, var1 = "PRESS", nc2 = nc2, - var2 = "air_pressure", units2 = "Pa", - dim2 = dim, - conv = function(x) { x * 1000 }, + var2 = "air_pressure", units2 = "Pa", + dim2 = dim, + conv = function(x) { x * 1000 }, verbose = verbose) - + # convert CO2 to mole_fraction_of_carbon_dioxide_in_air - copyvals(nc1 = nc1, var1 = "CO2", nc2 = nc2, - var2 = "mole_fraction_of_carbon_dioxide_in_air", - units2 = "mole/mole", - dim2 = dim, conv = function(x) { x / 1e+06 }, + copyvals(nc1 = nc1, var1 = "CO2", nc2 = nc2, + var2 = "mole_fraction_of_carbon_dioxide_in_air", + units2 = "mole/mole", + dim2 = dim, conv = function(x) { x / 1e+06 }, verbose = verbose) - + # convert TS1 to soil_temperature - copyvals(nc1 = nc1, var1 = "TS1", nc2 = nc2, - var2 = "soil_temperature", units2 = "degrees K", - dim2 = dim, - conv = function(x) { x + 273.15 }, + copyvals(nc1 = nc1, var1 = "TS1", nc2 = nc2, + var2 = "soil_temperature", units2 = "degrees K", + dim2 = dim, + conv = function(x) { udunits2::ud.convert(x, "degC", "K") }, verbose = verbose) - + # copy RH to relative_humidity - copyvals(nc1 = nc1, var1 = "RH", nc2 = nc2, - var2 = "relative_humidity", dim2 = dim, + copyvals(nc1 = nc1, var1 = "RH", nc2 = nc2, + var2 = "relative_humidity", dim2 = dim, verbose = verbose) - + # convert VPD to water_vapor_saturation_deficit HACK : conversion will make all values < 0 to be # NA copyvals(nc1 = nc1, var1 = "VPD", nc2 = nc2, - var2 = "water_vapor_saturation_deficit", units2 = "Pa", + var2 = "water_vapor_saturation_deficit", units2 = "Pa", dim2 = dim, conv = function(x) { ifelse(x < 0, NA, x * 1000) }, verbose = verbose) - + # copy Rg to surface_downwelling_shortwave_flux_in_air - copyvals(nc1 = nc1, var1 = "Rg", nc2 = nc2, - var2 = "surface_downwelling_shortwave_flux_in_air", - dim2 = dim, + copyvals(nc1 = nc1, var1 = "Rg", nc2 = nc2, + var2 = "surface_downwelling_shortwave_flux_in_air", + dim2 = dim, verbose = verbose) - + # copy Rgl to surface_downwelling_longwave_flux_in_air - copyvals(nc1 = nc1, var1 = "Rgl", nc2 = nc2, - var2 = "surface_downwelling_longwave_flux_in_air", - dim2 = dim, + copyvals(nc1 = nc1, var1 = "Rgl", nc2 = nc2, + var2 = "surface_downwelling_longwave_flux_in_air", + dim2 = dim, verbose = verbose) - + # convert PAR to surface_downwelling_photosynthetic_photon_flux_in_air - copyvals(nc1 = nc1, var1 = "PAR", nc2 = nc2, + copyvals(nc1 = nc1, var1 = "PAR", nc2 = nc2, var2 = "surface_downwelling_photosynthetic_photon_flux_in_air", units2 = "mol m-2 s-1", - dim2 = dim, - conv = function(x) { x / 1e+06 }, + dim2 = dim, + conv = function(x) { x / 1e+06 }, verbose = verbose) - + # copy WD to wind_direction (not official CF) copyvals(nc1 = nc1, var1 = "WD", nc2 = nc2, var2 = "wind_direction", dim2 = dim, verbose = verbose) - + # copy WS to wind_speed - copyvals(nc1 = nc1, var1 = "WS", nc2 = nc2, - var2 = "wind_speed", dim2 = dim, + copyvals(nc1 = nc1, var1 = "WS", nc2 = nc2, + var2 = "wind_speed", dim2 = dim, verbose = verbose) - + # convert PREC to precipitation_flux t <- tdim$vals min <- 0.02083 / 30 # 0.02083 time = 30 minutes timestep <- round(x = mean(diff(t)) / min, digits = 1) # round to nearest 0.1 minute - copyvals(nc1 = nc1, var1 = "PREC", nc2 = nc2, - var2 = "precipitation_flux", units2 = "kg/m^2/s", - dim2 = dim, + copyvals(nc1 = nc1, var1 = "PREC", nc2 = nc2, + var2 = "precipitation_flux", units2 = "kg/m^2/s", + dim2 = dim, conv = function(x) { x / timestep / 60 }, verbose = verbose) - + # convert wind speed and wind direction to eastward_wind and northward_wind wd <- ncvar_get(nc = nc1, varid = "WD") #wind direction wd[wd == -6999 | wd == -9999] <- NA @@ -275,29 +275,29 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date ew <- ws * cos(wd * (pi / 180)) nw <- ws * sin(wd * (pi / 180)) max <- ncatt_get(nc = nc1, varid = "WS", "valid_max")$value - + var <- ncvar_def(name = "eastward_wind", units = "m/s", dim = dim, missval = -6999, verbose = verbose) nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) ncvar_put(nc = nc2, varid = "eastward_wind", vals = ew) ncatt_put(nc = nc2, varid = "eastward_wind", attname = "valid_min", attval = -max) ncatt_put(nc = nc2, varid = "eastward_wind", attname = "valid_max", attval = max) - + var <- ncvar_def(name = "northward_wind", units = "m/s", dim = dim, missval = -6999, verbose = verbose) nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) ncvar_put(nc = nc2, varid = "northward_wind", vals = nw) ncatt_put(nc = nc2, varid = "northward_wind", attname = "valid_min", attval = -max) ncatt_put(nc = nc2, varid = "northward_wind", attname = "valid_max", attval = max) - + # add global attributes from original file cp.global.atts <- ncatt_get(nc = nc1, varid = 0) for (j in seq_along(cp.global.atts)) { ncatt_put(nc = nc2, varid = 0, attname = names(cp.global.atts)[j], attval = cp.global.atts[[j]]) } - + # done, close both files ncdf4::nc_close(nc1) ncdf4::nc_close(nc2) } ## end loop over years - + return(invisible(results)) } # met2CF.Ameriflux diff --git a/modules/data.atmosphere/R/metgapfill.R b/modules/data.atmosphere/R/metgapfill.R index 47cc67225a8..730fe43d550 100644 --- a/modules/data.atmosphere/R/metgapfill.R +++ b/modules/data.atmosphere/R/metgapfill.R @@ -111,6 +111,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst if (!is.numeric(Tair)) { PEcAn.logger::logger.error("air_temperature not defined in met file for metgapfill") } + Tair_degC <- udunits2::ud.convert(Tair, "K", "degC") precip <- try(ncvar_get(nc = nc, varid = "precipitation_flux"), silent = TRUE) if (!is.numeric(precip)) { PEcAn.logger::logger.error("precipitation_flux not defined in met file for metgapfill") @@ -255,16 +256,16 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst ## Fill these variables from each other if ((all(is.na(VPD))) & (!all(is.na(rH)))) { - VPD <- as.numeric(fCalcVPDfromRHandTair(rH, Tair - 273.15)) * 100 + VPD <- as.numeric(fCalcVPDfromRHandTair(rH, Tair_degC)) * 100 } if ((all(is.na(sHum))) & (!all(is.na(rH)))) { sHum <- rh2qair(rH / 100, Tair, press) } if ((all(is.na(rH))) & (!all(is.na(sHum)))) { - rH <- qair2rh(sHum, Tair - 273.15, press / 100) * 100 + rH <- qair2rh(sHum, Tair_degC, press / 100) * 100 } if ((all(is.na(rH))) & (!all(is.na(VPD)))) { - es <- get.es(Tair - 273.15) * 100 + es <- get.es(Tair_degC) * 100 rH <- 100 * ((es - VPD) / es) rH[rH < 0] <- 0 rH[rH > 100] <- 100 @@ -275,17 +276,17 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst } # try again if we computed rH from sHum, get VPD from sHum-based rH if ((all(is.na(VPD))) & (!all(is.na(rH)))) { - VPD <- as.numeric(fCalcVPDfromRHandTair(rH, Tair - 273.15)) * 100 + VPD <- as.numeric(fCalcVPDfromRHandTair(rH, Tair_degC)) * 100 } # now fill partial missing values of each badrH <- is.na(rH) if ((any(badrH)) & (!all(is.na(sHum)))) { - rH[badrH] <- qair2rh(sHum[badrH], Tair[badrH] - 273.15, press[badrH] / 100) * 100 + rH[badrH] <- qair2rh(sHum[badrH], Tair_degC[badrH], press[badrH] / 100) * 100 } badrH <- is.na(rH) if ((any(badrH)) & (!all(is.na(VPD)))) { - es <- get.es(Tair[badrH] - 273.15) * 100 + es <- get.es(Tair_degC[badrH]) * 100 rH[badrH] <- 100 * ((es - VPD[badrH]) / es) rH[rH < 0] <- 0 rH[rH > 100] <- 100 @@ -296,7 +297,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst } badVPD <- is.na(VPD) if ((any(badVPD)) & (!all(is.na(rH)))) { - VPD[badVPD] <- as.numeric(fCalcVPDfromRHandTair(rH[badVPD], Tair[badVPD] - 273.15)) * 100 + VPD[badVPD] <- as.numeric(fCalcVPDfromRHandTair(rH[badVPD], Tair_degC[badVPD])) * 100 } ## one set of these must exist (either wind_speed or east+north wind) @@ -327,8 +328,9 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst ## make a data frame, convert -9999 to NA, convert to degrees C EddyData.F <- data.frame(Tair, Rg, rH, PAR, precip, sHum, Lw, Ts1, VPD, ws, co2, press, east_wind, north_wind) - EddyData.F["Tair"] <- EddyData.F["Tair"] - 273.15 - EddyData.F["Ts1"] <- EddyData.F["Ts1"] - 273.15 + EddyData.F["Tair"] <- udunits2::ud.convert(EddyData.F["Tair"], "K", "degC") + EddyData.F["Tair"] <- EddyData.F["Tair"] + EddyData.F["Ts1"] <- udunits2::ud.convert(EddyData.F["Ts1"], "K", "degC") EddyData.F["VPD"] <- EddyData.F["VPD"] / 1000 ## Optional need: @@ -469,7 +471,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst ## Write back to NC file, convert air T to Kelvin error <- c() if (("Tair_f" %in% colnames(Extracted))) { - Tair_f <- Extracted[, "Tair_f"] + 273.15 + Tair_f <- udunits2::ud.convert(Extracted[, "Tair_f"], "degC", "K") } if (length(which(is.na(Tair_f))) > 0) { error <- c(error, "air_temperature") @@ -512,7 +514,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst sHum_f <- Extracted[, "sHum_f"] } sHum_f[is.na(sHum_f)] <- 0.622 * - (rH_f[is.na(sHum_f)] / 100) * (get.es(Tair_f[is.na(sHum_f)] - 273.15) / 1000) + (rH_f[is.na(sHum_f)] / 100) * (get.es(udunits2::ud.convert(Tair_f[is.na(sHum_f)], "K", "degC")) / 1000) if (length(which(is.na(sHum_f))) > 0) { error <- c(error, "specific_humidity") } @@ -528,7 +530,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst ncvar_put(nc, varid = "surface_downwelling_longwave_flux_in_air", vals = Lw_f) if (("Ts1_f" %in% colnames(Extracted))) { - Ts1_f <- Extracted[, "Ts1_f"] + 273.15 + Ts1_f <- udunits2::ud.convert(Extracted[, "Ts1_f"], "degC", "K") } if (sum(is.na(Ts1_f)) > 0) { Tair_ff <- Tair_f diff --git a/modules/data.atmosphere/R/metutils.R b/modules/data.atmosphere/R/metutils.R index 3b0d6c5e737..c5294b90858 100644 --- a/modules/data.atmosphere/R/metutils.R +++ b/modules/data.atmosphere/R/metutils.R @@ -16,7 +16,7 @@ qcshum <- function(x) { ##' ##' converting specific humidity into relative humidity ##' NCEP surface flux data does not have RH -##' from Bolton 1980 Teh computation of Equivalent Potential Temperature +##' from Bolton 1980 Teh computation of Equivalent Potential Temperature ##' \url{http://www.eol.ucar.edu/projects/ceop/dm/documents/refdata_report/eqns.html} ##' @title qair2rh ##' @param qair specific humidity, dimensionless (e.g. kg/kg) ratio of water mass / total air mass @@ -43,7 +43,8 @@ qair2rh <- function(qair, temp, press = 1013.25) { ##' @author Mike Dietze, Ankur Desai ##' @aliases rh2rv rh2qair <- function(rh, T, press = 101325) { - Tc <- T - 273.15 + stopifnot(T >= 0) + Tc <- udunits2::ud.convert(T, "K", "degC") es <- 6.112 * exp((17.67 * Tc) / (Tc + 243.5)) e <- rh * es p_mb <- press / 100 @@ -56,7 +57,7 @@ rh2qair <- function(rh, T, press = 101325) { ##' ##' Calculate vapor pressure deficit from relative humidity and temperature. ##' @title VPD -##' @param rh relative humidity, in percent +##' @param rh relative humidity, in percent ##' @param temp temperature, degrees celsius ##' @return vpd: vapor pressure deficit, in mb ##' @export @@ -74,7 +75,7 @@ get.vpd <- function(rh, temp) { ##' Calculate saturation vapor pressure ##' ##' @title get es -##' @param temp temperature in degrees C +##' @param temp temperature in degrees C ##' @return saturation vapor pressure in mb ##' @export ##' @author David LeBauer @@ -90,7 +91,7 @@ SatVapPres <- function(T) { # /estimates saturation vapor pressure (kPa) Goff-Gratch 1946 /input: T = absolute temperature T_st <- 373.15 ##steam temperature (K) e_st <- 1013.25 ##/saturation vapor pressure at steam temp (hPa) - return(0.1 * exp(-7.90298 * (T_st/T - 1) + 5.02808 * log(T_st/T) - 1.3816e-07 * (10^(11.344 * (1 - T/T_st)) - + return(0.1 * exp(-7.90298 * (T_st/T - 1) + 5.02808 * log(T_st/T) - 1.3816e-07 * (10^(11.344 * (1 - T/T_st)) - 1) + 0.0081328 * (10^(-3.49149 * (T_st/T - 1)) - 1) + log(e_st))) } # SatVapPres @@ -102,7 +103,7 @@ SatVapPres <- function(T) { ##' A Simple Conversion and Applications.) ##' @title get RH ##' @param temp T in original equation -##' @param dewpoint Td in original +##' @param dewpoint Td in original ##' @return numeric vector ##' @export ##' @author David LeBauer @@ -151,11 +152,11 @@ par2ppfd <- function(watts) { ##' Solar Radiation to PPFD -##' -##' Here the input is the total solar radiation +##' +##' Here the input is the total solar radiation ##' so to obtain in the PAR spectrum need to multiply by 0.486 From Campbell and Norman p151 ##' This is based on the approximation that PAR is 0.45-0.50 of the total radiation -##' +##' ##' @title SW to PAR ##' @author David LeBauer ##' @param sw shortwave radiation (W/m2 == J/m2/s) @@ -166,7 +167,7 @@ sw2par <- function(sw) { } # sw2par ##' CF Shortwave to PPFD -##' +##' ##' Cambell and Norman 1998 p 151, ch 10 ##' @title SW to PPFD ##' @author David LeBauer @@ -180,7 +181,7 @@ sw2ppfd <- function(sw) { ##' Solar Radiation to PPFD -##' +##' ##' There is no easy straight way to convert MJ/m2 to mu mol photons / m2 / s (PAR). ##' Note: 1 Watt = 1J/s ##' The above conversion is based on the following reasoning @@ -193,7 +194,7 @@ sw2ppfd <- function(sw) { ##' This means that 1e6 / (2.35e6) * 0.486 = 2.07 ##' 1e6 converts from mol to mu mol ##' 1/3600 divides the values in hours to seconds -##' +##' ##' @title MJ to PPFD ##' @author Fernando Miguez ##' @author David LeBauer @@ -224,13 +225,14 @@ AirDens <- function(pres, T, rv) { return(pres / (287 * T * (1 + 0.61 * rv))) } # AirDens -##' calculate latent heat of vaporization for water -##' +##' calculate latent heat of vaporization for water +##' ##' @title Latent heat of vaporization ##' @param airtemp air temperature (Kelvin) ##' @export ##' @author Istem Fer ##' @return lV latent heat of vaporization (J kg-1) get.lv <- function(airtemp = 268.6465) { - return((94.21 * (365 - (airtemp - 273.15)) ^ 0.31249) * 4.183 * 1000) + airtemp_C <- udunits2::ud.convert(airtemp, "K", "degC") + return((94.21 * (365 - airtemp_C) ^ 0.31249) * 4.183 * 1000) } # get.lv diff --git a/modules/data.atmosphere/man/qair2rh.Rd b/modules/data.atmosphere/man/qair2rh.Rd index 74172e25a53..6fc85af4d85 100644 --- a/modules/data.atmosphere/man/qair2rh.Rd +++ b/modules/data.atmosphere/man/qair2rh.Rd @@ -22,7 +22,7 @@ Convert specific humidity to relative humidity \details{ converting specific humidity into relative humidity NCEP surface flux data does not have RH -from Bolton 1980 Teh computation of Equivalent Potential Temperature +from Bolton 1980 Teh computation of Equivalent Potential Temperature \url{http://www.eol.ucar.edu/projects/ceop/dm/documents/refdata_report/eqns.html} } \author{ diff --git a/modules/data.atmosphere/man/sw2par.Rd b/modules/data.atmosphere/man/sw2par.Rd index dfd589de951..d2eb9abf973 100644 --- a/modules/data.atmosphere/man/sw2par.Rd +++ b/modules/data.atmosphere/man/sw2par.Rd @@ -16,7 +16,7 @@ PAR W/m2 Solar Radiation to PPFD } \details{ -Here the input is the total solar radiation +Here the input is the total solar radiation so to obtain in the PAR spectrum need to multiply by 0.486 From Campbell and Norman p151 This is based on the approximation that PAR is 0.45-0.50 of the total radiation } diff --git a/modules/uncertainty/R/run.sensitivity.analysis.R b/modules/uncertainty/R/run.sensitivity.analysis.R index e5f010813d0..f58eec9f3f7 100644 --- a/modules/uncertainty/R/run.sensitivity.analysis.R +++ b/modules/uncertainty/R/run.sensitivity.analysis.R @@ -1,23 +1,23 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html #------------------------------------------------------------------------------- #--------------------------------------------------------------------------------------------------# ##' run sensitivity.analysis -##' +##' ##' @name run.sensitivity.analysis ##' @title run sensitivity.analysis ##' @return nothing, saves \code{sensitivity.results} as sensitivity.results.Rdata, ##' sensitivity plots as sensitivityanalysis.pdf, and variance decomposition 'popsicle plot' ##' as variancedecomposition.pdf a side effect (OPTIONAL) -##' -##' @param plot logical. Option to generate sensitivity analysis and variance +##' +##' @param plot logical. Option to generate sensitivity analysis and variance ##' decomposition plots (plot=TRUE) or to turn these plots off (plot=FALSE). -##' +##' ##' @export ##' @author David LeBauer, Shawn Serbin, Ryan Kelly ##' @@ -33,54 +33,54 @@ run.sensitivity.analysis <- function(settings,plot=TRUE, ensemble.id=NULL, varia if(is.null(start.year) | is.null(end.year)) { PEcAn.logger::logger.severe("No years given for sensitivity analysis!") } - + if(is.null(variable)) { variable = settings$sensitivity.analysis$variable } if(is.null(variable)) { PEcAn.logger::logger.severe("No variables for ensemble analysis!") } - + # Only handling one variable at a time for now if(length(variable) > 1) { variable <- variable[1] PEcAn.logger::logger.warn(paste0("Currently performs ensemble analysis on only one variable at a time. Using first (", variable, ")")) } - + ### Load samples - # Have to load samples.Rdata for the traits. But can overwrite the run ids if a sensitivity analysis ensemble id provided. samples.Rdata always has only the most recent ensembles for both ensemble and sensitivity runs. - fname <- file.path(settings$outdir, 'samples.Rdata') + # Have to load samples.Rdata for the traits. But can overwrite the run ids if a sensitivity analysis ensemble id provided. samples.Rdata always has only the most recent ensembles for both ensemble and sensitivity runs. + fname <- file.path(settings$outdir, 'samples.Rdata') if(!file.exists(fname)) PEcAn.logger::logger.severe("No samples.Rdata file found!") load(fname) - + # Can specify ensemble ids manually. If not, look in settings. If none there, will use the most recent, which was loaded with samples.Rdata if(!is.null(ensemble.id)) { - fname <- sensitivity.filename(settings, "sensitivity.samples", "Rdata", + fname <- sensitivity.filename(settings, "sensitivity.samples", "Rdata", ensemble.id=ensemble.id, all.var.yr=TRUE) } else if(!is.null(settings$sensitivity.analysis$ensemble.id)) { ensemble.id <- settings$sensitivity.analysis$ensemble.id - fname <- sensitivity.filename(settings, "sensitivity.samples", "Rdata", + fname <- sensitivity.filename(settings, "sensitivity.samples", "Rdata", ensemble.id=ensemble.id, all.var.yr=TRUE) } else { ensemble.id <- NULL } if(file.exists(fname)) load(fname) - + # For backwards compatibility, define some variables if not just loaded if(!exists("pft.names")) pft.names <- names(trait.samples) if(!exists("trait.names")) trait.names <- lapply(trait.samples, names) if(!exists("sa.run.ids")) sa.run.ids <- runs.samples$sa - + ### Load parsed model results variables <- convert.expr(variable) variable.fn <- variables$variable.drv - + fname <- sensitivity.filename( settings, "sensitivity.output", "Rdata", all.var.yr = FALSE, - ensemble.id = ensemble.id, variable = variable.fn, + ensemble.id = ensemble.id, variable = variable.fn, start.year = start.year, end.year = end.year) load(fname) - + ### Generate SA output and diagnostic plots sensitivity.results <- list() for(pft in settings$pfts){ @@ -88,12 +88,14 @@ run.sensitivity.analysis <- function(settings,plot=TRUE, ensemble.id=NULL, varia quantiles.str <- rownames(sa.samples[[pft$name]]) quantiles.str <- quantiles.str[which(quantiles.str != '50')] quantiles <- as.numeric(quantiles.str)/100 - + C.units <- grepl('^Celsius$', trait.lookup(traits)$units, ignore.case = TRUE) if(any(C.units)){ - for(x in which(C.units)) trait.samples[[pft$name]][[x]] <- trait.samples[[pft$name]][[x]] + 273.15 + for(x in which(C.units)) { + trait.samples[[pft$name]][[x]] <- udunits2::ud.convert(trait.samples[[pft$name]][[x]], "degC", "K") + } } - + ## only perform sensitivity analysis on traits where no more than 2 results are missing good.saruns <- sapply(sensitivity.output[[pft$name]], function(x) sum(is.na(x)) <=2) if(!all(good.saruns)) { # if any bad saruns, reduce list of traits and print warning @@ -102,25 +104,25 @@ run.sensitivity.analysis <- function(settings,plot=TRUE, ensemble.id=NULL, varia '\n sensitivity analysis or variance decomposition will be performed on these trait(s)', '\n it is likely that the runs did not complete, this should be fixed !!!!!!')) } - + ### Gather SA results sensitivity.results[[pft$name]] <- sensitivity.analysis( trait.samples = trait.samples[[pft$name]][traits], sa.samples = sa.samples[[pft$name]][ ,traits, drop=FALSE], sa.output = sensitivity.output[[pft$name]][ ,traits, drop=FALSE], outdir = pft$outdir) - + ### Send diagnostic output to the console print(sensitivity.results[[pft$name]]$variance.decomposition.output) print(sensitivity.output[[pft$name]]) - + ### Plotting - Optional if(plot){ fname <- sensitivity.filename( - settings, "sensitivity.analysis", "pdf", + settings, "sensitivity.analysis", "pdf", all.var.yr=FALSE, pft=pft$name, ensemble.id=ensemble.id, variable=variable.fn, start.year=start.year, end.year=end.year) - + ### Generate SA diagnostic plots sensitivity.plots <- plot_sensitivities( sensitivity.results[[pft$name]]$sensitivity.output, linesize = 1, dotsize = 3) @@ -131,25 +133,25 @@ run.sensitivity.analysis <- function(settings,plot=TRUE, ensemble.id=NULL, varia print(do.call("grid.arrange", c(sensitivity.plots, ncol=ncol))) print(sensitivity.plots) # old method. depreciated. dev.off() - + ### Generate VD diagnostic plots vd.plots <- plot_variance_decomposition(sensitivity.results[[pft$name]]$variance.decomposition.output) #variance.scale = log, variance.prefix='Log') - fname <- sensitivity.filename(settings, "variance.decomposition", "pdf", + fname <- sensitivity.filename(settings, "variance.decomposition", "pdf", all.var.yr=FALSE, pft=pft$name, ensemble.id=ensemble.id, variable=variable.fn, start.year=start.year, end.year=end.year) - + pdf(fname, width = 11, height = 8) do.call(grid.arrange, c(vd.plots, ncol = 4)) dev.off() } - + } ## end if sensitivity analysis - - fname <- sensitivity.filename(settings, "sensitivity.results", "Rdata", + + fname <- sensitivity.filename(settings, "sensitivity.results", "Rdata", all.var.yr=FALSE, pft=NULL, ensemble.id=ensemble.id, variable=variable.fn, start.year=start.year, end.year=end.year) - + save(sensitivity.results, file = fname) } } @@ -160,7 +162,7 @@ runModule.run.sensitivity.analysis <- function(settings, ...) { if(is.MultiSettings(settings)) { return(papply(settings, runModule.run.sensitivity.analysis, ...)) } else if (is.Settings(settings)) { - run.sensitivity.analysis(settings, ...) + run.sensitivity.analysis(settings, ...) } else { stop("runModule.run.sensitivity.analysis only works with Settings or MultiSettings") } diff --git a/modules/uncertainty/man/run.sensitivity.analysis.Rd b/modules/uncertainty/man/run.sensitivity.analysis.Rd index 07c2ee1004e..fc5d34a31ae 100644 --- a/modules/uncertainty/man/run.sensitivity.analysis.Rd +++ b/modules/uncertainty/man/run.sensitivity.analysis.Rd @@ -8,7 +8,7 @@ run.sensitivity.analysis(settings, plot = TRUE, ensemble.id = NULL, variable = NULL, start.year = NULL, end.year = NULL, ...) } \arguments{ -\item{plot}{logical. Option to generate sensitivity analysis and variance +\item{plot}{logical. Option to generate sensitivity analysis and variance decomposition plots (plot=TRUE) or to turn these plots off (plot=FALSE).} } \value{ From 7f32455f77d6762bfa47b21f01c8dc1d8c1fd023 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 5 Sep 2017 11:07:25 -0400 Subject: [PATCH 539/771] Change manual unit conversions to `udunits2` Also, some more whitespace fixes by RStudio. --- models/dalec/R/write.configs.dalec.R | 126 ++++++++--------- models/dalec/man/write.config.DALEC.Rd | 9 -- models/preles/R/runPRELES.jobsh.R | 8 +- models/sipnet/R/model2netcdf.SIPNET.R | 55 ++++---- models/sipnet/R/write.configs.SIPNET.R | 132 +++++++++--------- models/sipnet/R/write_restart.SIPNET.R | 64 ++++----- .../data.atmosphere/R/download.MsTMIP_NARR.R | 2 +- modules/data.atmosphere/R/met2CF.ALMA.R | 14 +- modules/data.atmosphere/R/met2CF.Ameriflux.R | 14 +- modules/data.atmosphere/R/metgapfill.R | 6 +- 10 files changed, 212 insertions(+), 218 deletions(-) diff --git a/models/dalec/R/write.configs.dalec.R b/models/dalec/R/write.configs.dalec.R index 05e44598a26..6bf03d881ec 100644 --- a/models/dalec/R/write.configs.dalec.R +++ b/models/dalec/R/write.configs.dalec.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2015 Boston University, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -13,64 +13,64 @@ PREFIX_XML <- "\n" convert.samples.DALEC <- function(trait.samples) { - + DEFAULT.LEAF.C <- 0.48 ## convert SLA from PEcAn m2 / kg leaf to m2 / g C - + if ("SLA" %in% names(trait.samples)) { trait.samples[["SLA"]] <- trait.samples[["SLA"]]/DEFAULT.LEAF.C/1000 } - + # t1 rate variable controlling decomposition from litter to soil organinc matter [day-1, ref T # 10C] if ("litter_decomposition_to_SOM" %in% names(trait.samples)) { names(trait.samples)[which(names(trait.samples) == "litter_decomposition_to_SOM")] <- "t1" } - + # t2 proportion of GPP lost to autotrophic respiration if ("autotrophic_respiration_fraction" %in% names(trait.samples)) { names(trait.samples)[which(names(trait.samples) == "autotrophic_respiration_fraction")] <- "t2" } - + # t3 proportion of NPP allocated to foliage if ("leaf_allocation_fraction" %in% names(trait.samples)) { names(trait.samples)[which(names(trait.samples) == "leaf_allocation_fraction")] <- "t3" } - + # t4 proportion of NPP allocated to roots if ("root_allocation_fraction" %in% names(trait.samples)) { names(trait.samples)[which(names(trait.samples) == "root_allocation_fraction")] <- "t4" } - + # t5 proportion of foliage becoming litter every time step if ("leaf_turnover_rate" %in% names(trait.samples)) { trait.samples[["leaf_turnover_rate"]] <- trait.samples[["leaf_turnover_rate"]]/365 names(trait.samples)[which(names(trait.samples) == "leaf_turnover_rate")] <- "t5" } - + # t6 proportion of woody material becoming woody debris every time step if ("wood_turnover_rate" %in% names(trait.samples)) { trait.samples[["wood_turnover_rate"]] <- trait.samples[["wood_turnover_rate"]]/365 names(trait.samples)[which(names(trait.samples) == "wood_turnover_rate")] <- "t6" } - + # t7 proportion of fine roots becoming soil/woody debris every time step if ("root_turnover_rate" %in% names(trait.samples)) { trait.samples[["root_turnover_rate"]] <- trait.samples[["root_turnover_rate"]]/365 names(trait.samples)[which(names(trait.samples) == "root_turnover_rate")] <- "t7" } - + # t8 rate variable controlling respiration from litter [day-1, ref T 10C] if ("litter_respiration_rate" %in% names(trait.samples)) { names(trait.samples)[which(names(trait.samples) == "litter_respiration_rate")] <- "t8" } - + # t9 rate variable controlling respiration from soil organic matter and woody debris [day-1, ref # T 10C] if ("som_respiration_rate" %in% names(trait.samples)) { names(trait.samples)[which(names(trait.samples) == "som_respiration_rate")] <- "t9" } - + return(trait.samples) } # convert.samples.DALEC @@ -80,22 +80,22 @@ convert.samples.DALEC <- function(trait.samples) { #--------------------------------------------------------------------------------------------------# ##' write Dalec Configuration files ##' -##' @title write.config.DALEC -##' @param defaults -##' @param trait.values -##' @param settings -##' @param run.id +##' @title write.config.DALEC +##' @param defaults +##' @param trait.values +##' @param settings +##' @param run.id ##' @return configuration files ##' @export write.config.DALEC write.config.DALEC <- function(defaults, trait.values, settings, run.id) { - + ### CONVERT PARAMETERS cmdFlags <- "" for (group in names(trait.values)) { if (group == "env") { - + ## set defaults from config.header - + } else { if (!is.null(trait.values[[group]])) { params <- convert.samples.DALEC(trait.values[[group]]) @@ -106,69 +106,69 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { } } } - + ### INITIAL CONDITIONS IC.params <- list() - + if(!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path - + sla <- NULL if("SLA" %in% names(params)){ - sla <- params[1,"SLA"] * 1000 #convert SLA to m2/kgC from m2/gC (convert.samples) + sla <- udunits2::ud.convert(params[1,"SLA"], 'm2 kg-1', 'm2 g') #convert SLA to m2/kgC from m2/gC (convert.samples) } else{ default.param <- read.table(system.file("default_param.dalec", package = "PEcAn.DALEC"), header = TRUE) - sla <- default.param[which(default.param$cmdFlag == "SLA"),"val"] * 1000 #convert SLA to m2/kgC from m2/gC (dalec default) + sla <- udunits2::ud.convert(default.param[which(default.param$cmdFlag == "SLA"),"val"], 'm2 kg-1', 'm2 g') #convert SLA to m2/kgC from m2/gC (dalec default) } - + IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = sla)) - + if(!is.null(IC.pools)){ ###Write initial conditions from netcdf (Note: wherever valid input isn't available, DALEC default remains) - + # cf0 initial canopy foliar carbon (g/m2) if ("leaf" %in% names(IC.pools)) { - IC.params[["cf0"]] <- IC.pools$leaf * 1000 #from PEcAn standard kg C m-2 - } - + IC.params[["cf0"]] <- udunits2::ud.convert(IC.pools$leaf, 'kg m-2', 'g m-2') #from PEcAn standard kg C m-2 + } + # cw0 initial pool of woody carbon (g/m2) if ("wood" %in% names(IC.pools)) { - IC.params[["cw0"]] <- IC.pools$wood * 1000 #from PEcAn standard kg C m-2 - } - + IC.params[["cw0"]] <- udunits2::ud.convert(IC.pools$wood, 'kg m-2', 'g m-2') #from PEcAn standard kg C m-2 + } + # cr0 initial pool of fine root carbon (g/m2) if ("fine.roots" %in% names(IC.pools)) { - IC.params[["cr0"]] <- IC.pools$fine.roots * 1000 #from PEcAn standard kg C m-2 - } - + IC.params[["cr0"]] <- udunits2::ud.convert(IC.pools$fine.roots, 'kg m-2', 'g m-2') #from PEcAn standard kg C m-2 + } + ###non-living variables # cl0 initial pool of litter carbon (g/m2) if ("litter" %in% names(IC.pools)) { - IC.params[["cl0"]] <- IC.pools$litter * 1000 #from PEcAn standard kg C m-2 + IC.params[["cl0"]] <- udunits2::ud.convert(IC.pools$litter, 'kg m-2', 'g m-2') #from PEcAn standard kg C m-2 } - + # cs0 initial pool of soil organic matter and woody debris carbon (g/m2) if("soil" %in% names(IC.pools)){ if("wood.debris" %in% names(IC.pools)){ - IC.params[["cs0"]] <- (IC.pools$soil + sum(IC.pools$wood.debris)) * 1000 #from PEcAn standard kg C m-2 + IC.params[["cs0"]] <- udunits2::ud.convert(IC.pools$soil + sum(IC.pools$wood.debris), 'kg m-2', 'g m-2') #from PEcAn standard kg C m-2 } else { - IC.params[["cs0"]] <- IC.pools$soil * 1000 #from PEcAn standard kg C m-2 + IC.params[["cs0"]] <- udunits2::ud.convert(IC.pools$soil, 'kg m-2', 'g m-2') #from PEcAn standard kg C m-2 PEcAn.logger::logger.warn("write.configs.DALEC IC: Loading soil carbon pool without woody debris.") } - } - + } + ###Write to command line file for (i in seq_along(IC.params)) { cmdFlags <- paste0(cmdFlags, " -", names(IC.params)[i], " ", IC.params[[i]]) } PEcAn.logger::logger.info(paste("All command flags:",cmdFlags)) - + } else{ PEcAn.logger::logger.error("Bad initial conditions filepath; kept defaults") } } - - + + # find out where to write run/ouput rundir <- file.path(settings$host$rundir, as.character(run.id)) outdir <- file.path(settings$host$outdir, as.character(run.id)) @@ -176,34 +176,34 @@ write.config.DALEC <- function(defaults, trait.values, settings, run.id) { rundir <- file.path(settings$rundir, as.character(run.id)) outdir <- file.path(settings$modeloutdir, as.character(run.id)) } - + ### WRITE PARAMETERS config.file.name <- paste0("CONFIG.", run.id) writeLines(cmdFlags, con = file.path(rundir, config.file.name)) - + ### WRITE JOB.SH - jobsh <- paste0("#!/bin/bash\n", - settings$model$binary, - " $(cat ", rundir, "/", config.file.name, - ") < ", as.character(settings$run$inputs$met$path), " > ", - outdir, "/out.txt\n", + jobsh <- paste0("#!/bin/bash\n", + settings$model$binary, + " $(cat ", rundir, "/", config.file.name, + ") < ", as.character(settings$run$inputs$met$path), " > ", + outdir, "/out.txt\n", # 'echo ".libPaths(',"'~/R/library');", - "echo \"", - " library(PEcAn.DALEC); model2netcdf.DALEC(", "'", - outdir, "',", - settings$run$site$lat, ",", - settings$run$site$lon, ", '", - settings$run$start.date, "', '", - settings$run$end.date, "') ", + "echo \"", + " library(PEcAn.DALEC); model2netcdf.DALEC(", "'", + outdir, "',", + settings$run$site$lat, ",", + settings$run$site$lon, ", '", + settings$run$start.date, "', '", + settings$run$end.date, "') ", "\" | R --vanilla") writeLines(jobsh, con = file.path(settings$rundir, run.id, "job.sh")) Sys.chmod(file.path(settings$rundir, run.id, "job.sh")) - + ### Display info to the console. print(run.id) } # write.config.DALEC # ==================================================================================================# remove.config.DALEC <- function(outdir, settings) { - + } # remove.config.DALEC diff --git a/models/dalec/man/write.config.DALEC.Rd b/models/dalec/man/write.config.DALEC.Rd index cf3bf4a26d5..4d0329829db 100644 --- a/models/dalec/man/write.config.DALEC.Rd +++ b/models/dalec/man/write.config.DALEC.Rd @@ -6,15 +6,6 @@ \usage{ write.config.DALEC(defaults, trait.values, settings, run.id) } -\arguments{ -\item{defaults}{} - -\item{trait.values}{} - -\item{settings}{} - -\item{run.id}{} -} \value{ configuration files } diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index aecacabf8be..038f1fad567 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -30,7 +30,7 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - timestep.s <- 86400 # Number of seconds in a day + timestep.s <- udunits2::ud.convert(1, "day", "seconds") # Number of seconds in a day ## Build met met <- NULL @@ -80,7 +80,7 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star ## Get PPFD from SW PPFD <- sw2ppfd(SW) # PPFD in umol/m2/s - PPFD <- PPFD * 1e-06 # convert umol to mol + PPFD <- udunits2::ud.convert(PPFD, "umol m-2 s-1", "mol m-2 s-1") ## Format/convert inputs ppfd <- tapply(PPFD, doy, mean, na.rm = TRUE) # Find the mean for the day @@ -88,7 +88,7 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star vpd <- udunits2::ud.convert(tapply(VPD, doy, mean, na.rm = TRUE), "Pa", "kPa") # pascal to kila pascal precip <- tapply(Precip, doy, sum, na.rm = TRUE) # Sum to daily precipitation co2 <- tapply(CO2, doy, mean) # need daily average, so sum up day - co2 <- co2 / 1e+06 # convert to ppm + co2 <- co2 / 1e+06 # convert to ppm. ANS: Convert from what? Mole-fraction to ppm is multiplying by 1e6, not dividing doy <- tapply(doy, doy, mean) # day of year fapar <- rep(0.6, length = length(doy)) # For now set to 0.6. Needs to be between 0-1 @@ -152,7 +152,7 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star sub.PRELES.output.dims <- dim(sub.PRELES.output) output <- list() - output[[1]] <- (sub.PRELES.output[, 1] * 0.001)/timestep.s #GPP - gC/m2day to kgC/m2s1 + output[[1]] <- udunits2::ud.convert(sub.PRELES.output[, 1], 'g m-2 day-1', 'kg m-2 sec-1') #GPP - gC/m2day to kgC/m2s1 output[[2]] <- (sub.PRELES.output[, 2])/timestep.s #Evapotranspiration - mm =kg/m2 output[[3]] <- (sub.PRELES.output[, 3])/timestep.s #Soilmoisture - mm = kg/m2 output[[4]] <- (sub.PRELES.output[, 4])/timestep.s #fWE modifier - just a modifier diff --git a/models/sipnet/R/model2netcdf.SIPNET.R b/models/sipnet/R/model2netcdf.SIPNET.R index 97abc29abd3..170bc03c419 100644 --- a/models/sipnet/R/model2netcdf.SIPNET.R +++ b/models/sipnet/R/model2netcdf.SIPNET.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -22,42 +22,43 @@ ##' @export ##' @author Shawn Serbin, Michael Dietze model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, delete.raw, revision) { - + ### Read in model output in SIPNET format sipnet.out.file <- file.path(outdir, "sipnet.out") sipnet.output <- read.table(sipnet.out.file, header = T, skip = 1, sep = "") sipnet.output.dims <- dim(sipnet.output) - + ### Determine number of years and output timestep start.day <- sipnet.output$day[1] num.years <- length(unique(sipnet.output$year)) years <- unique(sipnet.output$year) out.day <- length(which(sipnet.output$year == years[1] & sipnet.output$day == start.day)) timestep.s <- 86400 / out.day - - + + ### Loop over years in SIPNET output to create separate netCDF outputs for (y in years) { if (file.exists(file.path(outdir, paste(y, "nc", sep = ".")))) { next } print(paste("---- Processing year: ", y)) # turn on for debugging - + ## Subset data for processing sub.sipnet.output <- subset(sipnet.output, year == y) sub.sipnet.output.dims <- dim(sub.sipnet.output) dayfrac <- 1 / out.day step <- seq(0, 0.99, dayfrac) - + ## Setup outputs for netCDF file in appropriate units output <- list() output[[1]] <- (sub.sipnet.output$gpp * 0.001) / timestep.s # GPP in kgC/m2/s + output[[1]] <- (sub.sipnet.output$gpp * 0.001) / timestep.s # GPP in kgC/m2/s ## output[[2]] <- (sub.sipnet.output$npp*0.001) / timestep.s # NPP in kgC/m2/s. Internal SIPNET ## calculation - output[[2]] <- (sub.sipnet.output$gpp * 0.001) / timestep.s - ((sub.sipnet.output$rAboveground * + output[[2]] <- (sub.sipnet.output$gpp * 0.001) / timestep.s - ((sub.sipnet.output$rAboveground * 0.001) / timestep.s + (sub.sipnet.output$rRoot * 0.001) / timestep.s) # NPP in kgC/m2/s. Post SIPNET calculation output[[3]] <- (sub.sipnet.output$rtot * 0.001) / timestep.s # Total Respiration in kgC/m2/s - output[[4]] <- (sub.sipnet.output$rAboveground * 0.001) / timestep.s + (sub.sipnet.output$rRoot * + output[[4]] <- (sub.sipnet.output$rAboveground * 0.001) / timestep.s + (sub.sipnet.output$rRoot * 0.001) / timestep.s # Autotrophic Respiration in kgC/m2/s output[[5]] <- ((sub.sipnet.output$rSoil - sub.sipnet.output$rRoot) * 0.001) / timestep.s # Heterotrophic Respiration in kgC/m2/s output[[6]] <- (sub.sipnet.output$rSoil * 0.001) / timestep.s # Soil Respiration in kgC/m2/s @@ -65,7 +66,7 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, # output[[7]] <- rep(-999,sipnet.output.dims[1]) # CarbPools output[[8]] <- (sub.sipnet.output$plantWoodC * 0.001) # Above ground wood kgC/m2 output[[9]] <- (sub.sipnet.output$plantLeafC * 0.001) # Leaf C kgC/m2 - output[[10]] <- (sub.sipnet.output$plantWoodC * 0.001) + (sub.sipnet.output$plantLeafC * 0.001) + + output[[10]] <- (sub.sipnet.output$plantWoodC * 0.001) + (sub.sipnet.output$plantLeafC * 0.001) + (sub.sipnet.output$coarseRootC * 0.001) + (sub.sipnet.output$fineRootC * 0.001) # Total living C kgC/m2 output[[11]] <- (sub.sipnet.output$soil * 0.001) + (sub.sipnet.output$litter * 0.001) # Total soil C kgC/m2 if (revision == "r136") { @@ -74,8 +75,8 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, ## *** NOTE : npp in the sipnet output file is actually evapotranspiration, this is due to a bug in sipnet.c : *** ## *** it says "npp" in the header (written by L774) but the values being written are trackers.evapotranspiration (L806) *** ## evapotranspiration in SIPNET is cm^3 water per cm^2 of area, to convert it to latent heat units W/m2 multiply with : - ## 0.01 (cm2m) * 1000 (water density, kg m-3) * latent heat of vaporization (J kg-1) - ## latent heat of vaporization is not constant and it varies slightly with temperature, get.lv() returns 2.5e6 J kg-1 by default + ## 0.01 (cm2m) * 1000 (water density, kg m-3) * latent heat of vaporization (J kg-1) + ## latent heat of vaporization is not constant and it varies slightly with temperature, get.lv() returns 2.5e6 J kg-1 by default output[[12]] <- (sub.sipnet.output$npp * 10 * PEcAn.data.atmosphere::get.lv()) / timestep.s # Qle W/m2 } output[[13]] <- (sub.sipnet.output$fluxestranspiration * 10) / timestep.s # Transpiration kgW/m2/s @@ -83,7 +84,7 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, output[[15]] <- (sub.sipnet.output$soilWetnessFrac) # Fractional soil wetness output[[16]] <- (sub.sipnet.output$snow * 10) # SWE output[[17]] <- sub.sipnet.output$litter * 0.001 ## litter kgC/m2 - + #calculate LAI for standard output param <- read.table(file.path(gsub(pattern = "/out/", replacement = "/run/", x = outdir), @@ -92,25 +93,25 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, leafC <- 0.48 SLA <- 1000 * leafC / param[id, 2] #SLA, m2/kgC output[[18]] <- output[[9]] * SLA # LAI - - + + # ******************** Declare netCDF variables ********************# - t <- ncdf4::ncdim_def(name = "time", - units = paste0("days since ", y, "-01-01 00:00:00"), + t <- ncdf4::ncdim_def(name = "time", + units = paste0("days since ", y, "-01-01 00:00:00"), vals = sub.sipnet.output$day - 1 + (sub.sipnet.output$time/24), - calendar = "standard", + calendar = "standard", unlim = TRUE) lat <- ncdf4::ncdim_def("lat", "degrees_north", vals = as.numeric(sitelat), longname = "station_latitude") lon <- ncdf4::ncdim_def("lon", "degrees_east", vals = as.numeric(sitelon), longname = "station_longitude") dims <- list(lon = lon, lat = lat, time = t) - + ## ***** Need to dynamically update the UTC offset here ***** - + for (i in seq_along(output)) { - if (length(output[[i]]) == 0) + if (length(output[[i]]) == 0) output[[i]] <- rep(-999, length(t$vals)) } - + mstmipvar <- PEcAn.utils::mstmipvar nc_var <- list() nc_var[[1]] <- PEcAn.utils::to_ncvar("GPP", dims) @@ -118,7 +119,7 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, nc_var[[3]] <- PEcAn.utils::to_ncvar("TotalResp", dims) nc_var[[4]] <- PEcAn.utils::to_ncvar("AutoResp", dims) nc_var[[5]] <- PEcAn.utils::to_ncvar("HeteroResp", dims) - nc_var[[6]] <- ncdf4::ncvar_def("SoilResp", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, + nc_var[[6]] <- ncdf4::ncvar_def("SoilResp", units = "kg C m-2 s-1", dim = list(lon, lat, t), missval = -999, longname = "Soil Respiration") #need to figure out standard variable for this output nc_var[[7]] <- PEcAn.utils::to_ncvar("NEE", dims) # nc_var[[7]] <- mstmipvar('CarbPools', lat, lon, t, NA) @@ -133,9 +134,9 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, nc_var[[16]] <- PEcAn.utils::to_ncvar("SWE", dims) nc_var[[17]] <- PEcAn.utils::to_ncvar("litter_carbon_content", dims) nc_var[[18]] <- PEcAn.utils::to_ncvar("LAI", dims) - + # ******************** Declare netCDF variables ********************# - + ### Output netCDF data nc <- ncdf4::nc_create(file.path(outdir, paste(y, "nc", sep = ".")), nc_var) varfile <- file(file.path(outdir, paste(y, "nc", "var", sep = ".")), "w") @@ -146,9 +147,9 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, } close(varfile) ncdf4::nc_close(nc) - + } ### End of year loop - + ## Delete raw output, if requested if (delete.raw) { file.remove(sipnet.out.file) diff --git a/models/sipnet/R/write.configs.SIPNET.R b/models/sipnet/R/write.configs.SIPNET.R index 4ad40cd7493..73fbd9d7956 100644 --- a/models/sipnet/R/write.configs.SIPNET.R +++ b/models/sipnet/R/write.configs.SIPNET.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -13,13 +13,13 @@ ##' @title Writes a configuration files for SIPNET model ##' @export ##' @author Michael Dietze -write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs = NULL, IC = NULL, +write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs = NULL, IC = NULL, restart = NULL, spinup = NULL) { ### WRITE sipnet.in template.in <- system.file("sipnet.in", package = "PEcAn.SIPNET") config.text <- readLines(con = template.in, n = -1) writeLines(config.text, con = file.path(settings$rundir, run.id, "sipnet.in")) - + ### WRITE *.clim template.clim <- settings$run$input$met$path ## read from settings #typo in inputs? if (!is.null(inputs)) { @@ -28,7 +28,7 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs template.clim <- inputs$met$path } } - + # find out where to write run/ouput rundir <- file.path(settings$host$rundir, as.character(run.id)) outdir <- file.path(settings$host$outdir, as.character(run.id)) @@ -36,14 +36,14 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs rundir <- file.path(settings$rundir, as.character(run.id)) outdir <- file.path(settings$modeloutdir, as.character(run.id)) } - + # create launch script (which will create symlink) if (!is.null(settings$model$jobtemplate) && file.exists(settings$model$jobtemplate)) { jobsh <- readLines(con = settings$model$jobtemplate, n = -1) } else { jobsh <- readLines(con = system.file("template.job", package = "PEcAn.SIPNET"), n = -1) } - + # create host specific setttings hostsetup <- "" if (!is.null(settings$model$prerun)) { @@ -52,7 +52,7 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs if (!is.null(settings$host$prerun)) { hostsetup <- paste(hostsetup, sep = "\n", paste(settings$host$prerun, collapse = "\n")) } - + hostteardown <- "" if (!is.null(settings$model$postrun)) { hostteardown <- paste(hostteardown, sep = "\n", paste(settings$model$postrun, collapse = "\n")) @@ -60,55 +60,55 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs if (!is.null(settings$host$postrun)) { hostteardown <- paste(hostteardown, sep = "\n", paste(settings$host$postrun, collapse = "\n")) } - + # create job.sh jobsh <- gsub("@HOST_SETUP@", hostsetup, jobsh) jobsh <- gsub("@HOST_TEARDOWN@", hostteardown, jobsh) - + jobsh <- gsub("@SITE_LAT@", settings$run$site$lat, jobsh) jobsh <- gsub("@SITE_LON@", settings$run$site$lon, jobsh) jobsh <- gsub("@SITE_MET@", template.clim, jobsh) - + jobsh <- gsub("@OUTDIR@", outdir, jobsh) jobsh <- gsub("@RUNDIR@", rundir, jobsh) - + jobsh <- gsub("@START_DATE@", settings$run$start.date, jobsh) jobsh <- gsub("@END_DATE@", settings$run$end.date, jobsh) - + jobsh <- gsub("@BINARY@", settings$model$binary, jobsh) jobsh <- gsub("@REVISION@", settings$model$revision, jobsh) - + if (is.null(settings$model$delete.raw)) { settings$model$delete.raw <- FALSE } jobsh <- gsub("@DELETE.RAW@", settings$model$delete.raw, jobsh) - + writeLines(jobsh, con = file.path(settings$rundir, run.id, "job.sh")) Sys.chmod(file.path(settings$rundir, run.id, "job.sh")) - + ### WRITE *.param-spatial template.paramSpatial <- system.file("template.param-spatial", package = "PEcAn.SIPNET") file.copy(template.paramSpatial, file.path(settings$rundir, run.id, "sipnet.param-spatial")) - + ### WRITE *.param template.param <- system.file("template.param", package = "PEcAn.SIPNET") if ("default.param" %in% names(settings$model)) { template.param <- settings$model$default.param } - + param <- read.table(template.param) - - - + + + #### write run-specific PFT parameters here #### Get parameters being handled by PEcAn for (pft in seq_along(trait.values)) { pft.traits <- unlist(trait.values[[pft]]) pft.names <- names(pft.traits) - + ## Append/replace params specified as constants constant.traits <- unlist(defaults[[1]]$constants) constant.names <- names(constant.traits) - + # Replace matches for (i in seq_along(constant.traits)) { ind <- match(constant.names[i], pft.names) @@ -121,13 +121,13 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs pft.traits[ind] <- constant.traits[i] } } - + # Remove NAs. Constants may be specified as NA to request template defaults. Note that it is 'NA' # (character) not actual NA due to being read in as XML pft.names <- pft.names[pft.traits != "NA" & !is.na(pft.traits)] pft.traits <- pft.traits[pft.traits != "NA" & !is.na(pft.traits)] pft.traits <- as.numeric(pft.traits) - + # Leaf carbon concentration leafC <- 0.48 #0.5 if ("leafC" %in% pft.names) { @@ -135,7 +135,7 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs id <- which(param[, 1] == "cFracLeaf") param[id, 2] <- leafC * 0.01 # convert to percentage from 0 to 1 } - + # Specific leaf area converted to SLW SLA <- NA id <- which(param[, 1] == "leafCSpWt") @@ -145,7 +145,7 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs } else { SLA <- 1000 * leafC / param[id, 2] } - + # Maximum photosynthesis Amax <- NA id <- which(param[, 1] == "aMax") @@ -155,51 +155,51 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs } else { Amax <- param[id, 2] * SLA } - + # Daily fraction of maximum photosynthesis if ("AmaxFrac" %in% pft.names) { param[which(param[, 1] == "aMaxFrac"), 2] <- pft.traits[which(pft.names == "AmaxFrac")] } - + ### Canopy extinction coefficiet (k) if ("extinction_coefficient" %in% pft.names) { param[which(param[, 1] == "attenuation"), 2] <- pft.traits[which(pft.names == "extinction_coefficient")] } - + # Leaf respiration rate converted to baseFolRespFrac if ("leaf_respiration_rate_m2" %in% pft.names) { Rd <- pft.traits[which(pft.names == "leaf_respiration_rate_m2")] id <- which(param[, 1] == "baseFolRespFrac") param[id, 2] <- max(min(Rd/Amax, 1), 0) } - + # Low temp threshold for photosynethsis if ("Vm_low_temp" %in% pft.names) { param[which(param[, 1] == "psnTMin"), 2] <- pft.traits[which(pft.names == "Vm_low_temp")] } - + # Opt. temp for photosynthesis if ("psnTOpt" %in% pft.names) { param[which(param[, 1] == "psnTOpt"), 2] <- pft.traits[which(pft.names == "psnTOpt")] } - + # Growth respiration factor (fraction of GPP) if ("growth_resp_factor" %in% pft.names) { param[which(param[, 1] == "growthRespFrac"), 2] <- pft.traits[which(pft.names == "growth_resp_factor")] } - + ### !!! NOT YET USED #Jmax = NA #if("Jmax" %in% pft.names){ # Jmax = pft.traits[which(pft.names == 'Jmax')] ### Using Jmax scaled to 25 degC. Maybe not be the best approach #} - + #alpha = NA #if("quantum_efficiency" %in% pft.names){ # alpha = pft.traits[which(pft.names == 'quantum_efficiency')] #} - + # Half saturation of PAR. PAR at which photosynthesis occurs at 1/2 theoretical maximum (Einsteins * m^-2 ground area * day^-1). #if(!is.na(Jmax) & !is.na(alpha)){ # param[which(param[,1] == "halfSatPar"),2] = Jmax/(2*alpha) @@ -208,65 +208,65 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs ### Once halfSatPar is calculated, need to remove Jmax and quantum_efficiency from param list so they are not included in SA #} ### !!! - + # Half saturation of PAR. PAR at which photosynthesis occurs at 1/2 theoretical maximum (Einsteins * m^-2 ground area * day^-1). # Temporary implementation until above is working. if ("half_saturation_PAR" %in% pft.names) { param[which(param[, 1] == "halfSatPar"), 2] <- pft.traits[which(pft.names == "half_saturation_PAR")] } - + # Ball-berry slomatal slope parameter m if ("stomatal_slope.BB" %in% pft.names) { id <- which(param[, 1] == "m_ballBerry") param[id, 2] <- pft.traits[which(pft.names == "stomatal_slope.BB")] } - + # Slope of VPD–photosynthesis relationship. dVpd = 1 - dVpdSlope * vpd^dVpdExp if ("dVPDSlope" %in% pft.names) { param[which(param[, 1] == "dVpdSlope"), 2] <- pft.traits[which(pft.names == "dVPDSlope")] } - + # VPD–water use efficiency relationship. dVpd = 1 - dVpdSlope * vpd^dVpdExp if ("dVpdExp" %in% pft.names) { param[which(param[, 1] == "dVpdExp"), 2] <- pft.traits[which(pft.names == "dVpdExp")] } - + # Leaf turnover rate average turnover rate of leaves, in fraction per day NOTE: read in as # per-year rate! if ("leaf_turnover_rate" %in% pft.names) { param[which(param[, 1] == "leafTurnoverRate"), 2] <- pft.traits[which(pft.names == "leaf_turnover_rate")] } - + # vegetation respiration Q10. if ("veg_respiration_Q10" %in% pft.names) { param[which(param[, 1] == "vegRespQ10"), 2] <- pft.traits[which(pft.names == "veg_respiration_Q10")] } - - # Base vegetation respiration. vegetation maintenance respiration at 0 degrees C (g C respired * g^-1 plant C * day^-1) + + # Base vegetation respiration. vegetation maintenance respiration at 0 degrees C (g C respired * g^-1 plant C * day^-1) # NOTE: only counts plant wood C - leaves handled elsewhere (both above and below-ground: assumed for now to have same resp. rate) # NOTE: read in as per-year rate! if ("stem_respiration_rate" %in% pft.names) { vegRespQ10 <- param[which(param[, 1] == "vegRespQ10"), 2] id <- which(param[, 1] == "baseVegResp") ## Convert from umols CO2 kg s-1 to gC g day-1 - stem_resp_g <- (((pft.traits[which(pft.names == "stem_respiration_rate")]) * + stem_resp_g <- (((pft.traits[which(pft.names == "stem_respiration_rate")]) * (44.0096 / 1e+06) * (12.01 / 44.0096)) / 1000) * 86400 ## use Q10 to convert stem resp from reference of 25C to 0C param[id,2] = ## pft.traits[which(pft.names=='stem_respiration_rate')]*vegRespQ10^(-25/10) param[id, 2] <- stem_resp_g * vegRespQ10^(-25/10) } - + # turnover of fine roots (per year rate) if ("root_turnover_rate" %in% pft.names) { id <- which(param[, 1] == "fineRootTurnoverRate") param[id, 2] <- pft.traits[which(pft.names == "root_turnover_rate")] } - + # fine root respiration Q10 if ("fine_root_respiration_Q10" %in% pft.names) { param[which(param[, 1] == "fineRootQ10"), 2] <- pft.traits[which(pft.names == "fine_root_respiration_Q10")] } - + # base respiration rate of fine roots (per year rate) if ("root_respiration_rate" %in% pft.names) { fineRootQ10 <- param[which(param[, 1] == "fineRootQ10"), 2] @@ -278,12 +278,12 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs ## pft.traits[which(pft.names=='root_respiration_rate')]*fineRootQ10^(-25/10) param[id, 2] <- root_resp_rate_g * fineRootQ10 ^ (-25 / 10) } - + # coarse root respiration Q10 if ("coarse_root_respiration_Q10" %in% pft.names) { param[which(param[, 1] == "coarseRootQ10"), 2] <- pft.traits[which(pft.names == "coarse_root_respiration_Q10")] } - + ### ----- Soil parameters soil respiration Q10. if ("soil_respiration_Q10" %in% pft.names) { param[which(param[, 1] == "soilRespQ10"), 2] <- pft.traits[which(pft.names == "soil_respiration_Q10")] @@ -305,24 +305,24 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs if ("soilWHC" %in% pft.names) { param[which(param[, 1] == "soilWHC"), 2] <- pft.traits[which(pft.names == "soilWHC")] } - + ### ----- Phenology parameters GDD leaf on if ("GDD" %in% pft.names) { param[which(param[, 1] == "gddLeafOn"), 2] <- pft.traits[which(pft.names == "GDD")] } - + # Fraction of leaf fall per year (should be 1 for decid) if ("fracLeafFall" %in% pft.names) { param[which(param[, 1] == "fracLeafFall"), 2] <- pft.traits[which(pft.names == "fracLeafFall")] } - + # Leaf growth. Amount of C added to the leaf during the greenup period if ("leafGrowth" %in% pft.names) { param[which(param[, 1] == "leafGrowth"), 2] <- pft.traits[which(pft.names == "leafGrowth")] } } ## end loop over PFTS ####### end parameter update - + #### write INITIAL CONDITIONS here #### if (!is.null(IC)) { ic.names <- names(IC) @@ -362,12 +362,12 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs else if (!is.null(settings$run$inputs$poolinitcond$path)) { IC.path <- settings$run$inputs$poolinitcond$path IC.pools <- PEcAn.data.land::prepare_pools(IC.path, constants = list(sla = SLA)) - + if(!is.null(IC.pools)){ IC.nc <- ncdf4::nc_open(IC.path) #for additional variables specific to SIPNET ## plantWoodInit gC/m2 if ("wood" %in% names(IC.pools)) { - param[which(param[, 1] == "plantWoodInit"), 2] <- IC.pools$wood * 1000 #from PEcAn standard AbvGrndWood kgC/m2 + param[which(param[, 1] == "plantWoodInit"), 2] <- udunits2:ud.convert(IC.pools$wood, "kg m-2", "g m-2") } ## laiInit m2/m2 lai <- try(ncdf4::ncvar_get(IC.nc,"LAI"),silent = TRUE) @@ -376,11 +376,11 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs } ## litterInit gC/m2 if ("litter" %in% names(IC.pools)) { - param[which(param[, 1] == "litterInit"), 2] <- IC.pools$litter * 1000 #from PEcAn standard litter_carbon_content kg/m2 + param[which(param[, 1] == "litterInit"), 2] <- udunits2::ud.convert(IC.pools$litter, 'kg m-2', 'g m-2') # BETY: kgC m-2 } ## soilInit gC/m2 if ("soil" %in% names(IC.pools)) { - param[which(param[, 1] == "soilInit"), 2] <- sum(IC.pools$soil) * 1000 #from PEcAn standard TotSoilCarb kg C/m2 + param[which(param[, 1] == "soilInit"), 2] <- udunits2::ud.convert(sum(IC.pools$soil), 'kg m-2', 'g m-2') # BETY: kgC m-2 } ## soilWFracInit fraction soilWFrac <- try(ncdf4::ncvar_get(IC.nc,"SoilMoistFrac"),silent = TRUE) @@ -389,16 +389,16 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs } ## litterWFracInit fraction litterWFrac <- soilWFrac - - ## snowInit cm water equivalent + + ## snowInit cm water equivalent (cm = g / cm2 because 1 g water = 1 cm3 water) snow = try(ncdf4::ncvar_get(IC.nc,"SWE"),silent = TRUE) if (!is.na(snow) && is.numeric(snow)) { - param[which(param[, 1] == "snowInit"), 2] <- snow*0.1 #from PEcAn standard SWE kg/m2 (1kg = 1mm) + param[which(param[, 1] == "snowInit"), 2] <- udunits2::ud.convert(snow, "kg m-2", "g cm-2") # BETY: kg m-2 } ## microbeInit mgC/g soil microbe <- try(ncdf4::ncvar_get(IC.nc,"Microbial Biomass C"),silent = TRUE) if (!is.na(microbe) && is.numeric(microbe)) { - param[which(param[, 1] == "microbeInit"), 2] <- microbe * .001 #BETY Microbial Biomass C mg C kg-1 soil + param[which(param[, 1] == "microbeInit"), 2] <- udunits2::ud.convert(microbe, "mg kg-1", "mg g-1") #BETY: mg microbial C kg-1 soil } ncdf4::nc_close(IC.nc) }else{ @@ -407,8 +407,8 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs }else{ #some stuff about IC file that we can give in lieu of actual ICs } - - write.table(param, file.path(settings$rundir, run.id, "sipnet.param"), row.names = FALSE, col.names = FALSE, + + write.table(param, file.path(settings$rundir, run.id, "sipnet.param"), row.names = FALSE, col.names = FALSE, quote = FALSE) } # write.config.SIPNET @@ -420,13 +420,13 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs ##' @name remove.config.SIPNET ##' @title Clear out previous SIPNET config and parameter files. ##' @param main.outdir Primary PEcAn output directory (will be depreciated) -##' @param settings PEcAn settings file +##' @param settings PEcAn settings file ##' @return nothing, removes config files as side effect ##' @export ##' ##' @author Shawn Serbin, David LeBauer remove.config.SIPNET <- function(main.outdir, settings) { - + ### Remove files on localhost if (settings$host$name == "localhost") { files <- paste0(settings$outdir, list.files(path = settings$outdir, recursive = FALSE)) # Need to change this to the run folder when implemented @@ -437,7 +437,7 @@ remove.config.SIPNET <- function(main.outdir, settings) { files <- files[-grep(pft.dir, files)] # Keep pft folder # file.remove(files,recursive=TRUE) system(paste("rm -r ", files, sep = "", collapse = " "), ignore.stderr = TRUE) # remove files/dirs - + ### On remote host } else { print("*** WARNING: Removal of files on remote host not yet implemented ***") diff --git a/models/sipnet/R/write_restart.SIPNET.R b/models/sipnet/R/write_restart.SIPNET.R index bedd1c34642..bbae720edbe 100644 --- a/models/sipnet/R/write_restart.SIPNET.R +++ b/models/sipnet/R/write_restart.SIPNET.R @@ -1,7 +1,7 @@ #------------------------------------------------------------------------------- # Copyright (c) 2012 University of Illinois, NCSA. # All rights reserved. This program and the accompanying materials -# are made available under the terms of the +# are made available under the terms of the # University of Illinois/NCSA Open Source License # which accompanies this distribution, and is available at # http://opensource.ncsa.illinois.edu/license.html @@ -10,7 +10,7 @@ ##' @title write_restart.SIPNET ##' @name write_restart.SIPNET ##' @author Ann Raiho \email{araiho@@nd.edu} -##' +##' ##' @param outdir output directory ##' @param runid run ID ##' @param time year that is being read @@ -21,89 +21,89 @@ ##' @param sample_parameters ##' @param trait.values ##' @param met -##' +##' ##' @description Write restart files for SIPNET -##' +##' ##' @return NONE ##' @export -write_restart.SIPNET <- function(outdir, runid, start.time, stop.time, settings, new.state, +write_restart.SIPNET <- function(outdir, runid, start.time, stop.time, settings, new.state, RENAME = TRUE, new.params = FALSE, inputs) { - + rundir <- settings$host$rundir variables <- colnames(new.state) - + if (RENAME) { - file.rename(file.path(outdir, runid, "sipnet.out"), + file.rename(file.path(outdir, runid, "sipnet.out"), file.path(outdir, runid, paste0("sipnet.", as.Date(start.time), ".out"))) system(paste("rm", file.path(rundir, runid, "sipnet.clim"))) } else { print(paste("Files not renamed -- Need to rerun year", start.time, "before next time step")) } - + settings$run$start.date <- start.time settings$run$end.date <- stop.time - + ## Converting to sipnet units prior.sla <- new.params[[which(names(new.params) != "soil")[1]]]$SLA[1] unit.conv <- 2 * (10000 / 1) * (1 / 1000) * (3.154 * 10^7) # kgC/m2/s -> Mg/ha/yr - + analysis.save <- list() - + if ("NPP" %in% variables) { analysis.save[[1]] <- new.state$NPP #*unit.conv -> Mg/ha/yr names(analysis.save[[1]]) <- c("NPP") } - + if ("AbvGrndWood" %in% variables) { analysis.save[[2]] <- udunits2::ud.convert(new.state$AbvGrndWood, "kg/m^2", "g/m^2")#no (1-.2-.2) because that's on sipnet side names(analysis.save[[2]]) <- c("plantWood") } - + if ("LeafC" %in% variables) { analysis.save[[3]] <- new.state$LeafC * prior.sla * 2 ## kgC/m2*m2/kg*2kg/kgC -> m2/m2 - if (new.state$LeafC < 0) + if (new.state$LeafC < 0) analysis.save[[3]] <- 0 names(analysis.save[[3]]) <- c("lai") } - + if ("Litter" %in% variables) { - analysis.save[[4]] <- new.state$Litter * 1000 ##kgC/m2 -> gC/m2 - if (new.state$Litter < 0) + analysis.save[[4]] <- udunits2::ud.convert(new.state$Litter, 'kg m-2', 'g m-2') # kgC/m2 -> gC/m2 + if (new.state$Litter < 0) analysis.save[[4]] <- 0 names(analysis.save[[4]]) <- c("litter") } - + if ("TotSoilCarb" %in% variables) { - analysis.save[[5]] <- new.state$TotSoilCarb * 1000 ##kgC/m2 -> gC/m2 + analysis.save[[5]] <- udunits2::ud.convert(new.state$TotSoilCarb, 'kg m-2', 'g m-2') # kgC/m2 -> gC/m2 names(analysis.save[[5]]) <- c("soil") } - + if ("SoilMoistFrac" %in% variables) { analysis.save[[6]] <- new.state$SoilMoistFrac ## unitless - if (new.state$SoilMoistFrac < 0 | new.state$SoilMoistFrac > 1) + if (new.state$SoilMoistFrac < 0 | new.state$SoilMoistFrac > 1) analysis.save[[6]] <- 0.5 names(analysis.save[[6]]) <- c("litterWFrac") - + analysis.save[[7]] <- new.state$SoilMoistFrac ## unitless - if (new.state$SoilMoistFrac < 0 | new.state$SoilMoistFrac > 1) + if (new.state$SoilMoistFrac < 0 | new.state$SoilMoistFrac > 1) analysis.save[[7]] <- 0.5 names(analysis.save[[7]]) <- c("soilWFrac") } - + if ("SWE" %in% variables) { analysis.save[[8]] <- new.state$SWE ## unitless - if (new.state$SWE < 0) + if (new.state$SWE < 0) new.state$SWE <- 0 names(analysis.save[[8]]) <- c("snow") } - + analysis.save.mat <- data.frame(matrix(unlist(analysis.save, use.names = TRUE), nrow = 1)) colnames(analysis.save.mat) <- names(unlist(analysis.save)) - - do.call(write.config.SIPNET, args = list(defaults = NULL, - trait.values = new.params, - settings = settings, - run.id = runid, + + do.call(write.config.SIPNET, args = list(defaults = NULL, + trait.values = new.params, + settings = settings, + run.id = runid, inputs = inputs, IC = analysis.save.mat)) print(runid) diff --git a/modules/data.atmosphere/R/download.MsTMIP_NARR.R b/modules/data.atmosphere/R/download.MsTMIP_NARR.R index e6b7a5f97bd..54ee7ece48d 100644 --- a/modules/data.atmosphere/R/download.MsTMIP_NARR.R +++ b/modules/data.atmosphere/R/download.MsTMIP_NARR.R @@ -49,7 +49,7 @@ download.MsTMIP_NARR <- function(outfolder, start_date, end_date, site_id, lat.i for (i in seq_len(rows)) { year <- ylist[i] - ntime <- ifelse(lubridate::leap_year(year), 2923, 2919) ## ANS: Where do these numbers come from? + ntime <- udunits2::ud.convert(PEcAn.utils::days_in_year(year), "days", "hours") / 3 - 1 # Number of 3 hour timesteps in one year loc.file <- file.path(outfolder, paste("MsTMIP_NARR", year, "nc", sep = ".")) diff --git a/modules/data.atmosphere/R/met2CF.ALMA.R b/modules/data.atmosphere/R/met2CF.ALMA.R index 6a851ae5472..f72bcdce879 100644 --- a/modules/data.atmosphere/R/met2CF.ALMA.R +++ b/modules/data.atmosphere/R/met2CF.ALMA.R @@ -125,7 +125,7 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end # Open new file and fill in air_temperature print(year) - var <- ncdf4::ncvar_def(name = "air_temperature", units = "degrees K", dim = dim, + var <- ncdf4::ncvar_def(name = "air_temperature", units = "K", dim = dim, missval = as.numeric(-9999)) nc2 <- ncdf4::nc_create(filename = new.file, vars = var, verbose = verbose) ncdf4::ncvar_put(nc = nc2, varid = "air_temperature", vals = met[["tair"]]) @@ -304,7 +304,7 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l ncvar_put(nc = nc2, varid = "longitude", vals = rep(latlon[2], tdim$len)) # air_temperature - insertPmet(met[["tair"]], nc2 = nc2, var2 = "air_temperature", units2 = "degrees K", dim2 = dim, + insertPmet(met[["tair"]], nc2 = nc2, var2 = "air_temperature", units2 = "K", dim2 = dim, verbose = verbose) # air_pressure @@ -495,7 +495,7 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove copyvals(nc1 = nc1, var1 = "TA", nc2 = nc2, - var2 = "air_temperature", units2 = "degrees K", + var2 = "air_temperature", units2 = "K", dim2 = dim, conv = function(x) { udunits2::ud.convert(x, "degC", "K") }, verbose = verbose) @@ -506,7 +506,7 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove nc2 = nc2, var2 = "air_pressure", units2 = "Pa", dim2 = dim, - conv = function(x) { x * 1000 }, + conv = function(x) { udunits2::ud.convert(x, 'kPa', 'Pa') }, verbose = verbose) # convert CO2 to mole_fraction_of_carbon_dioxide_in_air @@ -514,14 +514,14 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove var1 = "CO2", nc2 = nc2, var2 = "mole_fraction_of_carbon_dioxide_in_air", units2 = "mole/mole", - dim2 = dim, conv = function(x) { x * 1e+06 }, + dim2 = dim, conv = function(x) { udunits2::ud.convert(x, "mol/mol", "ppm") }, verbose = verbose) # convert TS1 to soil_temperature copyvals(nc1 = nc1, var1 = "TS1", nc2 = nc2, - var2 = "soil_temperature", units2 = "degrees K", + var2 = "soil_temperature", units2 = "K", dim2 = dim, conv = function(x) { udunits2::ud.convert(x, "degC", "K") }, verbose = verbose) @@ -576,7 +576,7 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove nc2 = nc2, var2 = "surface_downwelling_photosynthetic_photon_flux_in_air", units2 = "mol m-2 s-1", dim2 = dim, - conv = function(x) { x / 1e+06 }, + conv = function(x) { udunits2::ud.convert(x, "umol m-2 s-1", "mol m-2 s-1") }, verbose = verbose) # copy WD to wind_direction (not official CF) diff --git a/modules/data.atmosphere/R/met2CF.Ameriflux.R b/modules/data.atmosphere/R/met2CF.Ameriflux.R index 82b3ffb3337..e6aba96df4c 100644 --- a/modules/data.atmosphere/R/met2CF.Ameriflux.R +++ b/modules/data.atmosphere/R/met2CF.Ameriflux.R @@ -191,7 +191,7 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date # convert TA to air_temperature copyvals(nc1 = nc1, var1 = "TA", nc2 = nc2, - var2 = "air_temperature", units2 = "degrees K", + var2 = "air_temperature", units2 = "K", dim2 = dim, conv = function(x) { udunits2::ud.convert(x, "degC", "K") }, verbose = verbose) @@ -199,19 +199,20 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date copyvals(nc1 = nc1, var1 = "PRESS", nc2 = nc2, var2 = "air_pressure", units2 = "Pa", dim2 = dim, - conv = function(x) { x * 1000 }, + conv = function(x) { udunits2::ud.convert(x, "kPa", "Pa") }, verbose = verbose) # convert CO2 to mole_fraction_of_carbon_dioxide_in_air copyvals(nc1 = nc1, var1 = "CO2", nc2 = nc2, var2 = "mole_fraction_of_carbon_dioxide_in_air", units2 = "mole/mole", - dim2 = dim, conv = function(x) { x / 1e+06 }, + dim2 = dim, + conv = function(x) { udunits2::ud.convert(x, "ppm", "mol/mol") }, verbose = verbose) # convert TS1 to soil_temperature copyvals(nc1 = nc1, var1 = "TS1", nc2 = nc2, - var2 = "soil_temperature", units2 = "degrees K", + var2 = "soil_temperature", units2 = "K", dim2 = dim, conv = function(x) { udunits2::ud.convert(x, "degC", "K") }, verbose = verbose) @@ -225,7 +226,8 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date # NA copyvals(nc1 = nc1, var1 = "VPD", nc2 = nc2, var2 = "water_vapor_saturation_deficit", units2 = "Pa", - dim2 = dim, conv = function(x) { ifelse(x < 0, NA, x * 1000) }, + dim2 = dim, + conv = function(x) { ifelse(x < 0, NA, udunits2::ud.convert(x, "kPa", "Pa")) }, verbose = verbose) # copy Rg to surface_downwelling_shortwave_flux_in_air @@ -244,7 +246,7 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date copyvals(nc1 = nc1, var1 = "PAR", nc2 = nc2, var2 = "surface_downwelling_photosynthetic_photon_flux_in_air", units2 = "mol m-2 s-1", dim2 = dim, - conv = function(x) { x / 1e+06 }, + conv = function(x) { udunits2::ud.convert(x, "umol m-2 s-1", "mol m-2 s-1") }, verbose = verbose) # copy WD to wind_direction (not official CF) diff --git a/modules/data.atmosphere/R/metgapfill.R b/modules/data.atmosphere/R/metgapfill.R index 730fe43d550..7d2ba0b6f82 100644 --- a/modules/data.atmosphere/R/metgapfill.R +++ b/modules/data.atmosphere/R/metgapfill.R @@ -331,7 +331,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst EddyData.F["Tair"] <- udunits2::ud.convert(EddyData.F["Tair"], "K", "degC") EddyData.F["Tair"] <- EddyData.F["Tair"] EddyData.F["Ts1"] <- udunits2::ud.convert(EddyData.F["Ts1"], "K", "degC") - EddyData.F["VPD"] <- EddyData.F["VPD"] / 1000 + EddyData.F["VPD"] <- udunits2::ud.convert(EddyData.F["VPD"], "Pa", "kPa") ## Optional need: ## Compute VPD EddyData.F <- cbind(EddyData.F,VPD=fCalcVPDfromRHandTair(EddyData.F$rH, EddyData.F$Tair)) @@ -547,7 +547,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst ncvar_put(nc, varid = "soil_temperature", vals = Ts1_f) if (("VPD_f" %in% colnames(Extracted))) { - VPD_f <- Extracted[, "VPD_f"] * 1000 + VPD_f <- udunits2::ud.convert(Extracted[, "VPD_f"], "kPa", "Pa") } if (length(which(is.na(VPD_f))) > 0) { error <- c(error, "water_vapor_saturation_deficit") @@ -562,7 +562,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst co2_f <- Extracted[, "co2_f"] } co2_f[is.na(co2_f)] <- mean(co2, na.rm = TRUE) - co2_f[is.na(co2_f)] <- 380 / 1e+06 + co2_f[is.na(co2_f)] <- udunits2::ud.convert(380, "ppm", "mol/mol") if (length(which(is.na(co2_f))) > 0) { error <- c(error, "mole_fraction_of_carbon_dioxide_in_air") } From fa071c7f14b2e5300db46a51a9cb7f4fe5ce662f Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 5 Sep 2017 11:07:56 -0400 Subject: [PATCH 540/771] assim.batch: Fix ignored ensemble size argument --- modules/assim.batch/R/get.da.data.R | 1 - 1 file changed, 1 deletion(-) diff --git a/modules/assim.batch/R/get.da.data.R b/modules/assim.batch/R/get.da.data.R index af34225e2e4..ad13a3691c2 100644 --- a/modules/assim.batch/R/get.da.data.R +++ b/modules/assim.batch/R/get.da.data.R @@ -41,7 +41,6 @@ calculate.nee.L <- function(yeardoytime, model.i.nee, observed.flux, be, bu) { get.da.data <- function(out.dir, ameriflux.dir, years, be, bu, ensemble.size = 199) { - ensemble.size <- 500 load(paste(out.dir, "samples.Rdata", sep = "")) pfts <- names(ensemble.samples) From a56d81f29ecd38d0d0c84687b205079cca0bad3b Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Tue, 5 Sep 2017 11:19:40 -0400 Subject: [PATCH 541/771] a change --- models/gday/R/model2netcdf.GDAY.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/gday/R/model2netcdf.GDAY.R b/models/gday/R/model2netcdf.GDAY.R index c05931322c3..4fdfcfe1fa8 100644 --- a/models/gday/R/model2netcdf.GDAY.R +++ b/models/gday/R/model2netcdf.GDAY.R @@ -105,7 +105,7 @@ model2netcdf.GDAY <- function(outdir, sitelat, sitelon, start_date, end_date) { var[[10]] <- PEcAn.utils::to_ncvar("Evap", dims) var[[11]] <- PEcAn.utils::to_ncvar("TVeg", dims) - #var[[6]] <- PEcAn.utils::to_ncvar("LeafLitter", "kgC/m2/s", list(lon,lat,t), -999) + #var[[6]] <- PEcAn.utils::to_ncvar("LeafLitter", "kgC/m2/s", list(lon,lat,t), -999 ) #var[[7]] <- PEcAn.utils::to_ncvar("WoodyLitter", "kgC/m2/s", list(lon,lat,t), -999) #var[[8]] <- PEcAn.utils::to_ncvar("RootLitter", "kgC/m2/s", list(lon,lat,t), -999) #var[[9]] <- PEcAn.utils::to_ncvar("LeafBiomass", "kgC/m2", list(lon,lat,t), -999) From a6bd06822c1fb3b87e168aebdd20d35399cfba36 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 5 Sep 2017 10:23:18 -0500 Subject: [PATCH 542/771] Comments and style for #1615 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add more documentation on some parameters in align.met + adding the package before calls. Haven’t removed the library statements yet in case something is missing. --- modules/data.atmosphere/R/align_met.R | 48 ++++++++++----- .../data.atmosphere/R/debias_met_regression.R | 56 ++++++++--------- .../data.atmosphere/R/extract_local_CMIP5.R | 60 +++++++++---------- modules/data.atmosphere/man/align.met.Rd | 23 ++++++- 4 files changed, 112 insertions(+), 75 deletions(-) diff --git a/modules/data.atmosphere/R/align_met.R b/modules/data.atmosphere/R/align_met.R index 9e30e51f404..92e6c682248 100644 --- a/modules/data.atmosphere/R/align_met.R +++ b/modules/data.atmosphere/R/align_met.R @@ -12,6 +12,26 @@ ##' Note: can probably at borrow from or adapt align_data.R in Benchmarking module, but ##' it's too much of a black box at the moment. # ----------------------------------- +# Notes +# ----------------------------------- +##' @details 1. Assumes that both the training and source data are in *at least* daily resolution +##' and each dataset is in a consistent temporal resolution being read from a single file +##' (CF/Pecan format). For example, CMIP5 historical/p1000 runs where radiation drivers +##' are in monthly resolution and temperature is in daily will need to be reconciled using +##' one of the "met2CF" or "download" or "extract" functions +##' 2. Default file structure: Ensembles members for a given site or set of simes are housed +##' in a common folder with the site ID. Right now everything is based off of Christy's +##' PalEON ensemble ID scheme where the site ID is a character string (e.g. HARVARD) followed +##' the SOURCE data family (i.e. GCM) as a string and then the ensemble member ID as a number +##' (e.g. 001). For example, the file path for a single daily ensemble member for PalEON is: +##' "~/Desktop/Research/met_ensembles/data/met_ensembles/HARVARD/day/ensembles/bcc-csm1-1_004" +##' with each year in a separate netcdf file inside of it. +##' @return 2-layered list (stored in memory) containing the training and source data that are now matched +##' in temporal resolution have the specified number of ensemble members +##' - dat.train (training dataset) and dat.source (source data to be downscaled or bias-corrected) +##' are both lists that contain separate data frames for time indices and all available met +##' variables with ensemble members in columns +# ----------------------------------- # Parameters # ----------------------------------- ##' @param train.path - path to the dataset to be used to downscale the data @@ -21,7 +41,8 @@ ##' will be loaded. If not null, should be a vector of numbers (so you can skip ##' problematic years) ##' @param n.ens - number of ensemble members to generate and save -##' @param pair.mems - logical stating whether ensemble members should be paired +##' @param pair.mems - (not implemented) logical stating whether ensemble members should be paired in +##' the case where ensembles are being read in in both the training and source data ##' @param seed - specify seed so that random draws can be reproduced ##' @param verbose ##' @export @@ -42,11 +63,6 @@ # 1. dat.train # 2. dat.source # Sublist Layers: time, met variables -# ----------------------------------- -# Notes -# ----------------------------------- -# 1. This assumes that both the trian and source data are in *at least* daily resolution -# ----------------------------------- #---------------------------------------------------------------------- # Begin Function @@ -83,10 +99,10 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. for(i in 1:length(files.train)){ yr.now <- yrs.file[i] - ncT <- nc_open(file.path(train.path, files.train[i])) + ncT <- ncdf4::nc_open(file.path(train.path, files.train[i])) # Set up the time data frame to help index - nday <- ifelse(leap_year(yr.now), 366, 365) + nday <- ifelse(lubridate::leap_year(yr.now), 366, 365) ntime <- length(ncT$dim$time$vals) step.day <- nday/ntime step.hr <- step.day*24 @@ -100,12 +116,12 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. # Extract the met info, making matrices with the appropriate number of ensemble members for(v in names(ncT$var)){ - df.tem <- matrix(rep(ncvar_get(ncT, v), n.trn), ncol=n.trn, byrow=F) + df.tem <- matrix(rep(ncdf4::ncvar_get(ncT, v), n.trn), ncol=n.trn, byrow=F) met.out$dat.train[[v]] <- rbind(met.out$dat.train[[v]], df.tem) } - nc_close(ncT) + ncdf4::nc_close(ncT) setTxtProgressBar(pb, i) } # End looping through training data files @@ -150,10 +166,10 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. for(i in 1:length(files.train)){ yr.now <- yrs.file[i] - ncT <- nc_open(file.path(train.path, ens.train[j], files.train[i])) + ncT <- ncdf4::nc_open(file.path(train.path, ens.train[j], files.train[i])) # Set up the time data frame to help index - nday <- ifelse(leap_year(yr.now), 366, 365) + nday <- ifelse(lubridate::leap_year(yr.now), 366, 365) ntime <- length(ncT$dim$time$vals) step.day <- nday/ntime step.hr <- step.day*24 @@ -170,9 +186,9 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. # Extract the met info, making matrices with the appropriate number of ensemble members for(v in names(ncT$var)){ - dat.ens[[v]] <- append(dat.ens[[v]], ncvar_get(ncT, v)) + dat.ens[[v]] <- append(dat.ens[[v]], ncdf4::ncvar_get(ncT, v)) } - nc_close(ncT) + ncdf4::nc_close(ncT) setTxtProgressBar(pb, pb.ind) pb.ind <- pb.ind+1 @@ -215,7 +231,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. for(i in 1:length(files.source)){ yr.now <- yrs.file[i] - ncT <- nc_open(file.path(source.path, files.source[i])) + ncT <- ncdf4::nc_open(file.path(source.path, files.source[i])) # Set up the time data frame to help index nday <- ifelse(leap_year(yr.now), 366, 365) @@ -283,7 +299,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. met.out$dat.source[[v]] <- rbind(met.out$dat.source[[v]], as.matrix(df.tem, ncol=n.src)) } } - nc_close(ncT) + ncdf4::nc_close(ncT) setTxtProgressBar(pb, i) } # End looping through source met files print("") diff --git a/modules/data.atmosphere/R/debias_met_regression.R b/modules/data.atmosphere/R/debias_met_regression.R index 6fcee77ec60..f07e0c6e214 100644 --- a/modules/data.atmosphere/R/debias_met_regression.R +++ b/modules/data.atmosphere/R/debias_met_regression.R @@ -79,7 +79,7 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU if(is.null(vars.debias)) vars.debias <- vars.all[vars.all %in% names(train.data)] # Don't try to do vars that we don't have if(is.null(yrs.save)) yrs.save <- unique(source.data$time$Year) - if(is.null(ens.mems)) ens.mems <- str_pad(1:n.ens, nchar(n.ens), "left", pad="0") + if(is.null(ens.mems)) ens.mems <- stringr::str_pad(1:n.ens, nchar(n.ens), "left", pad="0") # Set up outputs vars.pred <- vector() @@ -306,7 +306,7 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU # the data that is to be bias-corrected. In this instance we essentially consider any daily precip to be # an anomaly # --------- - mod.bias <- gam(Y ~ s(doy, k=6) + X, data=dat.clim[dat.clim$ind == ind, ]) + mod.bias <- mgcv::gam(Y ~ s(doy, k=6) + X, data=dat.clim[dat.clim$ind == ind, ]) # summary(mod.bias) # Saving the mean predicted & residuals @@ -347,8 +347,8 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU # --------- # We want to look at anomalies relative to the raw expected seasonal pattern, so we need to fit training and data to be debiased separately - anom.train <- gam(X ~ s(doy, k=6) , data=met.train[met.train$ind==ind,]) - anom.src <- gam(X ~ s(doy, k=6) , data=met.src[met.src$ind==ind & met.src$year %in% yrs.overlap,]) + anom.train <- mgcv::gam(X ~ s(doy, k=6) , data=met.train[met.train$ind==ind,]) + anom.src <- mgcv::gam(X ~ s(doy, k=6) , data=met.src[met.src$ind==ind & met.src$year %in% yrs.overlap,]) met.train[met.train$ind==ind,"anom.train"] <- resid(anom.train) met.src[met.src$ind==ind, "anom.raw"] <- met.src[met.src$ind==ind, "X"] - predict(anom.src, newdata=met.src[met.src$ind==ind, ]) @@ -366,8 +366,8 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU met.src[met.src$ind==ind, "Q"] <- met.src[met.src$ind==ind,j] # Generating the predicted seasonal cycle for each variable - anom.train2 <- gam(Q ~ s(doy, k=6), data=met.train[met.train$ind==ind,]) - anom.src2 <- gam(Q ~ s(doy, k=6), data=met.src[met.src$year %in% yrs.overlap & met.src$ind==ind,]) + anom.train2 <- mgcv::gam(Q ~ s(doy, k=6), data=met.train[met.train$ind==ind,]) + anom.src2 <- mgcv::gam(Q ~ s(doy, k=6), data=met.src[met.src$year %in% yrs.overlap & met.src$ind==ind,]) met.train[met.train$ind==ind, paste0(j, ".anom")] <- resid(anom.train2) met.src[met.src$ind==ind, paste0(j, ".anom")] <- met.src[met.src$ind==ind,"Q"] - predict(anom.src2, newdata=met.src[met.src$ind==ind,]) @@ -406,25 +406,25 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU # These are the variables that have quasi-observed values for their whole time period, # so we can use the the seasonsal trend, and the observed anaomalies # Note: because we can directly model the anomalies, the inherent long-term trend should be preserved - mod.anom <- gam(anom.train ~ s(doy, k=6) + anom.raw -1, data=dat.anom) + mod.anom <- mgcv::gam(anom.train ~ s(doy, k=6) + anom.raw -1, data=dat.anom) } else if(v %in% c("surface_downwelling_shortwave_flux_in_air", "specific_humidity")){ # CRUNCEP surface_downwelling_shortwave_flux_in_air and specific_humidity have been vary hard to fit to NLDAS because it has a different variance for some reason, # and the only way I've been able to fix it is to model the temporal pattern seen in the dataset based on # its own anomalies (not ideal, but it works) - mod.anom <- gam(anom.raw ~ s(doy, k=6) + s(year, k=k) + air_temperature_maximum.anom*air_temperature_minimum.anom -1 , data=met.src[met.src$ind==ind,]) + mod.anom <- mgcv::gam(anom.raw ~ s(doy, k=6) + s(year, k=k) + air_temperature_maximum.anom*air_temperature_minimum.anom -1 , data=met.src[met.src$ind==ind,]) } else if(v=="precipitation_flux"){ # Precip is really only different from the others in that I deliberately chose a more rigid seasonal pattern and we need to force the intercept # through 0 so we can try and reduce the likelihood of evenly distributed precipitation events # k=round(length(met.src$year)/(25*366),0) # k=max(k, 4) # we can't have less than 4 knots - # mod.anom <- gam(anom.raw ~ s(year, k=k) + (air_temperature_maximum.anom + air_temperature_minimum.anom + surface_downwelling_shortwave_flux_in_air.anom + surface_downwelling_longwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.src[met.src$ind==ind,]) - mod.anom <- gam(anom.train ~ s(doy, k=6) + (air_temperature_maximum.anom + air_temperature_minimum.anom + surface_downwelling_shortwave_flux_in_air.anom + surface_downwelling_longwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.train[met.train$ind==ind,]) + # mod.anom <- mgcv::gam(anom.raw ~ s(year, k=k) + (air_temperature_maximum.anom + air_temperature_minimum.anom + surface_downwelling_shortwave_flux_in_air.anom + surface_downwelling_longwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.src[met.src$ind==ind,]) + mod.anom <- mgcv::gam(anom.train ~ s(doy, k=6) + (air_temperature_maximum.anom + air_temperature_minimum.anom + surface_downwelling_shortwave_flux_in_air.anom + surface_downwelling_longwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.train[met.train$ind==ind,]) } else if(v %in% c("wind_speed", "air_pressure", "surface_downwelling_longwave_flux_in_air")) { # These variables are constant in CRU pre-1950. # This means that we can not use information about the long term trend OR the actual annomalies # -- they must be inferred from the other met we have - mod.anom <- gam(anom.train ~ s(doy, k=6) + (air_temperature_minimum.anom*air_temperature_maximum.anom + surface_downwelling_shortwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.train[met.train$ind==ind,]) + mod.anom <- mgcv::gam(anom.train ~ s(doy, k=6) + (air_temperature_minimum.anom*air_temperature_maximum.anom + surface_downwelling_shortwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.train[met.train$ind==ind,]) } } else { # If we're dealing with non-empirical datasets, we can't pair anomalies to come up with a direct adjustment @@ -442,19 +442,19 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU if(v %in% c("air_temperature_maximum", "air_temperature_minimum")){ # If we haven't already done another met product, our best shot is to just model the existing variance # and preserve as much of the low-frequency cylce as possible - mod.anom <- gam(anom.raw ~ s(year, k=k) -1, data=met.src[met.src$ind==ind,]) + mod.anom <- mgcv::gam(anom.raw ~ s(year, k=k) -1, data=met.src[met.src$ind==ind,]) } else if(v=="precipitation_flux"){ # If we're working with precipitation_flux, need to make the intercept 0 so that we have plenty of days with little/no rain - mod.anom <- gam(anom.raw ~ s(year, k=k) + (air_temperature_maximum.anom*air_temperature_minimum.anom + surface_downwelling_shortwave_flux_in_air.anom + surface_downwelling_longwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.src[met.src$ind==ind,]) + mod.anom <- mgcv::gam(anom.raw ~ s(year, k=k) + (air_temperature_maximum.anom*air_temperature_minimum.anom + surface_downwelling_shortwave_flux_in_air.anom + surface_downwelling_longwave_flux_in_air.anom + specific_humidity.anom) -1, data=met.src[met.src$ind==ind,]) } else if(v %in% c("surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air")){ # See if we have some other anomaly that we can use to get the anomaly covariance & temporal trends right # This relies on the assumption that the low-frequency trends are in proportion to the other met variables # (this doesn't seem unreasonable, but that doesn't mean it's right) - mod.anom <- gam(anom.train ~ s(doy, k=4) + (air_temperature_maximum.anom*air_temperature_minimum.anom + specific_humidity.anom + air_pressure.anom + wind_speed.anom) -1, data=met.train[met.train$ind==ind,]) + mod.anom <- mgcv::gam(anom.train ~ s(doy, k=4) + (air_temperature_maximum.anom*air_temperature_minimum.anom + specific_humidity.anom + air_pressure.anom + wind_speed.anom) -1, data=met.train[met.train$ind==ind,]) } else { # If we have some info # THis should be specific_humidity, air_pressure, wind_speed - mod.anom <- gam(anom.raw ~ s(doy, k=6) + s(year, k=k) + (air_temperature_maximum.anom*air_temperature_minimum.anom)-1, data=met.src[met.src$ind==ind,]) + mod.anom <- mgcv::gam(anom.raw ~ s(doy, k=6) + s(year, k=k) + (air_temperature_maximum.anom*air_temperature_minimum.anom)-1, data=met.src[met.src$ind==ind,]) } } # summary(mod.anom) @@ -472,9 +472,9 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU if(v == "precipitation_flux") coef.ann <- coef(mod.ann) # Generate a random distribution of betas using the covariance matrix - Rbeta <- mvrnorm(n=n.ens, coef(mod.bias), vcov(mod.bias)) - Rbeta.anom <- mvrnorm(n=n.ens, coef(mod.anom), vcov(mod.anom)) - if(v == "precipitation_flux") Rbeta.ann <- mvrnorm(n=n.ens, coef(mod.ann), vcov(mod.ann)) + Rbeta <- MASS::mvrnorm(n=n.ens, coef(mod.bias), vcov(mod.bias)) + Rbeta.anom <- MASS::mvrnorm(n=n.ens, coef(mod.anom), vcov(mod.anom)) + if(v == "precipitation_flux") Rbeta.ann <- MASS::mvrnorm(n=n.ens, coef(mod.ann), vcov(mod.ann)) # Create the prediction matrix Xp <- predict(mod.bias, newdata=met.src[met.src$ind==ind,], type="lpmatrix") @@ -705,8 +705,8 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU ) # Define our lat/lon dims since those will be constant - dim.lat <- ncdim_def(name='latitude', units='degree_north', vals=lat.in, create_dimvar=TRUE) - dim.lon <- ncdim_def(name='longitude', units='degree_east', vals=lon.in, create_dimvar=TRUE) + dim.lat <- ncdf4::ncdim_def(name='latitude', units='degree_north', vals=lat.in, create_dimvar=TRUE) + dim.lon <- ncdf4::ncdim_def(name='longitude', units='degree_east', vals=lon.in, create_dimvar=TRUE) print("") print("Saving Ensemble") @@ -718,7 +718,7 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU nday <- ifelse(leap_year(yr), 366, 365) # Finish defining our time variables (same for all ensemble members) - dim.time <- ncdim_def(name='time', units="sec", vals=seq(1*24*360, (nday+1-1/24)*24*360, length.out=length(rows.yr)), create_dimvar=TRUE, unlim=TRUE) + dim.time <- ncdf4::ncdim_def(name='time', units="sec", vals=seq(1*24*360, (nday+1-1/24)*24*360, length.out=length(rows.yr)), create_dimvar=TRUE, unlim=TRUE) nc.dim=list(dim.lat,dim.lon,dim.time) # Setting up variables and dimensions @@ -726,10 +726,10 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU dat.list = list() for(j in 1:length(vars.debias)){ - var.list[[j]] = ncvar_def(name=vars.debias[j], - units=as.character(nc.info[nc.info$CF.name==vars.debias[j], "units"]), - longname=as.character(nc.info[nc.info$CF.name==vars.debias[j], "longname"]), - dim=nc.dim, missval=-999, verbose=verbose) + var.list[[j]] = ncdf4::ncvar_def(name=vars.debias[j], + units=as.character(nc.info[nc.info$CF.name==vars.debias[j], "units"]), + longname=as.character(nc.info[nc.info$CF.name==vars.debias[j], "longname"]), + dim=nc.dim, missval=-999, verbose=verbose) } names(var.list) <- vars.debias @@ -746,11 +746,11 @@ debias.met.regression <- function(train.data, source.data, n.ens, vars.debias=NU names(dat.list) <- vars.debias ## put data in new file - loc <- nc_create(filename=loc.file, vars=var.list, verbose=verbose) + loc <- ncdf4::nc_create(filename=loc.file, vars=var.list, verbose=verbose) for(j in 1:length(vars.debias)){ - ncvar_put(nc=loc, varid=as.character(vars.debias[j]), vals=dat.list[[j]]) + ncdf4::ncvar_put(nc=loc, varid=as.character(vars.debias[j]), vals=dat.list[[j]]) } - nc_close(loc) + ncdf4::nc_close(loc) setTxtProgressBar(pb, pb.ind) pb.ind <- pb.ind+1 diff --git a/modules/data.atmosphere/R/extract_local_CMIP5.R b/modules/data.atmosphere/R/extract_local_CMIP5.R index 9757bf7cbb6..c3c351c2969 100644 --- a/modules/data.atmosphere/R/extract_local_CMIP5.R +++ b/modules/data.atmosphere/R/extract_local_CMIP5.R @@ -41,13 +41,13 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i no.leap <- c("bcc-csm1-1", "CCSM4") # Days per month - dpm <- days_in_month(1:12) + dpm <- lubridate::days_in_month(1:12) # Date stuff start_date <- as.POSIXlt(start_date, tz = "GMT") end_date <- as.POSIXlt(end_date, tz = "GMT") - start_year <- year(start_date) - end_year <- year(end_date) + start_year <- lubridate::year(start_date) + end_year <- lubridate::year(end_date) lat.in = as.numeric(lat.in) lon.in = as.numeric(lon.in) @@ -82,8 +82,8 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i # Rewriting the dap name to get the closest variable that we have for the GCM (some only give uss stuff at sea level) library(car) # having trouble gettins stuff to work otherwise - if(!("huss" %in% vars.gcm)) var$DAP.name <- recode(var$DAP.name, "'huss'='hus'") - if(!("ps" %in% vars.gcm )) var$DAP.name <- recode(var$DAP.name, "'ps'='psl'") + if(!("huss" %in% vars.gcm)) var$DAP.name <- car::recode(var$DAP.name, "'huss'='hus'") + if(!("ps" %in% vars.gcm )) var$DAP.name <- car::recode(var$DAP.name, "'ps'='psl'") # Making sure we're only trying to grab the variables we have (i.e. don't try sfcWind if we don't have it) var <- var[var$DAP.name %in% vars.gcm,] @@ -106,7 +106,7 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i # Set up an index to help us find out which file we'll need files.var[[v]][["years"]] <- data.frame(first.year=NA, last.year=NA) for(i in 1:length(files.var[[v]][["files"]])){ - yr.str <- str_split(str_split(files.var[[v]][["files"]][[i]], "_")[[1]][6], "-")[[1]] + yr.str <- stringr::str_split(stringr::str_split(files.var[[v]][["files"]][[i]], "_")[[1]][6], "-")[[1]] # Don't bother storing this file if we don't want those years if(as.numeric(substr(yr.str[1], 1, 4)) > end_year | as.numeric(substr(yr.str[2], 1, 4))< start_year) next @@ -147,12 +147,12 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i # print(f.now) # Open up the file - ncT <- nc_open(file.path(in.path, v.res, var.now, f.now)) + ncT <- ncdf4::nc_open(file.path(in.path, v.res, var.now, f.now)) # Extract our dimensions - lat_bnd <- ncvar_get(ncT, "lat_bnds") - lon_bnd <- ncvar_get(ncT, "lon_bnds") - nc.time <- ncvar_get(ncT, "time") + lat_bnd <- ncdf4::ncvar_get(ncT, "lat_bnds") + lon_bnd <- ncdf4::ncvar_get(ncT, "lon_bnds") + nc.time <- ncdf4::ncvar_get(ncT, "time") # splt.ind <- ifelse(GCM %in% c("MPI-ESM-P"), 4, 3) # date.origin <- as.Date(str_split(ncT$dim$time$units, " ")[[1]][splt.ind]) @@ -167,17 +167,17 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i # Extract all of the available data if(var.now %in% c("hus", "ua", "va")){ # These have multiple strata; we only want 1 - plev <- ncvar_get(ncT, "plev") + plev <- ncdf4::ncvar_get(ncT, "plev") puse <- which(plev==max(plev)) # Get humidity at the place of highest pressure (closest to surface) - dat.temp <- ncvar_get(ncT, var.now, c(ind.lon, ind.lat, puse, 1), c(1,1,1,length(nc.time))) + dat.temp <- ncdf4::ncvar_get(ncT, var.now, c(ind.lon, ind.lat, puse, 1), c(1,1,1,length(nc.time))) # If dat.list has missing values, try the next layer puse.orig <- puse while(is.na(mean(dat.temp))){ if(puse.orig==1) { puse = puse + 1 } else { puse = puse -1 } - dat.temp <- ncvar_get(ncT, var.now, c(ind.lon, ind.lat, puse, 1), c(1,1,1,length(nc.time))) + dat.temp <- ncdf4::ncvar_get(ncT, var.now, c(ind.lon, ind.lat, puse, 1), c(1,1,1,length(nc.time))) } } else { - dat.temp <- ncvar_get(ncT, var.now, c(ind.lon, ind.lat, 1), c(1,1,length(nc.time))) + dat.temp <- ncdf4::ncvar_get(ncT, var.now, c(ind.lon, ind.lat, 1), c(1,1,length(nc.time))) } # If we have monthly data, lets trick it into being daily @@ -191,13 +191,13 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i } # End leap day trick dat.all[[v]] <- append(dat.all[[v]], dat.temp, length(dat.all[[v]])) - nc_close(ncT) + ncdf4::nc_close(ncT) } # End file loop } # End variable loop # Dealing with leap-year post-hoc because it was becoming a pain in the ass # If we have daily data and we're dealing with a model that skips leap year, add it in - dpm <- days_in_month(1:12) + dpm <- lubridate::days_in_month(1:12) yrs.leap <- ylist[leap_year(ylist)] for(y.now in yrs.leap){ yr.ind <- which(year(dat.time)==y.now) @@ -220,18 +220,18 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i yr.ind <- which(year(dat.time)==y.now) - dpm <- days_in_month(1:12) - if(leap_year(y.now)) dpm[2] <- dpm[2] + 1 # make sure Feb has 29 days if we're dealing with a leap year + dpm <- lubridate::days_in_month(1:12) + if(lubridate::leap_year(y.now)) dpm[2] <- dpm[2] + 1 # make sure Feb has 29 days if we're dealing with a leap year # figure out how many days we're working with if(rows>1 & i!=1 & i!=rows){ # If we have multiple years and we're not in the first or last year, we're taking a whole year - nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + nday = ifelse(lubridate::leap_year(y.now), 366, 365) # leap year or not; days per year day1 = 1 day2 = nday days.use = day1:day2 } else if(rows==1){ # if we're working with only 1 year, lets only pull what we need to - nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + nday = ifelse(lubridate::leap_year(y.now), 366, 365) # leap year or not; days per year day1 <- yday(start_date) # Now we need to check whether we're ending on the right day day2 <- yday(end_date) @@ -239,16 +239,16 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i nday=length(days.use) # Update nday } else if(i==1) { # If this is the first of many years, we only need to worry about the start date - nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + nday = ifelse(lubridate::leap_year(y.now), 366, 365) # leap year or not; days per year day1 <- yday(start_date) day2 = nday days.use = day1:day2 nday=length(days.use) # Update nday } else if(i==rows) { # If this is the last of many years, we only need to worry about the start date - nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + nday = ifelse(lubridate::leap_year(y.now), 366, 365) # leap year or not; days per year day1 = 1 - day2 <- yday(end_date) + day2 <- lubridate::yday(end_date) days.use = day1:day2 nday=length(days.use) # Update nday } @@ -258,9 +258,9 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i ## Create dimensions - dim.lat <- ncdim_def(name='latitude', units='degree_north', vals=lat.in, create_dimvar=TRUE) - dim.lon <- ncdim_def(name='longitude', units='degree_east', vals=lon.in, create_dimvar=TRUE) - dim.time <- ncdim_def(name='time', units="sec", vals=seq((min(days.use)+1-1/24)*24*360, (max(days.use)+1-1/24)*24*360, length.out=ntime), create_dimvar=TRUE, unlim=TRUE) + dim.lat <- ncdf4::ncdim_def(name='latitude', units='degree_north', vals=lat.in, create_dimvar=TRUE) + dim.lon <- ncdf4::ncdim_def(name='longitude', units='degree_east', vals=lon.in, create_dimvar=TRUE) + dim.time <- ncdf4::ncdim_def(name='time', units="sec", vals=seq((min(days.use)+1-1/24)*24*360, (max(days.use)+1-1/24)*24*360, length.out=ntime), create_dimvar=TRUE, unlim=TRUE) nc.dim=list(dim.lat,dim.lon,dim.time) @@ -269,7 +269,7 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i dat.list = list() for(j in 1:nrow(var)){ - var.list[[j]] = ncvar_def(name=as.character(var$CF.name[j]), units=as.character(var$units[j]), dim=nc.dim, missval=-999, verbose=verbose) + var.list[[j]] = ncdf4::ncvar_def(name=as.character(var$CF.name[j]), units=as.character(var$units[j]), dim=nc.dim, missval=-999, verbose=verbose) dat.list[[j]] <- array(NA, dim=c(length(lat.in), length(lon.in), ntime)) # Go ahead and make the arrays } names(var.list) <- names(dat.list) <- var$CF.name @@ -280,11 +280,11 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i } # End variable loop ## put data in new file - loc <- nc_create(filename=loc.file, vars=var.list, verbose=verbose) + loc <- ncdf4::nc_create(filename=loc.file, vars=var.list, verbose=verbose) for(j in 1:nrow(var)){ - ncvar_put(nc=loc, varid=as.character(var$CF.name[j]), vals=dat.list[[j]]) + ncdf4::ncvar_put(nc=loc, varid=as.character(var$CF.name[j]), vals=dat.list[[j]]) } - nc_close(loc) + ncdf4::nc_close(loc) results$file[i] <- loc.file # results$host[i] <- fqdn() diff --git a/modules/data.atmosphere/man/align.met.Rd b/modules/data.atmosphere/man/align.met.Rd index e76007a2610..35718504aec 100644 --- a/modules/data.atmosphere/man/align.met.Rd +++ b/modules/data.atmosphere/man/align.met.Rd @@ -19,10 +19,18 @@ problematic years)} \item{n.ens}{- number of ensemble members to generate and save} -\item{pair.mems}{- logical stating whether ensemble members should be paired} +\item{pair.mems}{- (not implemented) logical stating whether ensemble members should be paired in +the case where ensembles are being read in in both the training and source data} \item{seed}{- specify seed so that random draws can be reproduced} } +\value{ +2-layered list (stored in memory) containing the training and source data that are now matched + in temporal resolution have the specified number of ensemble members + - dat.train (training dataset) and dat.source (source data to be downscaled or bias-corrected) + are both lists that contain separate data frames for time indices and all available met + variables with ensemble members in columns +} \description{ This script aligns meteorology datasets in at temporal resolution for debiasing & temporal downscaling. @@ -32,6 +40,19 @@ This script aligns meteorology datasets in at temporal resolution for debiasing } \details{ Align meteorology datasets for debiasing + +1. Assumes that both the training and source data are in *at least* daily resolution + and each dataset is in a consistent temporal resolution being read from a single file + (CF/Pecan format). For example, CMIP5 historical/p1000 runs where radiation drivers + are in monthly resolution and temperature is in daily will need to be reconciled using + one of the "met2CF" or "download" or "extract" functions + 2. Default file structure: Ensembles members for a given site or set of simes are housed + in a common folder with the site ID. Right now everything is based off of Christy's + PalEON ensemble ID scheme where the site ID is a character string (e.g. HARVARD) followed + the SOURCE data family (i.e. GCM) as a string and then the ensemble member ID as a number + (e.g. 001). For example, the file path for a single daily ensemble member for PalEON is: + "~/Desktop/Research/met_ensembles/data/met_ensembles/HARVARD/day/ensembles/bcc-csm1-1_004" + with each year in a separate netcdf file inside of it. } \seealso{ Other debias - Debias & Align Meteorology Datasets into continuous time series: \code{\link{debias.met.regression}} From bd1ce911eb14282caeabe7dfb4affd6714de18d8 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 5 Sep 2017 11:24:31 -0400 Subject: [PATCH 543/771] ED: Cleanup `met2model.ED2` library calls --- models/ed/R/met2model.ED2.R | 69 ++++++++++++++++++------------------- 1 file changed, 33 insertions(+), 36 deletions(-) diff --git a/models/ed/R/met2model.ED2.R b/models/ed/R/met2model.ED2.R index 695a039d2a9..d5f20966fbe 100644 --- a/models/ed/R/met2model.ED2.R +++ b/models/ed/R/met2model.ED2.R @@ -35,10 +35,6 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l lon = NA, overwrite = FALSE, verbose = FALSE, ...) { overwrite <- as.logical(overwrite) - # deprecated? - library(rhdf5) - library(PEcAn.utils) - # results are stored in folder prefix.start.end start_date <- as.POSIXlt(start_date, tz = "UTC") end_date <- as.POSIXlt(end_date, tz = "UTC") @@ -73,6 +69,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l # get start/end year since inputs are specified on year basis start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) + day_secs <- udunits2::ud.convert(1, "day", "seconds") ## loop over files for (year in start_year:end_year) { @@ -84,7 +81,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l nc <- ncdf4::nc_open(ncfile) # check lat/lon - flat <- try(ncvar_get(nc, "latitude"), silent = TRUE) + flat <- try(ncdf4::ncvar_get(nc, "latitude"), silent = TRUE) if (!is.numeric(flat)) { flat <- nc$dim[[1]]$vals[1] } @@ -94,7 +91,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l PEcAn.logger::logger.warn("Latitude does not match that of file", lat, "!=", flat) } - flon <- try(ncvar_get(nc, "longitude"), silent = TRUE) + flon <- try(ncdf4::ncvar_get(nc, "longitude"), silent = TRUE) if (!is.numeric(flon)) { flat <- nc$dim[[2]]$vals[1] } @@ -110,15 +107,15 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l lat <- eval(parse(text = lat)) lon <- eval(parse(text = lon)) sec <- nc$dim$time$vals - Tair <- ncvar_get(nc, "air_temperature") - Qair <- ncvar_get(nc, "specific_humidity") #humidity (kg/kg) - U <- ncvar_get(nc, "eastward_wind") - V <- ncvar_get(nc, "northward_wind") - Rain <- ncvar_get(nc, "precipitation_flux") - pres <- ncvar_get(nc, "air_pressure") - SW <- ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") - LW <- ncvar_get(nc, "surface_downwelling_longwave_flux_in_air") - CO2 <- try(ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air"), silent = TRUE) + Tair <- ncdf4::ncvar_get(nc, "air_temperature") + Qair <- ncdf4::ncvar_get(nc, "specific_humidity") #humidity (kg/kg) + U <- ncdf4::ncvar_get(nc, "eastward_wind") + V <- ncdf4::ncvar_get(nc, "northward_wind") + Rain <- ncdf4::ncvar_get(nc, "precipitation_flux") + pres <- ncdf4::ncvar_get(nc, "air_pressure") + SW <- ncdf4::ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") + LW <- ncdf4::ncvar_get(nc, "surface_downwelling_longwave_flux_in_air") + CO2 <- try(ncdf4::ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air"), silent = TRUE) useCO2 <- is.numeric(CO2) @@ -147,15 +144,15 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l ## build time variables (year, month, day of year) skip <- FALSE - nyr <- floor(length(sec) / 86400 / 365 * dt) + nyr <- floor(udunits2::ud.convert(length(sec) * dt, "seconds", "years")) yr <- NULL doy <- NULL hr <- NULL asec <- sec for (y in seq(year, year + nyr - 1)) { diy <- PEcAn.utils::days_in_year(y) - ytmp <- rep(y, diy * 86400 / dt) - dtmp <- rep(seq_len(diy), each = 86400 / dt) + ytmp <- rep(y, udunits2::ud.convert(diy / dt, "days", "seconds")) + dtmp <- rep(seq_len(diy), each = day_secs / dt) if (is.null(yr)) { yr <- ytmp doy <- dtmp @@ -172,7 +169,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l break } asec[rng] <- asec[rng] - asec[rng[1]] - hr[rng] <- (asec[rng] - (dtmp - 1) * 86400) / 86400 * 24 + hr[rng] <- (asec[rng] - (dtmp - 1) * day_secs) / day_secs * 24 } mo <- day2mo(yr, doy) if (length(yr) < length(sec)) { @@ -183,8 +180,8 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l break } yr[rng] <- rep(y + 1, length(rng)) - doy[rng] <- rep(1:366, each = 86400 / dt)[1:length(rng)] - hr[rng] <- rep(seq(0, length = 86400 / dt, by = dt / 86400 * 24), 366)[1:length(rng)] + doy[rng] <- rep(1:366, each = day_secs / dt)[1:length(rng)] + hr[rng] <- rep(seq(0, length = day_secs / dt, by = dt / day_secs * 24), 366)[1:length(rng)] } if (skip) { print("Skipping to next year") @@ -237,14 +234,14 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l if (file.exists(mout)) { if (overwrite == TRUE) { file.remove(mout) - h5createFile(mout) + rhdf5::h5createFile(mout) } if (overwrite == FALSE) { PEcAn.logger::logger.warn("The file already exists! Moving to next month!") next } } else { - h5createFile(mout) + rhdf5::h5createFile(mout) } dims <- c(length(selm), 1, 1) nbdsf <- array(nbdsfA[selm], dim = dims) @@ -262,20 +259,20 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l if (useCO2) { co2 <- array(co2A[selm], dim = dims) } - h5write(nbdsf, mout, "nbdsf") - h5write(nddsf, mout, "nddsf") - h5write(vbdsf, mout, "vbdsf") - h5write(vddsf, mout, "vddsf") - h5write(prate, mout, "prate") - h5write(dlwrf, mout, "dlwrf") - h5write(pres, mout, "pres") - h5write(hgt, mout, "hgt") - h5write(ugrd, mout, "ugrd") - h5write(vgrd, mout, "vgrd") - h5write(sh, mout, "sh") - h5write(tmp, mout, "tmp") + rhdf5::h5write(nbdsf, mout, "nbdsf") + rhdf5::h5write(nddsf, mout, "nddsf") + rhdf5::h5write(vbdsf, mout, "vbdsf") + rhdf5::h5write(vddsf, mout, "vddsf") + rhdf5::h5write(prate, mout, "prate") + rhdf5::h5write(dlwrf, mout, "dlwrf") + rhdf5::h5write(pres, mout, "pres") + rhdf5::h5write(hgt, mout, "hgt") + rhdf5::h5write(ugrd, mout, "ugrd") + rhdf5::h5write(vgrd, mout, "vgrd") + rhdf5::h5write(sh, mout, "sh") + rhdf5::h5write(tmp, mout, "tmp") if (useCO2) { - h5write(co2, mout, "co2") + rhdf5::h5write(co2, mout, "co2") } } } From 38fb55c56402a18218792208bc6e252ae1a087a1 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Tue, 5 Sep 2017 10:25:48 -0500 Subject: [PATCH 544/771] Further Biocro data.table style cleanup (#1625) * use df$name for clarity * Do not convert relative humidity to percent Percent gets converted back to ratio a few lines later anyway! --- models/biocro/R/met2model.BIOCRO.R | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/models/biocro/R/met2model.BIOCRO.R b/models/biocro/R/met2model.BIOCRO.R index 857e5243b5d..14e4cb82aa7 100644 --- a/models/biocro/R/met2model.BIOCRO.R +++ b/models/biocro/R/met2model.BIOCRO.R @@ -142,13 +142,15 @@ cf2biocro <- function(met, longitude = NULL, zulu2solarnoon = FALSE) { if ((!is.null(longitude)) & zulu2solarnoon) { solarnoon_offset <- udunits2::ud.convert(longitude/360, "day", "minute") - met[, `:=`(solardate = date + lubridate::minutes(solarnoon_offset))] + met[, `:=`(solardate = met$date + lubridate::minutes(solarnoon_offset))] } if (!"relative_humidity" %in% colnames(met)) { if (all(c("air_temperature", "air_pressure", "specific_humidity") %in% colnames(met))) { - rh <- qair2rh(qair = met$specific_humidity, temp = udunits2::ud.convert(met$air_temperature, - "Kelvin", "Celsius"), press = udunits2::ud.convert(met$air_pressure, "Pa", "hPa")) - met <- cbind(met, relative_humidity = rh * 100) + rh <- qair2rh( + qair = met$specific_humidity, + temp = udunits2::ud.convert(met$air_temperature, "Kelvin", "Celsius"), + press = udunits2::ud.convert(met$air_pressure, "Pa", "hPa")) + met[, `:=`(relative_humidity = rh)] } else { PEcAn.logger::logger.error("neither relative_humidity nor [air_temperature, air_pressure, and specific_humidity]", "are in met data") @@ -173,12 +175,12 @@ cf2biocro <- function(met, longitude = NULL, zulu2solarnoon = FALSE) { } ## Convert RH from percent to fraction BioCro functions just to confirm - if (met[, max(met$relative_humidity) > 1]) { - met$relative_humidity = met$relative_humidity/100 + if (max(met$relative_humidity) > 1) { + met[, `:=`(relative_humidity = met$relative_humidity/100)] } - newmet <- met[, list(year = lubridate::year(date), - doy = lubridate::yday(date), - hour = round(lubridate::hour(date) + lubridate::minute(date) / 60, 0), + newmet <- met[, list(year = lubridate::year(met$date), + doy = lubridate::yday(met$date), + hour = round(lubridate::hour(met$date) + lubridate::minute(met$date) / 60, 0), SolarR = ppfd, Temp = udunits2::ud.convert(met$air_temperature, "Kelvin", "Celsius"), RH = met$relative_humidity, From f6ff4a2a08025637ebbc7ecee0d75a5df9efab81 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 5 Sep 2017 11:35:32 -0400 Subject: [PATCH 545/771] data.atmosphere: More cleanup of met NAMESPACE --- modules/data.atmosphere/NAMESPACE | 1 - modules/data.atmosphere/R/met2CF.ALMA.R | 61 ++++++------ modules/data.atmosphere/R/met2CF.Ameriflux.R | 99 +++++++++----------- 3 files changed, 73 insertions(+), 88 deletions(-) diff --git a/modules/data.atmosphere/NAMESPACE b/modules/data.atmosphere/NAMESPACE index 07f9b211132..d8a5dde0621 100644 --- a/modules/data.atmosphere/NAMESPACE +++ b/modules/data.atmosphere/NAMESPACE @@ -77,7 +77,6 @@ importFrom(PEcAn.DB,db.close) importFrom(PEcAn.DB,db.query) importFrom(PEcAn.DB,dbfile.input.insert) importFrom(ncdf4,ncatt_get) -importFrom(ncdf4,ncatt_put) importFrom(ncdf4,ncdim_def) importFrom(ncdf4,ncvar_add) importFrom(ncdf4,ncvar_def) diff --git a/modules/data.atmosphere/R/met2CF.ALMA.R b/modules/data.atmosphere/R/met2CF.ALMA.R index f72bcdce879..c891bdc295d 100644 --- a/modules/data.atmosphere/R/met2CF.ALMA.R +++ b/modules/data.atmosphere/R/met2CF.ALMA.R @@ -22,7 +22,6 @@ insertPmet <- function(vals, nc2, var2, dim2, units2 = NA, conv = NULL, ##' @param overwrite should existing files be overwritten ##' ##' @author Mike Dietze -##' @importFrom ncdf4 ncvar_get ncdim_def ncatt_get ncvar_add ncvar_put met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { @@ -184,7 +183,6 @@ met2CF.PalEONregional <- function(in.path, in.prefix, outfolder, start_date, end ##' @param overwrite should existing files be overwritten ##' ##' @author Mike Dietze -##' @importFrom ncdf4 ncvar_get ncdim_def ncatt_get ncvar_add ncvar_put met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, lat, lon, overwrite = FALSE, verbose = FALSE, ...) { @@ -256,9 +254,9 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l old.file <- fnames[sel] nc1 <- ncdf4::nc_open(old.file, write = FALSE) if (length(met[[v]]) <= 1) { - met[[v]] <- ncvar_get(nc = nc1, varid = v) + met[[v]] <- ncdf4::ncvar_get(nc = nc1, varid = v) } else { - tmp <- ncvar_get(nc = nc1, varid = v) + tmp <- ncdf4::ncvar_get(nc = nc1, varid = v) met[[v]] <- abind::abind(met[[v]], tmp) } if (v == by.folder[1]) { @@ -282,12 +280,12 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l tdim$len <- length(tdim$vals) latlon <- lat # nc1$dim$lat$vals latlon[2] <- lon # nc1$dim$lon$vals - lat <- ncdim_def(name = "latitude", units = "", vals = 1:1, create_dimvar = FALSE) - lon <- ncdim_def(name = "longitude", units = "", vals = 1:1, create_dimvar = FALSE) - time <- ncdim_def(name = "time", units = tdim$units, vals = tdim$vals, + lat <- ncdf4::ncdim_def(name = "latitude", units = "", vals = 1:1, create_dimvar = FALSE) + lon <- ncdf4::ncdim_def(name = "longitude", units = "", vals = 1:1, create_dimvar = FALSE) + time <- ncdf4::ncdim_def(name = "time", units = tdim$units, vals = tdim$vals, create_dimvar = TRUE, unlim = TRUE) dim <- list(lat, lon, time) - cp.global.atts <- ncatt_get(nc = nc1, varid = 0) + cp.global.atts <- ncdf4::ncatt_get(nc = nc1, varid = 0) ncdf4::nc_close(nc1) # Open new file and copy lat attribute to latitude @@ -295,13 +293,13 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l var <- ncdf4::ncvar_def(name = "latitude", units = "degree_north", dim = (list(lat, lon, time)), missval = as.numeric(-9999)) nc2 <- ncdf4::nc_create(filename = new.file, vars = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "latitude", vals = rep(latlon[1], tdim$len)) + ncdf4::ncvar_put(nc = nc2, varid = "latitude", vals = rep(latlon[1], tdim$len)) # copy lon attribute to longitude var <- ncdf4::ncvar_def(name = "longitude", units = "degree_east", dim = (list(lat, lon, time)), missval = as.numeric(-9999)) - nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "longitude", vals = rep(latlon[2], tdim$len)) + nc2 <- ncdf4::ncvar_add(nc = nc2, v = var, verbose = verbose) + ncdf4::ncvar_put(nc = nc2, varid = "longitude", vals = rep(latlon[2], tdim$len)) # air_temperature insertPmet(met[["tair"]], nc2 = nc2, var2 = "air_temperature", units2 = "K", dim2 = dim, @@ -360,7 +358,6 @@ met2CF.PalEON <- function(in.path, in.prefix, outfolder, start_date, end_date, l ##' @param overwrite should existing files be overwritten ##' ##' @author Mike Dietze -##' @importFrom ncdf4 ncvar_get ncdim_def ncatt_get ncvar_add ncvar_put met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE) { # get start/end year code works on whole years only @@ -440,9 +437,9 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove old.file <- fnames[sel] nc1 <- ncdf4::nc_open(old.file, write = FALSE) if (length(met[[v]]) <= 1) { - met[[v]] <- ncvar_get(nc = nc1, varid = v) + met[[v]] <- ncdf4::ncvar_get(nc = nc1, varid = v) } else { - tmp <- ncvar_get(nc = nc1, varid = v) + tmp <- ncdf4::ncvar_get(nc = nc1, varid = v) met[[v]] <- abind::abind(met[[v]], tmp) } if (v == by.folder[1]) { @@ -463,9 +460,9 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove tdim <- nc1$dim[["time"]] latlon <- nc1$dim$lat$vals latlon[2] <- nc1$dim$lon$vals - lat <- ncdim_def(name = "latitude", units = "", vals = 1:1, create_dimvar = FALSE) - lon <- ncdim_def(name = "longitude", units = "", vals = 1:1, create_dimvar = FALSE) - time <- ncdim_def(name = "time", units = tdim$units, vals = met[["time"]], + lat <- ncdf4::ncdim_def(name = "latitude", units = "", vals = 1:1, create_dimvar = FALSE) + lon <- ncdf4::ncdim_def(name = "longitude", units = "", vals = 1:1, create_dimvar = FALSE) + time <- ncdf4::ncdim_def(name = "time", units = tdim$units, vals = met[["time"]], create_dimvar = TRUE, unlim = TRUE) dim <- list(lat, lon, time) @@ -474,13 +471,13 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove var <- ncdf4::ncvar_def(name = "latitude", units = "degree_north", dim = (list(lat, lon, time)), missval = as.numeric(-9999)) nc2 <- nc_create(filename = new.file, vars = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "latitude", vals = rep(latlon[1], tdim$len)) + ncdf4::ncvar_put(nc = nc2, varid = "latitude", vals = rep(latlon[1], tdim$len)) # copy lon attribute to longitude var <- ncdf4::ncvar_def(name = "longitude", units = "degree_east", dim = (list(lat, lon, time)), missval = as.numeric(-9999)) - nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "longitude", vals = rep(latlon[2], tdim$len)) + nc2 <- ncdf4::ncvar_add(nc = nc2, v = var, verbose = verbose) + ncdf4::ncvar_put(nc = nc2, varid = "longitude", vals = rep(latlon[2], tdim$len)) # Convert all variables # This will include conversions or computations to create values from @@ -534,17 +531,17 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove verbose = verbose) # convert RH to SH - rh <- ncvar_get(nc = nc1, varid = "RH") + rh <- ncdf4::ncvar_get(nc = nc1, varid = "RH") rh[rh == -6999 | rh == -9999] <- NA rh <- rh/100 - ta <- ncvar_get(nc = nc1, varid = "TA") + ta <- ncdf4::ncvar_get(nc = nc1, varid = "TA") ta[ta == -6999 | ta == -9999] <- NA ta <- udunits2::ud.convert(ta, "degC", "K") sh <- rh2qair(rh = rh, T = ta) var <- ncdf4::ncvar_def(name = "specific_humidity", units = "kg/kg", dim = dim, missval = -6999, verbose = verbose) - nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "specific_humidity", vals = sh) + nc2 <- ncdf4::ncvar_add(nc = nc2, v = var, verbose = verbose) + ncdf4::ncvar_put(nc = nc2, varid = "specific_humidity", vals = sh) # convert VPD to water_vapor_saturation_deficit # HACK : conversion will make all values < 0 to be NA @@ -605,28 +602,28 @@ met2CF.ALMA <- function(in.path, in.prefix, outfolder, start_date, end_date, ove verbose = verbose) # convert wind speed and wind direction to eastward_wind and northward_wind - wd <- ncvar_get(nc = nc1, varid = "WD") #wind direction + wd <- ncdf4::ncvar_get(nc = nc1, varid = "WD") #wind direction wd[wd == -6999 | wd == -9999] <- NA - ws <- ncvar_get(nc = nc1, varid = "WS") #wind speed + ws <- ncdf4::ncvar_get(nc = nc1, varid = "WS") #wind speed ws[ws == -6999 | ws == -9999] <- NA ew <- ws * cos(wd * (pi / 180)) nw <- ws * sin(wd * (pi / 180)) - max <- ncatt_get(nc = nc1, varid = "WS", "valid_max")$value + max <- ncdf4::ncatt_get(nc = nc1, varid = "WS", "valid_max")$value var <- ncdf4::ncvar_def(name = "eastward_wind", units = "m/s", dim = dim, missval = -6999, verbose = verbose) - nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "eastward_wind", vals = ew) + nc2 <- ncdf4::ncvar_add(nc = nc2, v = var, verbose = verbose) + ncdf4::ncvar_put(nc = nc2, varid = "eastward_wind", vals = ew) ncatt_put(nc = nc2, varid = "eastward_wind", attname = "valid_min", attval = -max) ncatt_put(nc = nc2, varid = "eastward_wind", attname = "valid_max", attval = max) var <- ncdf4::ncvar_def(name = "northward_wind", units = "m/s", dim = dim, missval = -6999, verbose = verbose) - nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "northward_wind", vals = nw) + nc2 <- ncdf4::ncvar_add(nc = nc2, v = var, verbose = verbose) + ncdf4::ncvar_put(nc = nc2, varid = "northward_wind", vals = nw) ncatt_put(nc = nc2, varid = "northward_wind", attname = "valid_min", attval = -max) ncatt_put(nc = nc2, varid = "northward_wind", attname = "valid_max", attval = max) # add global attributes from original file - cp.global.atts <- ncatt_get(nc = nc1, varid = 0) + cp.global.atts <- ncdf4::ncatt_get(nc = nc1, varid = 0) for (j in seq_along(cp.global.atts)) { ncatt_put(nc = nc2, varid = 0, attname = names(cp.global.atts)[j], attval = cp.global.atts[[j]]) } diff --git a/modules/data.atmosphere/R/met2CF.Ameriflux.R b/modules/data.atmosphere/R/met2CF.Ameriflux.R index e6aba96df4c..1824cfed5de 100644 --- a/modules/data.atmosphere/R/met2CF.Ameriflux.R +++ b/modules/data.atmosphere/R/met2CF.Ameriflux.R @@ -2,62 +2,53 @@ # conversion of the variables as well as on the min/max values copyvals <- function(nc1, var1, nc2, var2, dim2, units2 = NA, conv = NULL, missval = -6999, verbose = FALSE) { - ncvar_get <- ncdf4::ncvar_get - ncatt_get <- ncdf4::ncatt_get - ncvar_add <- ncdf4::ncvar_add - ncvar_def <- ncdf4::ncvar_def - ncatt_put <- ncdf4::ncatt_put - ncvar_put <- ncdf4::ncvar_put - - vals <- ncvar_get(nc = nc1, varid = var1) + vals <- ncdf4::ncvar_get(nc = nc1, varid = var1) vals[vals == -6999 | vals == -9999] <- NA if (!is.null(conv)) { vals <- lapply(vals, conv) } if (is.na(units2)) { - units2 <- ncatt_get(nc = nc1, varid = var1, attname = "units", verbose = verbose)$value + units2 <- ncdf4::ncatt_get(nc = nc1, varid = var1, attname = "units", verbose = verbose)$value } - var <- ncvar_def(name = var2, units = units2, dim = dim2, missval = missval, verbose = verbose) - nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) - ncvar_put(nc = nc2, varid = var2, vals = vals) + var <- ncdf4::ncvar_def(name = var2, units = units2, dim = dim2, missval = missval, verbose = verbose) + nc2 <- ncdf4::ncvar_add(nc = nc2, v = var, verbose = verbose) + ncdf4::ncvar_put(nc = nc2, varid = var2, vals = vals) # copy and convert attributes - att <- ncatt_get(nc1, var1, "long_name") + att <- ncdf4::ncatt_get(nc1, var1, "long_name") if (att$hasatt) { val <- att$value - ncatt_put(nc = nc2, varid = var2, attname = "long_name", attval = val) + ncdf4::ncatt_put(nc = nc2, varid = var2, attname = "long_name", attval = val) } - att <- ncatt_get(nc1, var1, "valid_min") + att <- ncdf4::ncatt_get(nc1, var1, "valid_min") if (att$hasatt) { val <- ifelse(is.null(conv), att$value, conv(att$value)) - ncatt_put(nc = nc2, varid = var2, attname = "valid_min", attval = val) + ncdf4::ncatt_put(nc = nc2, varid = var2, attname = "valid_min", attval = val) } - att <- ncatt_get(nc1, var1, "valid_max") + att <- ncdf4::ncatt_get(nc1, var1, "valid_max") if (att$hasatt) { val <- ifelse(is.null(conv), att$value, conv(att$value)) - ncatt_put(nc = nc2, varid = var2, attname = "valid_max", attval = val) + ncdf4::ncatt_put(nc = nc2, varid = var2, attname = "valid_max", attval = val) } - att <- ncatt_get(nc1, var1, "comment") + att <- ncdf4::ncatt_get(nc1, var1, "comment") if (att$hasatt) { val <- sub(", -9999.* = missing value, -6999.* = unreported value", "", att$value) - ncatt_put(nc = nc2, varid = var2, attname = "comment", attval = val) + ncdf4::ncatt_put(nc = nc2, varid = var2, attname = "comment", attval = val) } } # copyvals getLatLon <- function(nc1) { - ncatt_get <- ncdf4::ncatt_get - - loc <- ncatt_get(nc = nc1, varid = 0, attname = "site_location") + loc <- ncdf4::ncatt_get(nc = nc1, varid = 0, attname = "site_location") if (loc$hasatt) { lat <- as.numeric(substr(loc$value, 20, 28)) lon <- as.numeric(substr(loc$value, 40, 48)) return(c(lat, lon)) } else { - lat <- ncatt_get(nc = nc1, varid = 0, attname = "geospatial_lat_min") - lon <- ncatt_get(nc = nc1, varid = 0, attname = "geospatial_lon_min") + lat <- ncdf4::ncatt_get(nc = nc1, varid = 0, attname = "geospatial_lat_min") + lon <- ncdf4::ncatt_get(nc = nc1, varid = 0, attname = "geospatial_lon_min") if (lat$hasatt && lon$hasatt) { return(c(as.numeric(lat$value), as.numeric(lon$value))) } @@ -80,12 +71,10 @@ getLatLon <- function(nc1) { ##' @param verbose should ouput of function be extra verbose ##' ##' @author Josh Mantooth, Mike Dietze, Elizabeth Cowdery, Ankur Desai -##' @importFrom ncdf4 ncvar_get ncatt_get ncdim_def ncvar_def ncvar_add ncvar_put ncatt_put met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { #---------------- Load libraries. -----------------------------------------------------------------# - library(PEcAn.utils) library(geonames) ## has to be loaded as a library #--------------------------------------------------------------------------------------------------# @@ -150,21 +139,21 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date tdim$units <- paste(tdim$units, lststr, sep = " ") } - lat <- ncdim_def(name = "latitude", units = "", vals = 1:1, create_dimvar = FALSE) - lon <- ncdim_def(name = "longitude", units = "", vals = 1:1, create_dimvar = FALSE) - time <- ncdim_def(name = "time", units = tdim$units, vals = tdim$vals, + lat <- ncdf4::ncdim_def(name = "latitude", units = "", vals = 1:1, create_dimvar = FALSE) + lon <- ncdf4::ncdim_def(name = "longitude", units = "", vals = 1:1, create_dimvar = FALSE) + time <- ncdf4::ncdim_def(name = "time", units = tdim$units, vals = tdim$vals, create_dimvar = TRUE, unlim = TRUE) dim <- list(lat, lon, time) # copy lat attribute to latitude - var <- ncvar_def(name = "latitude", units = "degree_north", dim = list(lat, lon), missval = as.numeric(-9999)) + var <- ncdf4::ncvar_def(name = "latitude", units = "degree_north", dim = list(lat, lon), missval = as.numeric(-9999)) nc2 <- ncdf4::nc_create(filename = new.file, vars = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "latitude", vals = latlon[1]) + ncdf4::ncvar_put(nc = nc2, varid = "latitude", vals = latlon[1]) # copy lon attribute to longitude - var <- ncvar_def(name = "longitude", units = "degree_east", dim = list(lat, lon), missval = as.numeric(-9999)) - nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "longitude", vals = latlon[2]) + var <- ncdf4::ncvar_def(name = "longitude", units = "degree_east", dim = list(lat, lon), missval = as.numeric(-9999)) + nc2 <- ncdf4::ncvar_add(nc = nc2, v = var, verbose = verbose) + ncdf4::ncvar_put(nc = nc2, varid = "longitude", vals = latlon[2]) # Convert all variables # This will include conversions or computations to create values from original file. @@ -177,17 +166,17 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date # convert RH to SH # this conversion needs to come before others to reinitialize dimension used by copyvals (lat/lon/time) - rh <- ncvar_get(nc = nc1, varid = "RH") + rh <- ncdf4::ncvar_get(nc = nc1, varid = "RH") rh[rh == -6999 | rh == -9999] <- NA rh <- rh/100 - ta <- ncvar_get(nc = nc1, varid = "TA") + ta <- ncdf4::ncvar_get(nc = nc1, varid = "TA") ta[ta == -6999 | ta == -9999] <- NA ta <- udunits2::ud.convert(ta, "degC", "K") sh <- rh2qair(rh = rh, T = ta) - var <- ncvar_def(name = "specific_humidity", units = "kg/kg", dim = dim, + var <- ncdf4::ncvar_def(name = "specific_humidity", units = "kg/kg", dim = dim, missval = -6999, verbose = verbose) - nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "specific_humidity", vals = sh) + nc2 <- ncdf4::ncvar_add(nc = nc2, v = var, verbose = verbose) + ncdf4::ncvar_put(nc = nc2, varid = "specific_humidity", vals = sh) # convert TA to air_temperature copyvals(nc1 = nc1, var1 = "TA", nc2 = nc2, @@ -270,30 +259,30 @@ met2CF.Ameriflux <- function(in.path, in.prefix, outfolder, start_date, end_date verbose = verbose) # convert wind speed and wind direction to eastward_wind and northward_wind - wd <- ncvar_get(nc = nc1, varid = "WD") #wind direction + wd <- ncdf4::ncvar_get(nc = nc1, varid = "WD") #wind direction wd[wd == -6999 | wd == -9999] <- NA - ws <- ncvar_get(nc = nc1, varid = "WS") #wind speed + ws <- ncdf4::ncvar_get(nc = nc1, varid = "WS") #wind speed ws[ws == -6999 | ws == -9999] <- NA ew <- ws * cos(wd * (pi / 180)) nw <- ws * sin(wd * (pi / 180)) - max <- ncatt_get(nc = nc1, varid = "WS", "valid_max")$value + max <- ncdf4::ncatt_get(nc = nc1, varid = "WS", "valid_max")$value - var <- ncvar_def(name = "eastward_wind", units = "m/s", dim = dim, missval = -6999, verbose = verbose) - nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "eastward_wind", vals = ew) - ncatt_put(nc = nc2, varid = "eastward_wind", attname = "valid_min", attval = -max) - ncatt_put(nc = nc2, varid = "eastward_wind", attname = "valid_max", attval = max) + var <- ncdf4::ncvar_def(name = "eastward_wind", units = "m/s", dim = dim, missval = -6999, verbose = verbose) + nc2 <- ncdf4::ncvar_add(nc = nc2, v = var, verbose = verbose) + ncdf4::ncvar_put(nc = nc2, varid = "eastward_wind", vals = ew) + ncdf4::ncatt_put(nc = nc2, varid = "eastward_wind", attname = "valid_min", attval = -max) + ncdf4::ncatt_put(nc = nc2, varid = "eastward_wind", attname = "valid_max", attval = max) - var <- ncvar_def(name = "northward_wind", units = "m/s", dim = dim, missval = -6999, verbose = verbose) - nc2 <- ncvar_add(nc = nc2, v = var, verbose = verbose) - ncvar_put(nc = nc2, varid = "northward_wind", vals = nw) - ncatt_put(nc = nc2, varid = "northward_wind", attname = "valid_min", attval = -max) - ncatt_put(nc = nc2, varid = "northward_wind", attname = "valid_max", attval = max) + var <- ncdf4::ncvar_def(name = "northward_wind", units = "m/s", dim = dim, missval = -6999, verbose = verbose) + nc2 <- ncdf4::ncvar_add(nc = nc2, v = var, verbose = verbose) + ncdf4::ncvar_put(nc = nc2, varid = "northward_wind", vals = nw) + ncdf4::ncatt_put(nc = nc2, varid = "northward_wind", attname = "valid_min", attval = -max) + ncdf4::ncatt_put(nc = nc2, varid = "northward_wind", attname = "valid_max", attval = max) # add global attributes from original file - cp.global.atts <- ncatt_get(nc = nc1, varid = 0) + cp.global.atts <- ncdf4::ncatt_get(nc = nc1, varid = 0) for (j in seq_along(cp.global.atts)) { - ncatt_put(nc = nc2, varid = 0, attname = names(cp.global.atts)[j], attval = cp.global.atts[[j]]) + ncdf4::ncatt_put(nc = nc2, varid = 0, attname = names(cp.global.atts)[j], attval = cp.global.atts[[j]]) } # done, close both files From 749a72e64d2c7601c098d108dd9a59dbdb67764a Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 5 Sep 2017 12:07:21 -0400 Subject: [PATCH 546/771] Update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 08b7ff463f5..9cd9c408313 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -18,6 +18,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Fixed FATES build script to work on ubuntu - SIPNET output netcdf now includes LAI; some variable names changed to match standard - Cleanup of leap year logic, using new `PEcAn.utils::days_in_year(year)` function (#801). +- Replace many hard-coded unit conversions with `udunits2::ud.convert` for consistency, readability, and clarity ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) From 717b2b71e64064be52e70e4eb5febb7d4928cd62 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Tue, 5 Sep 2017 13:25:50 -0400 Subject: [PATCH 547/771] fix co2 conversion and typo --- models/preles/R/runPRELES.jobsh.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index 499b1a8bcc3..83423c745ac 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -93,7 +93,7 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star vpd <- udunits2::ud.convert(tapply(VPD, doy, mean, na.rm = TRUE), "Pa", "kPa") # pascal to kila pascal precip <- tapply(Precip, doy, sum, na.rm = TRUE) # Sum to daily precipitation co2 <- tapply(CO2, doy, mean) # need daily average, so sum up day - co2 <- co2 / 1e+06 # convert to ppm + co2 <- co2 * 1e+06 # convert to ppm doy <- tapply(doy, doy, mean) # day of year fapar <- rep(0.6, length = length(doy)) # For now set to 0.6. Needs to be between 0-1 @@ -186,7 +186,7 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star var[[2]] <- PEcAn.utils::to_ncvar("Evapotranspiration", dims) var[[3]] <- PEcAn.utils::to_ncvar("SoilMoist", dims) var[[4]] <- PEcAn.utils::to_ncvar("fWE", dims) - var[[5]] <- PEcAn.utils::to_ncvarf("fW", dims) + var[[5]] <- PEcAn.utils::to_ncvar("fW", dims) var[[6]] <- PEcAn.utils::to_ncvar("Evap", dims) var[[7]] <- PEcAn.utils::to_ncvar("TVeg", dims) From b3b3f7e54cbc335fe73e11b54c2c974d1f39dfde Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 5 Sep 2017 12:35:39 -0500 Subject: [PATCH 548/771] align.met: Add source ensemble case Add code so that align.met can manipulate an ensemble of source data that will get fed into debiasing or temporal downscaling workflows --- modules/data.atmosphere/R/align_met.R | 145 +++++++++++++++++++++++++- 1 file changed, 140 insertions(+), 5 deletions(-) diff --git a/modules/data.atmosphere/R/align_met.R b/modules/data.atmosphere/R/align_met.R index 92e6c682248..5f769530dc1 100644 --- a/modules/data.atmosphere/R/align_met.R +++ b/modules/data.atmosphere/R/align_met.R @@ -67,7 +67,7 @@ #---------------------------------------------------------------------- # Begin Function #---------------------------------------------------------------------- -align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair.mems = TRUE, seed=Sys.Date(), verbose = FALSE) { +align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair.mems = FALSE, seed=Sys.Date(), verbose = FALSE) { # Load required libraries library(ncdf4) library(lubridate) @@ -130,8 +130,10 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. ens.train <- dir(train.path) if(is.null(n.ens)) n.ens <- length(ens.train) - if(length(ens.train)>n.ens) ens.train <- ens.train[sample(1:length(ens.train), n.ens)] - n.trn=n.ens + if(length(ens.train)>n.ens) { + train.use <- sample(1:length(ens.train), n.ens) + ens.train <- ens.train[train.use] + } # getting an estimate of how many files we need to process yrs.file <- strsplit(dir(file.path(train.path, ens.train[1])), "[.]") @@ -304,8 +306,141 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. } # End looping through source met files print("") } else { # we have an ensemble we need to deal with - stop("Source ensemble mode not implemented yet!") - } # End loading & formatting training data + ens.source <- dir(source.path) + + # If we're matching ensemble members need to use the same ones as from the training data + if(pair.ens==TRUE){ + if(length(ens.source) < ens.train) stop("Cannot pair ensemble members. Reset pair.ens to FALSE or check your file paths") + + ens.source <- ens.source[train.use] + } else { + # Figure out whether or not we need to subsample or repeat ensemble members + if(length(ens.source)>=n.ens){ + source.use <- sample(1:length(ens.source), n.ens) + } else { + source.use <- sample(1:length(ens.source), n.ens, replace = TRUE) + } + + ens.source <- ens.source[source.use] + } + n.src = n.ens + + # getting an estimate of how many files we need to process + n.files <- length(dir(file.path(source.path, ens.source[1]))) + + print("Processing Source Data") + pb <- txtProgressBar(min=0, max=length(ens.source)*n.files, style=3) + pb.ind=1 + for(j in 1:length(ens.source)){ + # Get a list of the files we'll be downscaling + files.source <- dir(file.path(source.path, ens.source[j]), ".nc") + + # create a vector of the years + yrs.file <- strsplit(files.source, "[.]") + yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) + yrs.file <- as.numeric(yrs.file[,ncol(yrs.file)-1]) # Assumes year is always last thing before the file extension + + # Getting the day & hour timesteps from the training data + day.train <- round(365/length(unique(met.out$dat.train$time$DOY))) + hr.train <- 24/length(unique(met.out$dat.train$time$Hour)) + + # Loop through the .nc files putting everything into a list + dat.ens <- list() + for(i in 1:length(files.source)){ + yr.now <- yrs.file[i] + + ncT <- nc_open(file.path(source.path, ens.source[j], files.source[i])) + + # Set up the time data frame to help index + nday <- ifelse(leap_year(yr.now), 366, 365) + ntime <- length(ncT$dim$time$vals) + step.day <- nday/ntime + step.hr <- step.day*24 + + # ----- + # Making time stamps to match the training data + # For coarser time step than the training data, we'll duplicate in the loop + # ----- + # Making what the unique time stamps should be to match the training data + stamps.hr <- seq(hr.train/2, by=hr.train, length.out=1/day.train) + stamps.src <- stamps.hr + + if(step.hr < hr.train){ # Finer hour increment --> set it up to aggregate + align = "aggregate" + stamps.src <- rep(stamps.hr, each=24/step.hr) + } else if(step.hr > hr.train) { # Set the flag to duplicate the data + align = "repeat" + } else { # things are aligned, so we're fine + align = "aligned" + } + # ----- + + # Create a data frame with all the important time info + # center the hour step + df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/day.train), Hour=rep(stamps.hr, length.out=nday/day.train)) + df.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") + + # Create a data frame with all the important time info + # center the hour step + # ** Only do this with the first ensemble member so we're not being redundant + if(j==1){ + met.out$dat.source[["time"]] <- rbind(met.out$dat.source$time, df.time) + } + + src.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/step.day), Hour=rep(stamps.src, length.out=ntime)) + src.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") + + # Extract the met info, making matrices with the appropriate number of ensemble members + for(v in names(ncT$var)){ + dat.tem <- ncvar_get(ncT, v) + + if(align=="repeat"){ # if we need to coerce the time step to be repeated to match temporal resolution, do it here + dat.tem <- rep(dat.temp, each=stamps.hr) + } + df.tem <- matrix(rep(dat.tem, n.src), ncol=1, byrow=F) + + # If we need to aggregate the data to align it, do it now to save memory + if(align == "aggregate"){ + df.tem <- cbind(src.time, data.frame(df.tem)) + + df.agg <- aggregate(df.tem[,(4+1:n.src)], by=df.tem[,c("Year", "DOY", "Hour")], FUN=mean) + dat.ens[[v]] <- rbind(dat.ens[[v]], as.matrix(df.agg[,(3+1:n.src)])) + + # if working with air temp, also find the max & min + if(v=="air_temperature"){ + tmin <- aggregate(df.tem[,(4+1:n.src)], by=df.tem[,c("Year", "DOY", "Hour")], FUN=min) + tmax <- aggregate(df.tem[,(4+1:n.src)], by=df.tem[,c("Year", "DOY", "Hour")], FUN=max) + + dat.ens[["air_temperature_minimum"]] <- rbind(dat.ens[["air_temperature_minimum"]], as.matrix(tmin[,(3+1:n.src)])) + dat.ens[["air_temperature_maximum"]] <- rbind(dat.ens[["air_temperature_maximum"]], as.matrix(tmax[,(3+1:n.src)])) + } + } else { + dat.ens[[v]] <- rbind(dat.ens[[v]], df.tem) + } + + # If met doesn't need to be aggregated, just copy it in + if(align %in% c("repeat", "align")) { + dat.ens[[v]] <- rbind(dat.ens[[v]], as.matrix(df.tem, ncol=n.src)) + } + } #End variable loop + nc_close(ncT) + setTxtProgressBar(pb, pb.ind) + pb.ind <- pb.ind+1 + } # End looping through source met files + + # Storing the ensemble member data in our output list + for(v in names(dat.ens)){ + met.out$dat.source[[v]] <- cbind(met.out$dat.source[[v]], dat.ens[[v]]) + } + } # End loading & formatting source ensemble members + + # Storing info about the ensemble members + for(v in 2:length(met.out$dat.source)){ + dimnames(met.out$dat.source[[v]])[[2]] <- ens.source + } + + } # End loading & formatting source data + print("") # --------------- From 0fbbdea95ff68fa62997a1c849ed2d0996dbbca9 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 5 Sep 2017 13:10:11 -0500 Subject: [PATCH 549/771] align.met bug fix Had the data repeating and causing problems. Probably could use a code restructure, but setting n.src to 1 seems to fix the problem for now. --- modules/data.atmosphere/R/align_met.R | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/modules/data.atmosphere/R/align_met.R b/modules/data.atmosphere/R/align_met.R index 5f769530dc1..7b44f652cd7 100644 --- a/modules/data.atmosphere/R/align_met.R +++ b/modules/data.atmosphere/R/align_met.R @@ -293,13 +293,9 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. met.out$dat.source[["air_temperature_maximum"]] <- rbind(met.out$dat.source[["air_temperature_maximum"]], as.matrix(tmax[,(3+1:n.src)])) } } else { - met.out$dat.source[[v]] <- rbind(met.out$dat.source[[v]], df.tem) + met.out$dat.source[[v]] <- rbind(met.out$dat.source[[v]], as.matrix(df.tem, ncol=1)) } - # If met doesn't need to be aggregated, just copy it in - if(align %in% c("repeat", "align")) { - met.out$dat.source[[v]] <- rbind(met.out$dat.source[[v]], as.matrix(df.tem, ncol=n.src)) - } } ncdf4::nc_close(ncT) setTxtProgressBar(pb, i) @@ -323,7 +319,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. ens.source <- ens.source[source.use] } - n.src = n.ens + n.src = 1 # Potential to redo places where n.src is currently; this is based on out-dated code # getting an estimate of how many files we need to process n.files <- length(dir(file.path(source.path, ens.source[1]))) @@ -415,13 +411,9 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. dat.ens[["air_temperature_maximum"]] <- rbind(dat.ens[["air_temperature_maximum"]], as.matrix(tmax[,(3+1:n.src)])) } } else { - dat.ens[[v]] <- rbind(dat.ens[[v]], df.tem) + dat.ens[[v]] <- rbind(dat.ens[[v]], as.matrix(df.tem, ncol=1)) } - # If met doesn't need to be aggregated, just copy it in - if(align %in% c("repeat", "align")) { - dat.ens[[v]] <- rbind(dat.ens[[v]], as.matrix(df.tem, ncol=n.src)) - } } #End variable loop nc_close(ncT) setTxtProgressBar(pb, pb.ind) From 3a0f595b9377e2d10181593470340cb174c5bbdf Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 5 Sep 2017 14:17:16 -0500 Subject: [PATCH 550/771] Update align.met documents Fixing a build problem by updating the align.met documents to reflect the change in default case made in a previous commit --- modules/data.atmosphere/R/align_met.R | 2 +- modules/data.atmosphere/man/align.met.Rd | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/data.atmosphere/R/align_met.R b/modules/data.atmosphere/R/align_met.R index 7b44f652cd7..1e06ca315d6 100644 --- a/modules/data.atmosphere/R/align_met.R +++ b/modules/data.atmosphere/R/align_met.R @@ -41,7 +41,7 @@ ##' will be loaded. If not null, should be a vector of numbers (so you can skip ##' problematic years) ##' @param n.ens - number of ensemble members to generate and save -##' @param pair.mems - (not implemented) logical stating whether ensemble members should be paired in +##' @param pair.mems - logical stating whether ensemble members should be paired in ##' the case where ensembles are being read in in both the training and source data ##' @param seed - specify seed so that random draws can be reproduced ##' @param verbose diff --git a/modules/data.atmosphere/man/align.met.Rd b/modules/data.atmosphere/man/align.met.Rd index 35718504aec..6251e69a1e5 100644 --- a/modules/data.atmosphere/man/align.met.Rd +++ b/modules/data.atmosphere/man/align.met.Rd @@ -5,7 +5,7 @@ \title{align.met} \usage{ align.met(train.path, source.path, yrs.train = NULL, n.ens = NULL, - pair.mems = TRUE, seed = Sys.Date(), verbose = FALSE) + pair.mems = FALSE, seed = Sys.Date(), verbose = FALSE) } \arguments{ \item{train.path}{- path to the dataset to be used to downscale the data} @@ -19,7 +19,7 @@ problematic years)} \item{n.ens}{- number of ensemble members to generate and save} -\item{pair.mems}{- (not implemented) logical stating whether ensemble members should be paired in +\item{pair.mems}{- logical stating whether ensemble members should be paired in the case where ensembles are being read in in both the training and source data} \item{seed}{- specify seed so that random draws can be reproduced} From f442325c6f3a807d7a4814f96dc22b52a4093b53 Mon Sep 17 00:00:00 2001 From: araiho Date: Tue, 5 Sep 2017 18:41:23 -0400 Subject: [PATCH 551/771] fixing errors breaking build and typos with xml --- .../StateAssimilation/TreeRingSDA.Rmd | 18 +++++++----------- models/linkages/R/model2netcdf.LINKAGES.R | 15 +-------------- 2 files changed, 8 insertions(+), 25 deletions(-) diff --git a/documentation/tutorials/StateAssimilation/TreeRingSDA.Rmd b/documentation/tutorials/StateAssimilation/TreeRingSDA.Rmd index 0f6fac510a0..baba56ad568 100644 --- a/documentation/tutorials/StateAssimilation/TreeRingSDA.Rmd +++ b/documentation/tutorials/StateAssimilation/TreeRingSDA.Rmd @@ -45,12 +45,8 @@ Perform a site-level SIPNET run using the following settings FALSE TRUE - 1000000040 - - - 1000013298 - + 1000013298 @@ -61,37 +57,37 @@ Perform a site-level SIPNET run using the following settings AbvGrndWood - KgC/m^2 + KgC/m^2 0 9999 TotSoilCarb - KgC/m^2 + KgC/m^2 0 9999 LeafC - m^2/m^2 + m^2/m^2 0 9999 SoilMoistFrac - + 0 9999 SWE - cm + cm 0 9999 Litter - gC/m^2 + gC/m^2 0 9999 diff --git a/models/linkages/R/model2netcdf.LINKAGES.R b/models/linkages/R/model2netcdf.LINKAGES.R index ea7bee82c39..0b615407fea 100644 --- a/models/linkages/R/model2netcdf.LINKAGES.R +++ b/models/linkages/R/model2netcdf.LINKAGES.R @@ -93,9 +93,7 @@ model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, e var[[2]] <- PEcAn.utils::to_ncvar("TotLivBiomass", dims) var[[3]] <- PEcAn.utils::to_ncvar("TotSoilCarb", dims) var[[4]] <- ncdf4::ncvar_def("CarbPools", "kgC/m2", list(dim.cpools, dim.lat, dim.lon, dim.t), -999) - var[[5]] <- ncdf4::ncvar_def("poolnames", units = "", dim = list(dim.string, dim.cpools1), - longname = "Carbon Pool Names", prec = "char") -<<<<<<< HEAD + var[[5]] <- ncdf4::ncvar_def("poolnames", units = "", dim = list(dim.string, dim.cpools1), longname = "Carbon Pool Names", prec = "char") var[[6]] <- ncvar_def("GWBI", "kgC/m2", list(dim.lat, dim.lon, dim.t), -999) var[[7]] <- ncvar_def("HeteroResp", "kgC/m2/s", list(dim.lat, dim.lon, dim.t), -999) var[[8]] <- ncvar_def("NPP", "kgC/m2/s", list(dim.lat, dim.lon, dim.t), -999) @@ -106,17 +104,6 @@ model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, e var[[13]] <- ncvar_def("LAI", "m2/m2", list(dim.lat, dim.lon, dim.t), -999) var[[14]] <- ncvar_def("SoilMoist", "m2/m2", list(dim.lat, dim.lon, dim.t), -999) var[[15]] <- ncvar_def("AbvGrndWood", "kgC/m2", list(dim.lat, dim.lon, dim.t), -999) -======= - var[[6]] <- PEcAn.utils::to_ncvar("GWBI", dims) - var[[7]] <- PEcAn.utils::to_ncvar("HeteroResp", dims) - var[[8]] <- PEcAn.utils::to_ncvar("NPP", dims) - var[[9]] <- PEcAn.utils::to_ncvar("NEE", dims) - var[[10]] <- PEcAn.utils::to_ncvar("Evap", dims) - var[[11]] <- PEcAn.utils::to_ncvar("AGB.pft", dims) - var[[12]] <- PEcAn.utils::to_ncvar("Fcomp", dims) - var[[13]] <- PEcAn.utils::to_ncvar("LAI", dims) - var[[14]] <- PEcAn.utils::to_ncvar("SoilMoist", dims) ->>>>>>> 009e165d50f7e59bc9732677156c291cde4ee459 # ******************** Declare netCDF variables ********************# From 58112a0e4285cd77ee4f98438cbb5ce927f7c045 Mon Sep 17 00:00:00 2001 From: araiho Date: Tue, 5 Sep 2017 22:42:38 -0400 Subject: [PATCH 552/771] adding flag for ensemble adjustment math --- modules/assim.sequential/R/sda.enkf.R | 71 ++++++++++++--------------- 1 file changed, 32 insertions(+), 39 deletions(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index 86cd7f5d52f..0ce642782f3 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -7,13 +7,14 @@ ##' @param obs.cov list of observations of covariance matrices of state variables (time X nstate X nstate) ##' @param IC initial conditions ##' @param Q process covariance matrix given if there is no data to estimate it +##' @param adjustment flag for using ensemble adjustment filter or not ##' ##' @description State Variable Data Assimilation: Ensemble Kalman Filter ##' ##' @return NONE ##' @export ##' -sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { +sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL, adjustment = TRUE) { library(nimble) @@ -172,7 +173,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { dir.create(file.path(settings$modeloutdir, run.id[[i]]), recursive = TRUE) ## Write Configs - do.call(my.write.config, args = list(defaults = NULL, + do.call(what = my.write.config, args = list(defaults = NULL, trait.values = params[[i]], settings = settings, run.id = run.id[[i]], @@ -738,45 +739,37 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) { ###-------------------------------------------------------------------### ### update state matrix ### ###-------------------------------------------------------------------### - S_f <- svd(Pf) - L_f <- S_f$d - V_f <- S_f$v - - ## normalize - Z <- X*0 - for(i in seq_len(nens)){ - Z[i,] <- 1/sqrt(L_f) * t(V_f)%*%(X[i,]-mu.f) - } - Z[is.na(Z)]<-0 - - ## analysis - #mu_a <- c(10,-3) - #D <- sqrt(diag(c(3,1))) - #R <- matrix(c(1,-0.75,-0.75,1),2,2) - #P_a <- D%*%R%*%D - S_a <- svd(Pa) - L_a <- S_a$d - V_a <- S_a$v - - ## analysis ensemble - X_a <- X*0 - for(i in seq_len(nens)){ - X_a[i,] <- V_a %*%diag(sqrt(L_a))%*%Z[i,] + mu.a + if(adjustment == TRUE){ + S_f <- svd(Pf) + L_f <- S_f$d + V_f <- S_f$v + + ## normalize + Z <- X*0 + for(i in seq_len(nens)){ + Z[i,] <- 1/sqrt(L_f) * t(V_f)%*%(X[i,]-mu.f) + } + Z[is.na(Z)]<-0 + + ## analysis + S_a <- svd(Pa) + L_a <- S_a$d + V_a <- S_a$v + + ## analysis ensemble + X_a <- X*0 + for(i in seq_len(nens)){ + X_a[i,] <- V_a %*%diag(sqrt(L_a))%*%Z[i,] + mu.a + } + + if(sum(mu.a-colMeans(X_a))>1) logger.warn('Problem with ensemble adjustment (1)') + if(sum(diag(Pa),diag(cov(X_a)))>5) logger.warn('Problem with ensemble adjustment (2)') + + analysis <- as.data.frame(X_a) + }else{ + analysis <- as.data.frame(rmvnorm(as.numeric(nens), mu.a, Pa, method = "svd")) } - # par(mfrow=c(1,1)) - # plot(X_a) - # ## check if ensemble mean is correct - # cbind(mu.a,colMeans(X_a)) - if(sum(mu.a-colMeans(X_a))>1) logger.warn('Problem with ensemble adjustment (1)') - if(sum(diag(Pa),diag(cov(X_a)))>5) logger.warn('Problem with ensemble adjustment (2)') - # ## check if ensemble var is correct - # cbind(diag(Pa),diag(cov(X_a))) ## just variances - # cbind(as.vector(Pa),as.vector(cov(X_a))) ## full cov - # - #analysis <- as.data.frame(rmvnorm(as.numeric(nens), mu.a, Pa, method = "svd")) - - analysis <- as.data.frame(X_a) colnames(analysis) <- colnames(X) ##### Mapping analysis vectors to be in bounds of state variables From 6237d24a66f4162b0a47f43ca709d5d945a70bab Mon Sep 17 00:00:00 2001 From: araiho Date: Tue, 5 Sep 2017 22:43:24 -0400 Subject: [PATCH 553/771] taking out ciEnvelope function because it is contained in pecan.all --- modules/assim.sequential/inst/paleon_sda.R | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/modules/assim.sequential/inst/paleon_sda.R b/modules/assim.sequential/inst/paleon_sda.R index 3c424c47b1b..a0e63cd23d1 100644 --- a/modules/assim.sequential/inst/paleon_sda.R +++ b/modules/assim.sequential/inst/paleon_sda.R @@ -6,16 +6,12 @@ library(PEcAn.assim.sequential) library(nimble) library(lubridate) -ciEnvelope <- function(x,ylo,yhi,...){ - polygon(cbind(c(x, rev(x), x[1]), c(ylo, rev(yhi), - ylo[1])), border = NA,...) -} - #LINKAGES #AGB.pft #Harvard Forest -setwd('/fs/data2/output//PEcAn_1000003314/') -setwd('/fs/data2/output//PEcAn_1000007999/') +#setwd('/fs/data2/output//PEcAn_1000003314/') +#setwd('/fs/data2/output//PEcAn_1000007999/') #full run 50 nens +setwd('/fs/data2/output//PEcAn_1000008008/') +file.copy('/fs/data2/output//PEcAn_1000007999/sda.obs.Rdata',getwd()) #TO DO: Having problem with running proc.var == TRUE because nimble isn't keeping the toggle sampler in the function environment. -#TO DO: Intial conditions for linkages are messed up. Need to calibrate. #SIPNET @@ -40,10 +36,10 @@ colnames(state)<-c('AGB','NPP') IC <- sample.IC.SIPNET(ne, state = state) status.end() - PEcAn.assim.sequential::sda.enkf(settings, obs.mean = obs.list$obs.mean, obs.cov = obs.list$obs.cov, IC = IC) -for(i in 1:10){ - obs.cov[[i]][2,2]<-obs.cov[[i]][2,2]*100000 +for(i in 2:length(obs.mean)){ + obs.mean[[i]]<-NA + obs.cov[[i]]<-NA } From 29ae9f14905c0548ab77a0deb4c362abf38945c9 Mon Sep 17 00:00:00 2001 From: araiho Date: Tue, 5 Sep 2017 22:44:31 -0400 Subject: [PATCH 554/771] uncommenting legend for now. Need to learn how to scale so it doesn't take up whole frame. --- modules/assim.sequential/R/sda.enkf.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index 0ce642782f3..b8ca1906b35 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -863,7 +863,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL, adjustmen # analysis ciEnvelope(as.Date(obs.times[t1:t]), XaCI[, 1], XaCI[, 2], col = alphapink) lines(as.Date(obs.times[t1:t]), Xa, col = "black", lty = 2, lwd = 2) - #legend('topright',c('Forecast','Data','Analysis'),col=c(alphablue,alphagreen,alphapink),lty=1,lwd=5) + legend('topright',c('Forecast','Data','Analysis'),col=c(alphablue,alphagreen,alphapink),lty=1,lwd=5) } } From 944da652e6e5a9ee00080f8fd0260a122b4a3303 Mon Sep 17 00:00:00 2001 From: araiho Date: Tue, 5 Sep 2017 22:46:21 -0400 Subject: [PATCH 555/771] adding commment about why there is a hardcoded density dependence in write.restart.linkages --- models/linkages/R/write_restart.LINKAGES.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/models/linkages/R/write_restart.LINKAGES.R b/models/linkages/R/write_restart.LINKAGES.R index 289b8d2059f..145ac77db66 100644 --- a/models/linkages/R/write_restart.LINKAGES.R +++ b/models/linkages/R/write_restart.LINKAGES.R @@ -215,6 +215,8 @@ write_restart.LINKAGES <- function(outdir, runid, start.time, stop.time, setting } } + #making sure to stick with density dependence rules in linkages (< 198 trees per 800/m^2) + #someday we could think about estimating this parameter from data if(sum(new.ntrees) > 198) new.ntrees <- round((new.ntrees / sum(new.ntrees)) * runif(1,160,195)) print(paste0("new.ntrees =", new.ntrees)) From f76838034e6e28d23ba7b44ced319dcb613ba118 Mon Sep 17 00:00:00 2001 From: araiho Date: Tue, 5 Sep 2017 22:53:19 -0400 Subject: [PATCH 556/771] ran make document for new flag argument --- modules/assim.sequential/man/sda.enkf.Rd | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/modules/assim.sequential/man/sda.enkf.Rd b/modules/assim.sequential/man/sda.enkf.Rd index 4f4403a97d7..b2ad2b68fe2 100644 --- a/modules/assim.sequential/man/sda.enkf.Rd +++ b/modules/assim.sequential/man/sda.enkf.Rd @@ -4,7 +4,8 @@ \alias{sda.enkf} \title{sda.enkf} \usage{ -sda.enkf(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) +sda.enkf(settings, obs.mean, obs.cov, IC = NULL, Q = NULL, + adjustment = TRUE) } \arguments{ \item{settings}{PEcAn settings object} @@ -16,6 +17,8 @@ sda.enkf(settings, obs.mean, obs.cov, IC = NULL, Q = NULL) \item{IC}{initial conditions} \item{Q}{process covariance matrix given if there is no data to estimate it} + +\item{adjustment}{flag for using ensemble adjustment filter or not} } \value{ NONE From 0ab52c83240d95de5dcb217858ea6998241c4eb9 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Tue, 5 Sep 2017 23:06:49 -0400 Subject: [PATCH 557/771] `::`-qualify data.table and PEcAn.utils calls --- models/biocro/NAMESPACE | 2 -- models/biocro/R/get.model.output.BIOCRO.R | 3 +-- models/biocro/R/met2model.BIOCRO.R | 1 - models/biocro/R/model2netcdf.BIOCRO.R | 4 +--- models/biocro/R/run.biocro.R | 17 ++++++++--------- 5 files changed, 10 insertions(+), 17 deletions(-) diff --git a/models/biocro/NAMESPACE b/models/biocro/NAMESPACE index 5c01df54ab9..344877d115e 100644 --- a/models/biocro/NAMESPACE +++ b/models/biocro/NAMESPACE @@ -9,6 +9,4 @@ export(read.biocro.config) export(remove.config.BIOCRO) export(run.biocro) export(write.config.BIOCRO) -import(PEcAn.utils) -import(data.table) importFrom(data.table,":=") diff --git a/models/biocro/R/get.model.output.BIOCRO.R b/models/biocro/R/get.model.output.BIOCRO.R index 71c49bfaa41..6dc7d540691 100644 --- a/models/biocro/R/get.model.output.BIOCRO.R +++ b/models/biocro/R/get.model.output.BIOCRO.R @@ -12,14 +12,13 @@ ##' @name get.model.output.BIOCRO ##' @title Retrieve model output from local server ##' @param settings list generated from \code{\link{read.settings}} function applied to settings file -##' @import PEcAn.utils ##' @export ##' @author Mike Dietze, David LeBauer get.model.output.BIOCRO <- function(settings) { ### Get model output on the localhost if (settings$host$name == "localhost") { - get.results(settings = settings) + PEcAn.utils::get.results(settings = settings) } else { print(paste("biocro model specific get.model.output not implemented for\n", "use on remote host; generic get.model.output under development")) diff --git a/models/biocro/R/met2model.BIOCRO.R b/models/biocro/R/met2model.BIOCRO.R index 4686507aac9..e02c18b22bb 100644 --- a/models/biocro/R/met2model.BIOCRO.R +++ b/models/biocro/R/met2model.BIOCRO.R @@ -134,7 +134,6 @@ met2model.BIOCRO <- function(in.path, in.prefix, outfolder, overwrite = FALSE, ##' \item {precip} {cm/h} ##' } ##' @export cf2biocro -##' @import PEcAn.utils ##' @importFrom data.table := ##' @author David LeBauer cf2biocro <- function(met, longitude = NULL, zulu2solarnoon = FALSE) { diff --git a/models/biocro/R/model2netcdf.BIOCRO.R b/models/biocro/R/model2netcdf.BIOCRO.R index 08d39641f1a..9f06645f1f6 100644 --- a/models/biocro/R/model2netcdf.BIOCRO.R +++ b/models/biocro/R/model2netcdf.BIOCRO.R @@ -22,8 +22,6 @@ ##' @param lat Latitude of the site ##' @param lon Longitude of the site ##' @export -##' @import data.table -##' @import PEcAn.utils ##' @author David LeBauer, Deepak Jaiswal, Rob Kooper model2netcdf.BIOCRO <- function(result, genus = NULL, outdir, lat = -9999, lon = -9999) { @@ -31,7 +29,7 @@ model2netcdf.BIOCRO <- function(result, genus = NULL, outdir, lat = -9999, lon = result$hour <- 0 } if (all(c("year", "hour", "doy") %in% colnames(result))) { - setnames(result, c("year", "hour", "doy"), c("Year", "Hour", "DayofYear")) + data.table::setnames(result, c("year", "hour", "doy"), c("Year", "Hour", "DayofYear")) } ## longname prefix station_* used for a point diff --git a/models/biocro/R/run.biocro.R b/models/biocro/R/run.biocro.R index ccc3ebf7890..6dcb7bbe075 100644 --- a/models/biocro/R/run.biocro.R +++ b/models/biocro/R/run.biocro.R @@ -9,7 +9,6 @@ #' @param coppice.interval numeric, number of years between cuttings for coppice plant or perinneal grass (default 1) #' @return output from one of the \code{BioCro::*.Gro} functions (determined by \code{config$genus}), as data.table object #' @export -#' @import data.table #' @author David LeBauer run.biocro <- function(lat, lon, metpath, soil.nc = NULL, config = config, coppice.interval = 1) { l2n <- function(x) lapply(x, as.numeric) @@ -89,13 +88,13 @@ run.biocro <- function(lat, lon, metpath, soil.nc = NULL, config = config, coppi if (i == 1) { iplant <- config$pft$iPlantControl } else { - iplant$iRhizome <- last(tmp.result$Rhizome) - iplant$iRoot <- last(tmp.result$Root) - iplant$iStem <- last(tmp.result$Stem) + iplant$iRhizome <- data.table::last(tmp.result$Rhizome) + iplant$iRoot <- data.table::last(tmp.result$Root) + iplant$iStem <- data.table::last(tmp.result$Stem) if ((i - 1)%%coppice.interval == 0) { # coppice when remainder = 0 - HarvestedYield <- round(last(tmp.result$Stem) * 0.95, 2) + HarvestedYield <- round(data.table::last(tmp.result$Stem) * 0.95, 2) } else if ((i - 1)%%coppice.interval == 1) { # year after coppice @@ -119,8 +118,8 @@ run.biocro <- function(lat, lon, metpath, soil.nc = NULL, config = config, coppi if (yeari == years[1]) { iRhizome <- config$pft$iPlantControl$iRhizome } else { - iRhizome <- last(tmp.result$Rhizome) - HarvestedYield <- round(last(tmp.result$Stem) * 0.95, 2) + iRhizome <- data.table::last(tmp.result$Rhizome) + HarvestedYield <- round(data.table::last(tmp.result$Stem) * 0.95, 2) } ## run BioGro tmp.result <- BioCro::BioGro(WetDat = WetDat, @@ -144,7 +143,7 @@ run.biocro <- function(lat, lon, metpath, soil.nc = NULL, config = config, coppi photoControl = l2n(config$pft$photoParms)) } - result.yeari.hourly <- with(tmp.result, data.table(year = yeari, + result.yeari.hourly <- with(tmp.result, data.table::data.table(year = yeari, doy = DayofYear, hour = Hour, ThermalT, Stem, Leaf, Root, @@ -191,5 +190,5 @@ run.biocro <- function(lat, lon, metpath, soil.nc = NULL, config = config, coppi by = "year"] return(list(hourly = hourly.results, daily = daily.results, - annually = data.table(lat = lat, lon = lon, annual.results))) + annually = data.table::data.table(lat = lat, lon = lon, annual.results))) } # run.biocro From e7a031bfb04274faf623c449b3a29414a9e43372 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Tue, 5 Sep 2017 23:10:10 -0400 Subject: [PATCH 558/771] need to load methods so lubridate can find them --- models/biocro/inst/biocro.Rscript | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/models/biocro/inst/biocro.Rscript b/models/biocro/inst/biocro.Rscript index f60dc701c06..99a8f98bb94 100755 --- a/models/biocro/inst/biocro.Rscript +++ b/models/biocro/inst/biocro.Rscript @@ -1,5 +1,11 @@ #!/usr/bin/env Rscript +# Need to explicitly load methods package, else lubridate throws obscure errors +# See https://github.com/tidyverse/lubridate/issues/499 +# This load is only necessary when run from Rscript -- +# interactive R loads methods package by default. +library("methods") + args <- commandArgs(trailingOnly = TRUE) rundir <- args[1] outdir <- args[2] From 9c92ca6b15a7de30e2a80e97a495afd29ba71f9f Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Wed, 6 Sep 2017 09:14:23 -0500 Subject: [PATCH 559/771] bug fix: align.met One last little bug from inconsistent variable naming --- modules/data.atmosphere/R/align_met.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.atmosphere/R/align_met.R b/modules/data.atmosphere/R/align_met.R index 1e06ca315d6..a57844d7071 100644 --- a/modules/data.atmosphere/R/align_met.R +++ b/modules/data.atmosphere/R/align_met.R @@ -305,8 +305,8 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. ens.source <- dir(source.path) # If we're matching ensemble members need to use the same ones as from the training data - if(pair.ens==TRUE){ - if(length(ens.source) < ens.train) stop("Cannot pair ensemble members. Reset pair.ens to FALSE or check your file paths") + if(pair.mems==TRUE){ + if(length(ens.source) < ens.train) stop("Cannot pair ensemble members. Reset pair.mems to FALSE or check your file paths") ens.source <- ens.source[train.use] } else { From ff110f8f603a47348d7e8b5f31b090b65b62aff9 Mon Sep 17 00:00:00 2001 From: araiho Date: Wed, 6 Sep 2017 10:32:38 -0400 Subject: [PATCH 560/771] adding flags for overwriting nc files --- models/linkages/R/model2netcdf.LINKAGES.R | 9 +++++---- models/linkages/man/model2netcdf.LINKAGES.Rd | 4 +++- models/sipnet/R/model2netcdf.SIPNET.R | 9 +++++---- models/sipnet/man/model2netcdf.SIPNET.Rd | 4 +++- 4 files changed, 16 insertions(+), 10 deletions(-) diff --git a/models/linkages/R/model2netcdf.LINKAGES.R b/models/linkages/R/model2netcdf.LINKAGES.R index 0b615407fea..d8c31ab8f07 100644 --- a/models/linkages/R/model2netcdf.LINKAGES.R +++ b/models/linkages/R/model2netcdf.LINKAGES.R @@ -18,11 +18,12 @@ ##' @param sitelon Longitude of the site ##' @param start_date Start time of the simulation ##' @param end_date End time of the simulation +##' @param overwrite Flag for overwriting nc files or not ##' @export ##' ##' @author Ann Raiho, Betsy Cowdery ##' @importFrom ncdf4 ncdim_def ncvar_def -model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, end_date = NULL, force = FALSE) { +model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, end_date = NULL, force = FALSE, overwrite = FALSE) { # , PFTs) { logger.severe('NOT IMPLEMENTED') library(PEcAn.utils) @@ -39,9 +40,9 @@ model2netcdf.LINKAGES <- function(outdir, sitelat, sitelon, start_date = NULL, e ### Loop over years in linkages output to create separate netCDF outputs for (y in seq_along(years)) { - # if (file.exists(file.path(outdir, paste(years[y], "nc", sep = ".")))) { - # next - # } + if (file.exists(file.path(outdir, paste(years[y], "nc", sep = "."))) & overwrite==FALSE) { + next + } print(paste("---- Processing year: ", years[y])) # turn on for debugging ## Subset data for processing sub.linkages.output <- subset(linkages.output, year == y) diff --git a/models/linkages/man/model2netcdf.LINKAGES.Rd b/models/linkages/man/model2netcdf.LINKAGES.Rd index 6ddc266b67e..d2be77a34d3 100644 --- a/models/linkages/man/model2netcdf.LINKAGES.Rd +++ b/models/linkages/man/model2netcdf.LINKAGES.Rd @@ -5,7 +5,7 @@ \title{Code to convert LINKAGES's output into netCDF format} \usage{ model2netcdf.LINKAGES(outdir, sitelat, sitelon, start_date = NULL, - end_date = NULL, force = FALSE) + end_date = NULL, force = FALSE, overwrite = FALSE) } \arguments{ \item{outdir}{Location of model output} @@ -17,6 +17,8 @@ model2netcdf.LINKAGES(outdir, sitelat, sitelon, start_date = NULL, \item{start_date}{Start time of the simulation} \item{end_date}{End time of the simulation} + +\item{overwrite}{Flag for overwriting nc files or not} } \description{ Convert MODEL output into the NACP Intercomparison format (ALMA using netCDF) diff --git a/models/sipnet/R/model2netcdf.SIPNET.R b/models/sipnet/R/model2netcdf.SIPNET.R index 304ffd99805..ad23b78dc93 100644 --- a/models/sipnet/R/model2netcdf.SIPNET.R +++ b/models/sipnet/R/model2netcdf.SIPNET.R @@ -19,9 +19,10 @@ ##' @param start_date Start time of the simulation ##' @param end_date End time of the simulation ##' @param revision model revision +##' @param overwrite Flag for overwriting nc files or not ##' @export ##' @author Shawn Serbin, Michael Dietze -model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, delete.raw, revision) { +model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, delete.raw, revision, overwrite = FALSE) { ### Read in model output in SIPNET format sipnet.out.file <- file.path(outdir, "sipnet.out") @@ -38,9 +39,9 @@ model2netcdf.SIPNET <- function(outdir, sitelat, sitelon, start_date, end_date, ### Loop over years in SIPNET output to create separate netCDF outputs for (y in years) { - # if (file.exists(file.path(outdir, paste(y, "nc", sep = ".")))) { - # next - # } + if (file.exists(file.path(outdir, paste(y, "nc", sep = "."))) & overwrite == FALSE) { + next + } print(paste("---- Processing year: ", y)) # turn on for debugging ## Subset data for processing diff --git a/models/sipnet/man/model2netcdf.SIPNET.Rd b/models/sipnet/man/model2netcdf.SIPNET.Rd index 5594f8e6508..c22676ab97c 100644 --- a/models/sipnet/man/model2netcdf.SIPNET.Rd +++ b/models/sipnet/man/model2netcdf.SIPNET.Rd @@ -5,7 +5,7 @@ \title{Function to convert SIPNET model output to standard netCDF format} \usage{ model2netcdf.SIPNET(outdir, sitelat, sitelon, start_date, end_date, delete.raw, - revision) + revision, overwrite = FALSE) } \arguments{ \item{outdir}{Location of SIPNET model output} @@ -19,6 +19,8 @@ model2netcdf.SIPNET(outdir, sitelat, sitelon, start_date, end_date, delete.raw, \item{end_date}{End time of the simulation} \item{revision}{model revision} + +\item{overwrite}{Flag for overwriting nc files or not} } \description{ Convert SIPNET output to netCDF From 0f80625e687bb2c0f414777523a647a116a6049c Mon Sep 17 00:00:00 2001 From: araiho Date: Wed, 6 Sep 2017 10:33:58 -0400 Subject: [PATCH 561/771] clean up --- modules/assim.sequential/R/sda.enkf.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index b8ca1906b35..6742364abc4 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -340,7 +340,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL, adjustmen ###-------------------------------------------------------------------### ### loop over time ### ###-------------------------------------------------------------------### - for(t in seq_len(nt)) {#seq_len(nt) + for(t in seq_len(nt)) { ###-------------------------------------------------------------------### ### read restart ### From 1332e4a5f55c15080bbfc9a5186b7b5d6b1cda2b Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Wed, 6 Sep 2017 14:54:25 -0400 Subject: [PATCH 562/771] Added sidebar and more pages to dashboard --- shiny/Data-Ingest/app.R | 52 +++++++++++++++++++++++------------------ 1 file changed, 29 insertions(+), 23 deletions(-) diff --git a/shiny/Data-Ingest/app.R b/shiny/Data-Ingest/app.R index a776258d81a..590593d8584 100644 --- a/shiny/Data-Ingest/app.R +++ b/shiny/Data-Ingest/app.R @@ -8,7 +8,7 @@ # library(shiny) -library(PEcAn.data.land) +#library(PEcAn.data.land) library(shinyDND) library(shinydashboard) @@ -17,33 +17,39 @@ library(shinydashboard) ui <- dashboardPage( dashboardHeader(title = "Data Ingest"), - dashboardSidebar(), + dashboardSidebar( + sidebarMenu( + menuItem("Import Data", tabName = "importData", icon = icon("file")), + menuItem("Step 2 -- dbfiles record", tabName = "step2", icon = icon("cog")), + menuItem("Step 3 -- format record", tabName = "step3", icon = icon("cog")), + menuItem("Step 4 -- etc.", tabName = "step4", icon = icon("cog")) + ) + ), dashboardBody( - - fluidRow( - box( - textInput("id", label = h3("Import From DataONE"), placeholder = "Enter doi or id here"), - actionButton(inputId = "D1Button", label = "Upload"), - hr(), - fluidRow(column(12, verbatimTextOutput("identifier"))) + tabItems( + tabItem(tabName = "importData", + fluidRow( + box( + textInput("id", label = h3("Import From DataONE"), placeholder = "Enter doi or id here"), + actionButton(inputId = "D1Button", label = "Upload"), + hr(), + fluidRow(column(12, verbatimTextOutput("identifier"))) + ), + + box( + # https://github.com/rstudio/shiny-examples/blob/master/009-upload/app.R + fileInput(inputId = "file", label = h3("Upload Local Files"), accept = NULL, multiple = TRUE), + p("One or more files") + ) + ) ), - box( - # https://github.com/rstudio/shiny-examples/blob/master/009-upload/app.R - fileInput(inputId = "file", label = h3("Upload Local Files"), accept = NULL, multiple = TRUE), - p("One or more files") - ) - ), - - dashboardSidebar( - sidebarMenu( - menuItem("Import Data", tabName = "importData", icon = icon("file")), - menuItem("Step 2 -- dbfiles record", tabName = "step2", icon = icon("cog")), - menuItem("Step 3 -- format record", tabName = "step3", icon = icon("cog")), - menuItem("Step 4 -- etc.", tabName = "step4", icon = icon("cog")) + tabItem(tabName = "step2", + h2("dbfiles tab content") ) + + ) - ) ) From 36f53578b788a8943aaabad9d9bdf9a5b8bf5c9d Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Wed, 6 Sep 2017 17:14:07 -0400 Subject: [PATCH 563/771] add to info page of inputs --- book_source/workflow/inputs_conversions.Rmd | 25 +++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/book_source/workflow/inputs_conversions.Rmd b/book_source/workflow/inputs_conversions.Rmd index e69de29bb2d..c61ffc9a226 100644 --- a/book_source/workflow/inputs_conversions.Rmd +++ b/book_source/workflow/inputs_conversions.Rmd @@ -0,0 +1,25 @@ +# Input Data + +Models require input data as drivers, parameters, and boundary conditions. In order to make a variety of data sources that have unique formats compatible with models, conversion scripts are written to convert them into a PEcAn standard format. That format is a netcdf file with variables names and specified to our standard variable table. + +Within the PEcAn repository, code pertaining to input conversion is in the MODULES directory under the data.atmosphere and data.land directories. + +## Meteorological Data +To convert meterological data into the PEcAn Standard and then into model formats we follow four main steps: + + - Downloading raw data + - Currently supported products + - Example Code + - Converting raw data into a CF standard + - Example Code + - Downscaling and gapfilling + - Example Code + - Coverting to Model Specific format + - Example Code + +How do I add my Meterological data product to PEcAn? +How do I use PEcAn to convert Met data outide the workflow? + +## Initial Conditions + + - COMING SOON \ No newline at end of file From d42c8b7ea444f5537243da8f64e348779a564ead Mon Sep 17 00:00:00 2001 From: Chris Black Date: Wed, 6 Sep 2017 19:56:33 -0400 Subject: [PATCH 564/771] use PEcAn.utils::to_ncvar instead of mstmipvar --- models/biocro/R/model2netcdf.BIOCRO.R | 19 ++++++++++--------- .../tests/testthat/test.model2netcdf.BIOCRO.R | 10 ++++++---- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/models/biocro/R/model2netcdf.BIOCRO.R b/models/biocro/R/model2netcdf.BIOCRO.R index 9f06645f1f6..54f0fc90ddd 100644 --- a/models/biocro/R/model2netcdf.BIOCRO.R +++ b/models/biocro/R/model2netcdf.BIOCRO.R @@ -59,21 +59,22 @@ model2netcdf.BIOCRO <- function(result, genus = NULL, outdir, lat = -9999, lon = } } - vars <- list(NPP = PEcAn.utils::mstmipvar("NPP", x, y, t), - TotLivBiom = PEcAn.utils::mstmipvar("TotLivBiom", x, y, t), - RootBiom = PEcAn.utils::mstmipvar("RootBiom", x, y, t), - StemBiom = PEcAn.utils::mstmipvar("StemBiom", x, y, t), - Evap = PEcAn.utils::mstmipvar("Evap", x, y, t), - TVeg = PEcAn.utils::mstmipvar("TVeg", x, y, t), - LAI = PEcAn.utils::mstmipvar("LAI", x, y, t)) + dims <- list(lat = x, lon = y, time = t) + vars <- list(NPP = PEcAn.utils::to_ncvar("NPP", dims), + TotLivBiom = PEcAn.utils::to_ncvar("TotLivBiom", dims), + root_carbon_content = PEcAn.utils::to_ncvar("root_carbon_content", dims), + AbvGrndWood = PEcAn.utils::to_ncvar("AbvGrndWood", dims), + Evap = PEcAn.utils::to_ncvar("Evap", dims), + TVeg = PEcAn.utils::to_ncvar("TVeg", dims), + LAI = PEcAn.utils::to_ncvar("LAI", dims)) biomass2c <- 0.4 k <- udunits2::ud.convert(1, "Mg/ha", "kg/m2") * biomass2c result_yeari_std <- with(result_yeari, list( TotLivBiom = k * (Leaf + Root + Stem + Rhizome + Grain), - RootBiom = k * Root, - StemBiom = k * Stem, + root_carbon_content = k * Root, + AbvGrndWood = k * Stem, Evap = udunits2::ud.convert(SoilEvaporation + CanopyTrans, "Mg/ha/h", "kg/m2/s"), TVeg = udunits2::ud.convert(CanopyTrans, "Mg/ha/h", "kg/m2/s"), LAI = LAI)) diff --git a/models/biocro/tests/testthat/test.model2netcdf.BIOCRO.R b/models/biocro/tests/testthat/test.model2netcdf.BIOCRO.R index 55aa3479c37..ee12303f8b3 100644 --- a/models/biocro/tests/testthat/test.model2netcdf.BIOCRO.R +++ b/models/biocro/tests/testthat/test.model2netcdf.BIOCRO.R @@ -28,7 +28,7 @@ dims <- biocro.nc$dim test_that("model2netcdf.BIOCRO wrote netCDF with correct variables", { - expect_true(all(c("TotLivBiom", "RootBiom", "StemBiom", "Evap", "TVeg", "LAI") %in% + expect_true(all(c("TotLivBiom", "root_carbon_content", "AbvGrndWood", "Evap", "TVeg", "LAI") %in% names(vars))) expect_true(all(c("latitude", "longitude", "time") %in% names(dims))) @@ -47,11 +47,13 @@ test_that("dimensions have MsTMIP standard units", { test_that("variables have MsTMIP standard units", { - data(mstmip_vars, package = "PEcAn.utils") + standard_vars <- read.csv( + file = system.file("data/standard_vars.csv", package = "PEcAn.utils"), + stringsAsFactors = FALSE) for (var in vars) { - if (var$name %in% mstmip_vars$Variable.Name) { - expect_true(var$units == mstmip_vars[mstmip_vars$Variable.Name == var$name, + if (var$name %in% standard_vars$Variable.Name) { + expect_true(var$units == standard_vars[standard_vars$Variable.Name == var$name, "Units"]) } } From 29896c3a0b5f30212a5006490b0e1799274fd614 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Wed, 6 Sep 2017 20:14:24 -0400 Subject: [PATCH 565/771] prevent one more global variable warning --- models/biocro/R/met2model.BIOCRO.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/models/biocro/R/met2model.BIOCRO.R b/models/biocro/R/met2model.BIOCRO.R index e02c18b22bb..52c89b8c791 100644 --- a/models/biocro/R/met2model.BIOCRO.R +++ b/models/biocro/R/met2model.BIOCRO.R @@ -183,6 +183,7 @@ cf2biocro <- function(met, longitude = NULL, zulu2solarnoon = FALSE) { Temp = udunits2::ud.convert(met$air_temperature, "Kelvin", "Celsius"), RH = met$relative_humidity, WS = wind_speed, - precip = udunits2::ud.convert(met$precipitation_flux, "s-1", "h-1"))][hour <= 23] + precip = udunits2::ud.convert(met$precipitation_flux, "s-1", "h-1"))] + newmet <- newmet[newmet$hour <= 23,] return(as.data.frame(newmet)) } # cf2biocro From 4360a0b98beedf8d57ca03be3217ce418cf7d816 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Wed, 6 Sep 2017 20:37:22 -0400 Subject: [PATCH 566/771] remove duplicated mcmc.list2init --- utils/R/mcmc.list2init.R | 78 ------------------------------------- utils/man/mcmc.list2init.Rd | 20 ---------- 2 files changed, 98 deletions(-) delete mode 100644 utils/R/mcmc.list2init.R delete mode 100644 utils/man/mcmc.list2init.Rd diff --git a/utils/R/mcmc.list2init.R b/utils/R/mcmc.list2init.R deleted file mode 100644 index 965c52215fb..00000000000 --- a/utils/R/mcmc.list2init.R +++ /dev/null @@ -1,78 +0,0 @@ -#' Convert mcmc.list to initial condition list -#' -#' Used for restarting MCMC code based on last parameters sampled (e.g. in JAGS) -#' -#' @author Mike Dietze -#' -#' @param dat mcmc.list object -#' -#' @return list -#' @export -#' -#' @examples -mcmc.list2init <- function(dat) { - - ## get unique variable names - allname <- strsplit(colnames(dat[[1]]),"[",fixed = TRUE) - firstname <- sapply(allname,function(x){x[1]}) - dims <- lapply(allname,function(x){ - y <- sub(pattern = "]",replacement = "",x[2]) - y <- as.numeric(strsplit(y,",",fixed=TRUE)[[1]]) - return(y) - }) - ind <- t(sapply(dims,function(x){ - if(length(x)==2){ - return(x) - } else { return(c(NA,NA))} - })) - - uname <- unique(firstname) - - ## define variables - ic <- list() - n <- nrow(dat[[1]]) - nc <- nchain(dat) - for(c in seq_len(nc)) ic[[c]] <- list() - - for(v in seq_along(uname)){ - - ## detect variable type (scalar, vector, matrix) - cols <- which(firstname == uname[v]) - - if(length(cols) == 1){ - ## SCALAR - for(c in seq_len(nc)){ - ic[[c]][[v]] <- dat[[c]][nr,cols] - names(ic[[c]])[v] <- uname[v] - } - - } else { - - dim <- length(dims[[cols[1]]]) - - if(dim == 1){ - ## VECTOR - for(c in seq_len(nc)){ - ic[[c]][[v]] <- dat[[c]][nr,cols] - names(ic[[c]])[v] <- uname[v] - } - - } else if (dim == 2){ - ## MATRIX - for(c in seq_len(nc)){ - ic[[c]][[v]] <- matrix(seq_along(cols),max(ind[cols,1]),max(ind[cols,2])) ## set up matrix for storage - ic[[c]][[v]][ind[cols]] <- dat[[c]][nr,cols] - names(ic[[c]])[v] <- uname[v] - } - - } else { - PEcAn.utils::logger.severe("dimension not supported",dim,uname[v]) - } - - } ## end else VECTOR or MATRIX - - } ## end loop over v - - return(ic) - -} ## end mcmc.list2init \ No newline at end of file diff --git a/utils/man/mcmc.list2init.Rd b/utils/man/mcmc.list2init.Rd deleted file mode 100644 index c91a11718f8..00000000000 --- a/utils/man/mcmc.list2init.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mcmc.list2init.R -\name{mcmc.list2init} -\alias{mcmc.list2init} -\title{Convert mcmc.list to initial condition list} -\usage{ -mcmc.list2init(dat) -} -\arguments{ -\item{dat}{mcmc.list object} -} -\value{ -list -} -\description{ -Used for restarting MCMC code based on last parameters sampled (e.g. in JAGS) -} -\author{ -Mike Dietze -} From de2f0ffb9018cb648169e85fecb1443ab8c58e10 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Wed, 6 Sep 2017 21:36:33 -0400 Subject: [PATCH 567/771] update changelog --- CHANGELOG.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index abf2d76d51d..81465a63ec1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,9 @@ For more information about this file see also [Keep a Changelog](http://keepacha ## [Unreleased] ### Fixes +- `PEcAn.BIOCRO` now uses PEcAn-standard variable names. As a result, two output variables have been renamed but keep their exiting units and definitions: + - `StemBiom` renamed to `AbvGrndWood` + - `RootBiom` renamed to `root_carbon_content` - Improved make install logic (#1558) - Fixed remote code execution #1545 - Added check for NA end/start year in read.output From a532cb9f32e7376ecba8f4a7bddf72bf26876a35 Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 7 Sep 2017 09:49:21 -0400 Subject: [PATCH 568/771] tests with cloned pfts --- models/ed/data/pftmapping.csv | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/models/ed/data/pftmapping.csv b/models/ed/data/pftmapping.csv index ddaebb2602e..88f62552414 100644 --- a/models/ed/data/pftmapping.csv +++ b/models/ed/data/pftmapping.csv @@ -62,3 +62,8 @@ temperate.Western_Hardwood;10 broadleaf_evergreen_tropical_tree;3 tundra.deciduous.NGEE_Arctic;11 tundra.grass.NGEE_Arctic;5 +temperate.Early_Hardwood.IF;9 +temperate.Late_Conifer.IF;8 +temperate.Late_Hardwood.IF;11 +temperate.Northern_Pine.IF;6 +temperate.North_Mid_Hardwood.IF;10 \ No newline at end of file From a18105845747bd79e2ddfacbca31d3542920d4e0 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 7 Sep 2017 10:29:43 -0400 Subject: [PATCH 569/771] ED: Add EBI C4 grass to `pftmappings` --- models/ed/data/pftmapping.csv | 1 + 1 file changed, 1 insertion(+) diff --git a/models/ed/data/pftmapping.csv b/models/ed/data/pftmapping.csv index ddaebb2602e..ae1f987add8 100644 --- a/models/ed/data/pftmapping.csv +++ b/models/ed/data/pftmapping.csv @@ -4,6 +4,7 @@ ebifarm.acsa3;11 ebifarm.c3grass;12 ebifarm.c4crop;15 ebifarm.c4grass;14 +ebifarm.c4grass.doe_vd;14 ebifarm.castanea;11 ebifarm.forb;12 ebifarm.liqui;9 From f856cc3cabf6ae819721477e12014626ad12b5e9 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Thu, 7 Sep 2017 10:55:18 -0400 Subject: [PATCH 570/771] change listing --- book_source/workflow/inputs_conversions.Rmd | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/book_source/workflow/inputs_conversions.Rmd b/book_source/workflow/inputs_conversions.Rmd index c61ffc9a226..f6121d0aea8 100644 --- a/book_source/workflow/inputs_conversions.Rmd +++ b/book_source/workflow/inputs_conversions.Rmd @@ -7,16 +7,18 @@ Within the PEcAn repository, code pertaining to input conversion is in the MODUL ## Meteorological Data To convert meterological data into the PEcAn Standard and then into model formats we follow four main steps: - - Downloading raw data + 1. Downloading raw data - Currently supported products - Example Code - - Converting raw data into a CF standard + 2. Converting raw data into a CF standard - Example Code - - Downscaling and gapfilling + 3. Downscaling and gapfilling - Example Code - - Coverting to Model Specific format + 4. Coverting to Model Specific format - Example Code +Common Questions regarding Met Data: + How do I add my Meterological data product to PEcAn? How do I use PEcAn to convert Met data outide the workflow? From 26d03a1f2db88646919939a5e8fb443f1d1ca1ad Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 7 Sep 2017 11:03:41 -0400 Subject: [PATCH 571/771] fixes to convert.samples for model compatibility --- models/ed/R/write.configs.ed.R | 9 +++++++++ models/ed/data/pftmapping.csv | 2 +- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/models/ed/R/write.configs.ed.R b/models/ed/R/write.configs.ed.R index 1f28e4fd843..ec69a018d3b 100644 --- a/models/ed/R/write.configs.ed.R +++ b/models/ed/R/write.configs.ed.R @@ -43,6 +43,11 @@ convert.samples.ED <- function(trait.samples) { trait.samples[["SLA"]] <- sla/DEFAULT.LEAF.C } + # for model version compatibility (q and fineroot2leaf are the same) + if ("fineroot2leaf" %in% names(trait.samples)) { + trait.samples[["q"]] <- as.numeric(trait.samples[["fineroot2leaf"]]) + } + ## convert leaf width / 1000 if ("leaf_width" %in% names(trait.samples)) { lw <- as.numeric(trait.samples[["leaf_width"]]) @@ -53,11 +58,15 @@ convert.samples.ED <- function(trait.samples) { rrr1 <- as.numeric(trait.samples[["root_respiration_rate"]]) rrr2 <- rrr1 * DEFAULT.MAINTENANCE.RESPIRATION trait.samples[["root_respiration_rate"]] <- arrhenius.scaling(rrr2, old.temp = 25, new.temp = 15) + # model version compatibility (rrr and rrf are the same) + trait.samples[["root_respiration_factor"]] <- trait.samples[["root_respiration_rate"]] } if ("Vcmax" %in% names(trait.samples)) { vcmax <- as.numeric(trait.samples[["Vcmax"]]) trait.samples[["Vcmax"]] <- arrhenius.scaling(vcmax, old.temp = 25, new.temp = 15) + # write as Vm0 for version compatibility (Vm0 = Vcmax @ 15C) + trait.samples[["Vm0"]] <- arrhenius.scaling(vcmax, old.temp = 25, new.temp = 15) ## Convert leaf_respiration_rate_m2 to dark_resp_factor; requires Vcmax if ("leaf_respiration_rate_m2" %in% names(trait.samples)) { diff --git a/models/ed/data/pftmapping.csv b/models/ed/data/pftmapping.csv index 88f62552414..40ffffcda44 100644 --- a/models/ed/data/pftmapping.csv +++ b/models/ed/data/pftmapping.csv @@ -66,4 +66,4 @@ temperate.Early_Hardwood.IF;9 temperate.Late_Conifer.IF;8 temperate.Late_Hardwood.IF;11 temperate.Northern_Pine.IF;6 -temperate.North_Mid_Hardwood.IF;10 \ No newline at end of file +temperate.North_Mid_Hardwood.IF;10 From d7af36c72f35bfc5209c573c162e6e28baaa5d03 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 7 Sep 2017 10:13:57 -0500 Subject: [PATCH 572/771] Reverted to EBI Farm ED test, with revisions --- tests/pecan64.ed.xml | 100 +++++++++++++++---------------------------- 1 file changed, 35 insertions(+), 65 deletions(-) diff --git a/tests/pecan64.ed.xml b/tests/pecan64.ed.xml index 36e88af37e4..911d4b13676 100644 --- a/tests/pecan64.ed.xml +++ b/tests/pecan64.ed.xml @@ -1,10 +1,10 @@ - pecan_ed_test + pecan - PostgreSQL + PostgreSQL bety bety localhost @@ -15,38 +15,35 @@ - temperate.Late_Conifer - - 1 - - - - temperate.Northern_Pine - - 2 - - - - temperate.Southern_Pine - - 3 - + ebifarm.c4grass.doe_vd 3000 FALSE + 1.2 + AUTO - 1 NPP + + - 5000000001 - ED2IN.rgit + /usr/local/bin/ed2.git + ED2 + git 0.01 @@ -60,52 +57,25 @@ - 772 - 1998-01-01 06:00:00 - 2008-01-01 05:00:00 - Niwot Ridge Forest/LTER NWT1 (US-NR1) - 40.0329 - -105.546 + 76 + 2004-01-01 00:00:00 + 2009-12-31 23:59:59 - - 186 - /home/carya/sites/niwot/NR1.NACP.lat40.5lon-105.5.css - - - 187 - /home/carya/sites/niwot/NR1.NACP.lat40.5lon-105.5.pss - - - 188 - /home/carya/sites/niwot/NR1.NACP.lat40.5lon-105.5.site - - - 112 - /home/carya/sites/niwot/ED_MET_DRIVER_HEADER - - - 294 - /home/carya/ed_inputs/glu/ - - - 297 - /home/carya/faoOLD/FAO_ - - - 295 - /home/carya/ed_inputs/ - - - 296 - /home/carya/oge2OLD/OGE2_ - + /home/carya/sites/ebifarm/ED_MET_DRIVER_HEADER + /home/carya/oge2OLD/OGE2_ + /home/carya/faoOLD/FAO_ + /home/carya/sites/ebifarm/ebifarm.lat40.0lon-88.0.pss + /home/carya/sites/ebifarm/ebifarm.lat40.0lon-88.0.css + /home/carya/sites/ebifarm/ebifarm.lat40.0lon-88.0.site + /home/carya/ed_inputs/glu + /home/carya/ed_inputs - 2004/01/01 - 2004/12/31 + 2006/01/01 + 2006/12/31 + + localhost + + pecan/dbfiles - - localhost - - pecan/dbfiles From 4dca1ab8ba0f9186b173f48dfad4bfee29948abf Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 7 Sep 2017 11:41:04 -0400 Subject: [PATCH 573/771] add DBI call --- base/db/R/utils.R | 2 +- models/ed/R/write.configs.ed.R | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/base/db/R/utils.R b/base/db/R/utils.R index ab42176da11..d4b59835a01 100644 --- a/base/db/R/utils.R +++ b/base/db/R/utils.R @@ -81,7 +81,7 @@ db.open <- function(params) { args[['driver']] <- NULL } - c <- do.call(dbConnect, as.list(args)) + c <- do.call(DBI::dbConnect, as.list(args)) id <- sample(1000, size=1) while(length(which(.db.utils$connections$id==id)) != 0) { id <- sample(1000, size=1) diff --git a/models/ed/R/write.configs.ed.R b/models/ed/R/write.configs.ed.R index ec69a018d3b..de61f6bd74c 100644 --- a/models/ed/R/write.configs.ed.R +++ b/models/ed/R/write.configs.ed.R @@ -32,8 +32,7 @@ convert.samples.ED <- function(trait.samples) { DEFAULT.MAINTENANCE.RESPIRATION <- 1 / 2 ## convert SLA from m2 / kg leaf to m2 / kg C - # IF: I don't know why we're removing leaf_respiration_rate from trait samples below - # but if the trait samples doesn't have leaf_respiration_rate + # IF: if the trait samples doesn't have leaf_respiration_rate # it's not being set to NULL and trait samples is not coherced to a list # trait.samples not being a list throws an error later in the write.config.xml.ED2, L:407 trait.samples <- as.list(trait.samples) @@ -81,7 +80,9 @@ convert.samples.ED <- function(trait.samples) { trait.samples[["leaf_respiration_rate_m2"]] / trait.samples[["Vcmax"]] ## Remove leaf_respiration_rate from trait samples - trait.samples$leaf_respiration_rate_m2 <- NULL # !!!WHY DO WE DO THIS??!!! + trait.samples$leaf_respiration_rate_m2 <- NULL # !!!WHY DO WE DO THIS??!!! + # IF : ED doesn't read leaf_respiration_rate_m2, but uses "dark_respiration_factor" + # leaf_respiration_rate_m2 could be left in the trait samples though } ## End dark_respiration_factor loop } ## End Vcmax From 1d995c94520e589b63773cf092823df946f071f2 Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 7 Sep 2017 14:12:04 -0400 Subject: [PATCH 574/771] add DI call to dbDisconnect as well --- base/db/R/utils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/db/R/utils.R b/base/db/R/utils.R index d4b59835a01..be719136bd0 100644 --- a/base/db/R/utils.R +++ b/base/db/R/utils.R @@ -127,7 +127,7 @@ db.close <- function(con, showWarnings=TRUE) { .db.utils$connections$log <- .db.utils$connections$log[-deleteme] } } - dbDisconnect(con) + DBI::dbDisconnect(con) } ##' Debug method for db.open and db.close From 3b9a068b7e8d3d9326011262828182728e48f923 Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 7 Sep 2017 14:38:37 -0400 Subject: [PATCH 575/771] correct the line reference after changes --- models/ed/R/write.configs.ed.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/ed/R/write.configs.ed.R b/models/ed/R/write.configs.ed.R index de61f6bd74c..13b47cd0e51 100644 --- a/models/ed/R/write.configs.ed.R +++ b/models/ed/R/write.configs.ed.R @@ -34,7 +34,7 @@ convert.samples.ED <- function(trait.samples) { # IF: if the trait samples doesn't have leaf_respiration_rate # it's not being set to NULL and trait samples is not coherced to a list - # trait.samples not being a list throws an error later in the write.config.xml.ED2, L:407 + # trait.samples not being a list throws an error later in the write.config.xml.ED2, L:402 trait.samples <- as.list(trait.samples) if ("SLA" %in% names(trait.samples)) { From 28f351207f89b9d90fd7285b6074fda728fb362c Mon Sep 17 00:00:00 2001 From: araiho Date: Thu, 7 Sep 2017 14:48:55 -0400 Subject: [PATCH 576/771] trying to fix flag issue with PR --- modules/assim.sequential/R/sda.enkf.R | 1 - 1 file changed, 1 deletion(-) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index 6742364abc4..942c9aaddb4 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -735,7 +735,6 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL, adjustmen } enkf.params[[t]] <- list(mu.f = mu.f, Pf = Pf, mu.a = mu.a, Pa = Pa) } - ###-------------------------------------------------------------------### ### update state matrix ### ###-------------------------------------------------------------------### From 1e19c7d082929ef724a48caa304ad140f9f0be3e Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Fri, 8 Sep 2017 10:43:46 -0500 Subject: [PATCH 577/771] Drag and drop instructions added to fileInput box --- shiny/Data-Ingest/app.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/shiny/Data-Ingest/app.R b/shiny/Data-Ingest/app.R index 590593d8584..706c03d81f6 100644 --- a/shiny/Data-Ingest/app.R +++ b/shiny/Data-Ingest/app.R @@ -38,8 +38,7 @@ ui <- dashboardPage( box( # https://github.com/rstudio/shiny-examples/blob/master/009-upload/app.R - fileInput(inputId = "file", label = h3("Upload Local Files"), accept = NULL, multiple = TRUE), - p("One or more files") + fileInput(inputId = "file", label = h3("Upload Local Files"), accept = NULL, multiple = TRUE, placeholder = "Drag and drop files here") ) ) ), From a05abedd5c015554b3dcef54a373ce291fd652e1 Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 8 Sep 2017 13:57:41 -0400 Subject: [PATCH 578/771] reassign Vcmax to Vm0 --- models/ed/R/write.configs.ed.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/ed/R/write.configs.ed.R b/models/ed/R/write.configs.ed.R index 13b47cd0e51..767105e3348 100644 --- a/models/ed/R/write.configs.ed.R +++ b/models/ed/R/write.configs.ed.R @@ -65,7 +65,7 @@ convert.samples.ED <- function(trait.samples) { vcmax <- as.numeric(trait.samples[["Vcmax"]]) trait.samples[["Vcmax"]] <- arrhenius.scaling(vcmax, old.temp = 25, new.temp = 15) # write as Vm0 for version compatibility (Vm0 = Vcmax @ 15C) - trait.samples[["Vm0"]] <- arrhenius.scaling(vcmax, old.temp = 25, new.temp = 15) + trait.samples[["Vm0"]] <- trait.samples[["Vcmax"]] ## Convert leaf_respiration_rate_m2 to dark_resp_factor; requires Vcmax if ("leaf_respiration_rate_m2" %in% names(trait.samples)) { From ba403195e68d871419a0e9dd99d59449f9e75131 Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 8 Sep 2017 13:58:29 -0400 Subject: [PATCH 579/771] dont remove leaf_respiration_rate from trait samples --- models/ed/R/write.configs.ed.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/models/ed/R/write.configs.ed.R b/models/ed/R/write.configs.ed.R index 767105e3348..9903dd2944b 100644 --- a/models/ed/R/write.configs.ed.R +++ b/models/ed/R/write.configs.ed.R @@ -79,10 +79,6 @@ convert.samples.ED <- function(trait.samples) { trait.samples[["dark_respiration_factor"]] <- trait.samples[["leaf_respiration_rate_m2"]] / trait.samples[["Vcmax"]] - ## Remove leaf_respiration_rate from trait samples - trait.samples$leaf_respiration_rate_m2 <- NULL # !!!WHY DO WE DO THIS??!!! - # IF : ED doesn't read leaf_respiration_rate_m2, but uses "dark_respiration_factor" - # leaf_respiration_rate_m2 could be left in the trait samples though } ## End dark_respiration_factor loop } ## End Vcmax From 424d402e53e3fcf7fbd7bfe55e92d399e740af17 Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 8 Sep 2017 14:01:48 -0400 Subject: [PATCH 580/771] revise note --- models/ed/R/write.configs.ed.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/models/ed/R/write.configs.ed.R b/models/ed/R/write.configs.ed.R index 9903dd2944b..5d6536af248 100644 --- a/models/ed/R/write.configs.ed.R +++ b/models/ed/R/write.configs.ed.R @@ -32,9 +32,7 @@ convert.samples.ED <- function(trait.samples) { DEFAULT.MAINTENANCE.RESPIRATION <- 1 / 2 ## convert SLA from m2 / kg leaf to m2 / kg C - # IF: if the trait samples doesn't have leaf_respiration_rate - # it's not being set to NULL and trait samples is not coherced to a list - # trait.samples not being a list throws an error later in the write.config.xml.ED2, L:402 + # IF: trait.samples not being a list throws an error later in the write.config.xml.ED2 trait.samples <- as.list(trait.samples) if ("SLA" %in% names(trait.samples)) { From b6cb8dc65315b7899bca52ac5fadba989eb12ac7 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 9 Sep 2017 00:23:52 -0400 Subject: [PATCH 581/771] include PEcAn.qaqc in Makefile Yes, the space in the vignette filename really was breaking the make process! --- Makefile | 3 ++- base/qaqc/vignettes/{compare ED2.Rmd => compare_ED2.Rmd} | 0 2 files changed, 2 insertions(+), 1 deletion(-) rename base/qaqc/vignettes/{compare ED2.Rmd => compare_ED2.Rmd} (100%) diff --git a/Makefile b/Makefile index ab51343c0e5..63ac0298a1a 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ NCPUS ?= 1 -BASE := logger utils db settings visualization +BASE := logger utils db settings visualization qaqc MODELS := biocro clm45 dalec ed fates gday jules linkages \ lpjguess maat maespa preles sipnet @@ -55,6 +55,7 @@ depends = .doc/$(1) .install/$(1) .check/$(1) .test/$(1) $(call depends,base/db): .install/base/logger .install/base/utils $(call depends,base/settings): .install/base/logger .install/base/utils .install/base/db $(call depends,base/visualization): .install/base/logger .install/base/db +$(call depends,base/qaqc): .install/base/logger $(call depends,modules/data.atmosphere): .install/base/logger .install/base/utils $(call depends,modules/data.land): .install/base/logger .install/base/db .install/base/utils $(call depends,modules/meta.analysis): .install/base/logger .install/base/utils .install/base/db diff --git a/base/qaqc/vignettes/compare ED2.Rmd b/base/qaqc/vignettes/compare_ED2.Rmd similarity index 100% rename from base/qaqc/vignettes/compare ED2.Rmd rename to base/qaqc/vignettes/compare_ED2.Rmd From f5728bbcdd14863f6fbfad035eee7893e352bac4 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 9 Sep 2017 00:25:32 -0400 Subject: [PATCH 582/771] rozygenize --- base/qaqc/DESCRIPTION | 1 + base/qaqc/NAMESPACE | 2 ++ base/qaqc/man/new.taylor.Rd | 14 +++++--------- 3 files changed, 8 insertions(+), 9 deletions(-) diff --git a/base/qaqc/DESCRIPTION b/base/qaqc/DESCRIPTION index c2d23d56b95..cd6f6393270 100644 --- a/base/qaqc/DESCRIPTION +++ b/base/qaqc/DESCRIPTION @@ -16,3 +16,4 @@ LazyLoad: yes LazyData: FALSE Collate: 'taylor.plot.R' +RoxygenNote: 6.0.1 diff --git a/base/qaqc/NAMESPACE b/base/qaqc/NAMESPACE index e69de29bb2d..6ae926839dd 100644 --- a/base/qaqc/NAMESPACE +++ b/base/qaqc/NAMESPACE @@ -0,0 +1,2 @@ +# Generated by roxygen2: do not edit by hand + diff --git a/base/qaqc/man/new.taylor.Rd b/base/qaqc/man/new.taylor.Rd index 52fdd09b52f..242b376a2b5 100644 --- a/base/qaqc/man/new.taylor.Rd +++ b/base/qaqc/man/new.taylor.Rd @@ -1,18 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/taylor.plot.R \name{new.taylor} \alias{new.taylor} \title{Taylor Diagram} \usage{ - new.taylor(dataset, runid, siteid) +new.taylor(dataset, runid, siteid) } \arguments{ - \item{dataset}{} - - \item{runid}{a numeric vector with the id(s) of one or - more runs (folder in runs) to plot} - - \item{siteid}{} +\item{runid}{a numeric vector with the id(s) of one or more runs (folder in runs) to plot} } \description{ - plot taylor diagram for benchmark sites +Plot taylor diagram for benchmark sites } - From 9c7ed671864b15e72c11f314ace058e863d50d83 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 9 Sep 2017 13:48:01 -0400 Subject: [PATCH 583/771] do not install model template package --- Makefile | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/Makefile b/Makefile index ab51343c0e5..90069223c11 100644 --- a/Makefile +++ b/Makefile @@ -13,27 +13,27 @@ MODULES := allometry assim.batch assim.sequential benchmark \ BASE := $(BASE:%=base/%) MODELS := $(MODELS:%=models/%) MODULES := $(MODULES:%=modules/%) -ALL_PKGS := $(BASE) $(MODULES) $(MODELS) models/template +ALL_PKGS := $(BASE) $(MODULES) $(MODELS) BASE_I := $(BASE:%=.install/%) MODELS_I := $(MODELS:%=.install/%) MODULES_I := $(MODULES:%=.install/%) -ALL_PKGS_I := $(BASE_I) $(MODULES_I) $(MODELS_I) .install/models/template +ALL_PKGS_I := $(BASE_I) $(MODULES_I) $(MODELS_I) BASE_C := $(BASE:%=.check/%) MODELS_C := $(MODELS:%=.check/%) MODULES_C := $(MODULES:%=.check/%) -ALL_PKGS_C := $(BASE_C) $(MODULES_C) $(MODELS_C) .check/models/template +ALL_PKGS_C := $(BASE_C) $(MODULES_C) $(MODELS_C) BASE_T := $(BASE:%=.test/%) MODELS_T := $(MODELS:%=.test/%) MODULES_T := $(MODULES:%=.test/%) -ALL_PKGS_T := $(BASE_T) $(MODULES_T) $(MODELS_T) .test/models/template +ALL_PKGS_T := $(BASE_T) $(MODULES_T) $(MODELS_T) BASE_D := $(BASE:%=.doc/%) MODELS_D := $(MODELS:%=.doc/%) MODULES_D := $(MODULES:%=.doc/%) -ALL_PKGS_D := $(BASE_D) $(MODULES_D) $(MODELS_D) .doc/models/template +ALL_PKGS_D := $(BASE_D) $(MODULES_D) $(MODELS_D) .PHONY: all install check test document @@ -65,9 +65,6 @@ $(call depends,modules/uncertainty): .install/base/logger .install/base/utils .i $(call depends,models/template): .install/base/logger .install/base/utils $(call depends,models/biocro): .install/base/logger .install/base/utils .install/base/settings .install/base/db .install/modules/data.atmosphere .install/modules/data.land -$(MODELS_I): .install/models/template - - clean: rm -rf .install .check .test .doc find modules/rtm/src \( -name \*.mod -o -name \*.o -o -name \*.so \) -delete From 00e961f70b06c7b9dee3b50864eb1263f639001b Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 7 Sep 2017 09:57:52 -0400 Subject: [PATCH 584/771] use trusty --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 8a922782349..495fa07b695 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,7 +4,7 @@ language: r # use containers -dist: precise +dist: trusty sudo: false cache: From e86f628f412dfddaae9f19caef29169935262f18 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 7 Sep 2017 11:11:30 -0400 Subject: [PATCH 585/771] bump postgres version --- .travis.yml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index 495fa07b695..353b103964f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -17,7 +17,7 @@ cache: - packages addons: - postgresql: 9.4 + postgresql: 9.6 apt: packages: - libnetcdf-dev @@ -26,8 +26,8 @@ addons: - jags - libudunits2-dev - python-dev - - postgresql-9.4-postgis-2.1 - - postgresql-9.4-postgis-2.1-scripts + - postgresql-9.6-postgis-2.3 + - postgresql-9.6-postgis-2.3-scripts - netcdf-bin - bc - curl From 6167f7c6731d9b5eff4601615e1073af6d96c006 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 9 Sep 2017 15:42:23 -0400 Subject: [PATCH 586/771] cache: packages does this already --- .travis.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 353b103964f..e904b4f1e1a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,7 +9,6 @@ sudo: false cache: - directories: - - $HOME/R/Library - .install - .check - .test From 98dc49f20e85387615f26a868b1ea7ae42c667b2 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 9 Sep 2017 16:36:16 -0400 Subject: [PATCH 587/771] install only devtools to prime CI cache --- .travis.yml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index e904b4f1e1a..3b320221415 100644 --- a/.travis.yml +++ b/.travis.yml @@ -85,12 +85,12 @@ script: - set -e # - scripts/build.sh --no-git --tests --name travis - echo 'Installing PEcAn packages' - - make - - echo 'Testing PEcAn packages' - - make test - - make document - - echo 'Testing Integration' - - ./tests/integration.sh travis + - make .install/devtools + # - echo 'Testing PEcAn packages' + # - make test + # - make document + # - echo 'Testing Integration' + # - ./tests/integration.sh travis - if [[ `git status -s` ]]; then echo "These files were changed by the build process:"; git status -s; From 385d5f5c4347cb3926a5deb5315f4e5004706879 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 9 Sep 2017 16:51:24 -0400 Subject: [PATCH 588/771] Revert "install only devtools to prime CI cache" This reverts commit 98dc49f20e85387615f26a868b1ea7ae42c667b2. --- .travis.yml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index 3b320221415..e904b4f1e1a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -85,12 +85,12 @@ script: - set -e # - scripts/build.sh --no-git --tests --name travis - echo 'Installing PEcAn packages' - - make .install/devtools - # - echo 'Testing PEcAn packages' - # - make test - # - make document - # - echo 'Testing Integration' - # - ./tests/integration.sh travis + - make + - echo 'Testing PEcAn packages' + - make test + - make document + - echo 'Testing Integration' + - ./tests/integration.sh travis - if [[ `git status -s` ]]; then echo "These files were changed by the build process:"; git status -s; From 69402749b16a7db1705311ca43e8ed1ec8e6ec64 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Tue, 12 Sep 2017 11:28:09 -0400 Subject: [PATCH 589/771] Remote: Add check that qsub was successful This prevents an infinite loop if `qsub` fails for some reason. See #1617. --- CHANGELOG.md | 2 ++ base/utils/R/start.model.runs.R | 6 +++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e8a3a089424..cf64ab1d119 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,6 +22,8 @@ For more information about this file see also [Keep a Changelog](http://keepacha - SIPNET output netcdf now includes LAI; some variable names changed to match standard - Cleanup of leap year logic, using new `PEcAn.utils::days_in_year(year)` function (#801). - Replace many hard-coded unit conversions with `udunits2::ud.convert` for consistency, readability, and clarity +- Bugfixes to remote: + - Check that `qsub` step works, and fail loudly if it doesn't ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) diff --git a/base/utils/R/start.model.runs.R b/base/utils/R/start.model.runs.R index 5ba9f5a1cbb..56eff754f52 100644 --- a/base/utils/R/start.model.runs.R +++ b/base/utils/R/start.model.runs.R @@ -122,7 +122,11 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error=TRUE) { PEcAn.logger::logger.debug(settings$host,format(run, scientific = FALSE)) } - PEcAn.logger::logger.debug("JOB.SH submit status:",out) + PEcAn.logger::logger.debug("JOB.SH submit status:", out) + qsub_worked <- grepl(settings$host$qsub.jobid, out) + if (!qsub_worked) { + PEcAn.logger::logger.severe("Job ID not assigned by qsub. The following qsub output may be relevant:\n", out) + } jobids[run] <- sub(settings$host$qsub.jobid, "\\1", out) # if qsub option is not invoked. just start model runs in serial. From 29c6d2902fbd480c2421b8f95063a5ae6dd075e0 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 12 Sep 2017 20:58:03 -0400 Subject: [PATCH 590/771] Updated Example, removed erraneous comment, alexey figured out how to retain filename with wget --- modules/data.land/R/dataone_download.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index a80dd9e9c59..1a5b1baaf99 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -11,7 +11,7 @@ #' #' @export #' -#' @examples doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", username = "Guest") +#' @examples doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", filepath = "/fs/data1/pecan.data/dbfiles/") dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNode = "PROD", lazyLoad = FALSE, quiet = F){ ### automatically retrieve mnId @@ -21,7 +21,7 @@ dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNod ### begin D1 download process d1c <- dataone::D1Client("PROD", mnId) - pkg <- dataone::getDataPackage(d1c, id = id, lazyLoad = lazyLoad, quiet = quiet, limit = "1MB") # what is the standard limit for pecan downloads? + pkg <- dataone::getDataPackage(d1c, id = id, lazyLoad = lazyLoad, quiet = quiet, limit = "1MB") files <- datapack::getValue(pkg, name="sysmeta@formatId") n <- length(files) # number of files @@ -31,7 +31,7 @@ dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNod for(i in 1:n){ rename <- paste(i, basename(names(files[i])), sep="_") # new file name - system(paste("cd", newdir, "&&", "{", "wget", "-O", rename, names(files)[i], "; cd -; }")) # cd to newdir, download files with wget, cd back + system(paste("cd", newdir, "&&", "{", "wget", "--content-disposition", rename, names(files)[i], "; cd -; }")) # cd to newdir, download files with wget, cd back } list.files(newdir) # checks that files were downloaded to From 85725846be71eb0f5dc6c8747610abaacd80720c Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 12 Sep 2017 21:11:16 -0400 Subject: [PATCH 591/771] Forgot to roxygenise before pushing --- modules/data.land/R/dataone_download.R | 4 +--- modules/data.land/man/dataone_download.Rd | 3 +++ 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index 412637beb1c..0abd987b98f 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -11,10 +11,8 @@ #' #' @export #' -<<<<<<< HEAD + #' @examples doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", filepath = "/fs/data1/pecan.data/dbfiles/") -======= ->>>>>>> 8e1e7400fa8f1ceb2ecc92be32fb10b87500a8a0 dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNode = "PROD", lazyLoad = FALSE, quiet = F){ ### automatically retrieve mnId diff --git a/modules/data.land/man/dataone_download.Rd b/modules/data.land/man/dataone_download.Rd index 35d68f3b021..5fc774adace 100644 --- a/modules/data.land/man/dataone_download.Rd +++ b/modules/data.land/man/dataone_download.Rd @@ -21,6 +21,9 @@ dataone_download(id, filepath = "/fs/data1/pecan.data/dbfiles/", \description{ Adapts the dataone::getDataPackage workflow to allow users to download data from the DataONE federation by simply entering the doi or associated package id } +\examples{ +doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", filepath = "/fs/data1/pecan.data/dbfiles/") +} \author{ Liam P Burke, \email{lpburke@bu.edu} } From b8c63a037a029982f85e28958daac5d78684b803 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 12 Sep 2017 21:01:22 -0500 Subject: [PATCH 592/771] Rough draft: dataone download code now runs --- shiny/Data-Ingest/app.R | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/shiny/Data-Ingest/app.R b/shiny/Data-Ingest/app.R index 706c03d81f6..562e6714b28 100644 --- a/shiny/Data-Ingest/app.R +++ b/shiny/Data-Ingest/app.R @@ -8,9 +8,11 @@ # library(shiny) -#library(PEcAn.data.land) -library(shinyDND) +library(PEcAn.data.land) library(shinydashboard) +library(dataone) + +#stopifnot # Define UI for application @@ -38,7 +40,8 @@ ui <- dashboardPage( box( # https://github.com/rstudio/shiny-examples/blob/master/009-upload/app.R - fileInput(inputId = "file", label = h3("Upload Local Files"), accept = NULL, multiple = TRUE, placeholder = "Drag and drop files here") + fileInput(inputId = "file", label = h3("Upload Local Files"), accept = NULL, multiple = TRUE, placeholder = "Drag and drop files here"), + p("This isn't linked to the server yet") ) ) ), @@ -54,14 +57,17 @@ ui <- dashboardPage( server <- function(input, output) { - d1d <- eventReactive(input$D1Button, { input$id }) #print doi on click + # d1d <- eventReactive(input$D1Button, { input$id }) #print doi on click - # d1d <- eventReactive(input$D1Button, { PEcAn.data.land::dataone_download(input$id) }) #run dataone_download on click + # How do I force R to load the dependencies before I run dataone_download? brew, redland, datapack, dataone + d1d <- eventReactive(input$D1Button, { PEcAn.data.land::dataone_download(input$id) }) #run dataone_download with input from id on click output$identifier <- renderText({ d1d() }) + # output$debug <- # file.copy copy from tmp file to + } # Run the application From a47efada611f99a184bd573eaa2c4676bd9df3c4 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Wed, 13 Sep 2017 08:57:38 -0400 Subject: [PATCH 593/771] ignore test output --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 58214759cc0..2ee3ac562d8 100644 --- a/.gitignore +++ b/.gitignore @@ -75,3 +75,5 @@ shiny/BenchmarkReport/* .check/ .test/ .doc/ +# files generated by tests +base/qaqc/tests/testthat/Rplots.pdf From df276e8afc78731773bfe1e5019df1675637f372 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Wed, 13 Sep 2017 10:57:10 -0400 Subject: [PATCH 594/771] Refactored extract_soil_nc to pull out soil conversions and writing to netcdf into it's own function, soil2netcdf, that can be used to easily save local soil data into PEcAn standard file. --- modules/data.land/R/extract_soil_nc.R | 56 ++------------------- modules/data.land/R/soil2netcdf.R | 70 +++++++++++++++++++++++++++ 2 files changed, 75 insertions(+), 51 deletions(-) create mode 100644 modules/data.land/R/soil2netcdf.R diff --git a/modules/data.land/R/extract_soil_nc.R b/modules/data.land/R/extract_soil_nc.R index 9de6e8ff004..220838e134b 100644 --- a/modules/data.land/R/extract_soil_nc.R +++ b/modules/data.land/R/extract_soil_nc.R @@ -89,56 +89,9 @@ extract_soil_nc <- function(in.file,outdir,lat,lon){ names(soil.data)[which(names(soil.data) == "cec")] <- "soil_cec" ## units = meq/100g names(soil.data)[which(names(soil.data) == "oc")] <- "soilC" ## this is currently the BETY name, would like to change and make units SI - ## convert soil type to parameters via look-up-table / equations - mysoil <- PEcAn.data.land::soil_params(sand=soil.data$volume_fraction_of_sand_in_soil, - silt=soil.data$volume_fraction_of_silt_in_soil, - clay=soil.data$volume_fraction_of_clay_in_soil, - bulk=soil.data$soil_bulk_density) - - ## Merge in new variables - for(n in seq_along(mysoil)){ - if(!(names(mysoil)[n] %in% names(soil.data))){ - soil.data[[names(mysoil)[n]]] <- mysoil[[n]] - } - } - - ## Because netCDF is a pain for storing strings, convert named class to number - ## conversion back can be done by load(system.file("data/soil_class.RData",package = "PEcAn.data.land")) - ## and then soil.name[soil_n] - soil.data$soil_type <- soil.data$soil_n - soil.data$soil_n <- NULL - - ## open new file - prefix <- tools::file_path_sans_ext(basename(in.file)) - new.file <- file.path(outdir,paste0(prefix,".nc")) - - ## create netCDF variables - ncvar <- list() - for(n in seq_along(soil.data)){ - varname <- names(soil.data)[n] - if(length(soil.data[[n]])>1){ - ## if vector, save by depth - ncvar[[n]] <- ncdf4::ncvar_def(name = varname, - units = soil.units(varname), - dim = depth) - }else { - ## else save as scalar - ncvar[[n]] <- ncdf4::ncvar_def(name = varname, - units = soil.units(varname), - dim=list()) - } - } - - ## create new file - nc <- ncdf4::nc_create(new.file, vars = ncvar) - - ## add data - for (i in seq_along(ncvar)) { - ncdf4::ncvar_put(nc, ncvar[[i]], soil.data[[i]]) - } - - ncdf4::nc_close(nc) - + ## Calculate soil parameters and export to netcdf + soil2netcdf(soil.data,new.file) + return(new.file) } @@ -153,7 +106,7 @@ extract_soil_nc <- function(in.file,outdir,lat,lon){ #' #' @examples #' soil.units("soil_albedo") -soil.units <- function(varname){ +soil.units <- function(varname = NA){ variables <- as.data.frame(matrix(c("soil_depth","m", "soil_cec","meq/100g", "volume_fraction_of_clay_in_soil","m3 m-3", @@ -186,6 +139,7 @@ soil.units <- function(varname){ unit = which(variables$var == varname) if(length(unit) == 0){ + print(variables) return(NA) }else{ unit = as.character(variables$unit[unit]) diff --git a/modules/data.land/R/soil2netcdf.R b/modules/data.land/R/soil2netcdf.R new file mode 100644 index 00000000000..96c63826655 --- /dev/null +++ b/modules/data.land/R/soil2netcdf.R @@ -0,0 +1,70 @@ +#' Save soil texture & parameters in PEcAn standard netCDF CF +#' +#' @param soil.data List of soil variables in standard names & units. Minimum is two of [sand, silt, clay]. Bulk density encouraged. +#' @param out.file +#' +#' @return none +#' @export +#' +#' @details +#' +#' A table of standard names and units can be displayed by running soil.units() without any arguements +#' +#' soil_params is called internally to estimate additional soil physical parameters from sand/silt/clay & bulk density. Will not overwrite any provided values +#' +#' Need to expand to alternatively take soil_type (texture class) as an input +#' +#' On output, soil_type named class is converted to a number because netCDF is a pain for storing strings. +#' Conversion back can be done by load(system.file("data/soil_class.RData",package = "PEcAn.data.land")) and then soil.name[soil_n] +#' +#' @examples +soil2netcdf <- function(soil.data,out.file){ + ## convert soil type to parameters via look-up-table / equations + mysoil <- PEcAn.data.land::soil_params(sand=soil.data$volume_fraction_of_sand_in_soil, + silt=soil.data$volume_fraction_of_silt_in_soil, + clay=soil.data$volume_fraction_of_clay_in_soil, + bulk=soil.data$soil_bulk_density) + + ## Merge in new variables + for(n in seq_along(mysoil)){ + if(!(names(mysoil)[n] %in% names(soil.data))){ + soil.data[[names(mysoil)[n]]] <- mysoil[[n]] + } + } + + ## convert soil_type to number + soil.data$soil_type <- soil.data$soil_n + soil.data$soil_n <- NULL + + ## open new file + prefix <- tools::file_path_sans_ext(basename(in.file)) + new.file <- file.path(outdir,paste0(prefix,".nc")) + + ## create netCDF variables + ncvar <- list() + for(n in seq_along(soil.data)){ + varname <- names(soil.data)[n] + if(length(soil.data[[n]])>1){ + ## if vector, save by depth + ncvar[[n]] <- ncdf4::ncvar_def(name = varname, + units = soil.units(varname), + dim = depth) + }else { + ## else save as scalar + ncvar[[n]] <- ncdf4::ncvar_def(name = varname, + units = soil.units(varname), + dim=list()) + } + } + + ## create new file + nc <- ncdf4::nc_create(new.file, vars = ncvar) + + ## add data + for (i in seq_along(ncvar)) { + ncdf4::ncvar_put(nc, ncvar[[i]], soil.data[[i]]) + } + + ncdf4::nc_close(nc) + +} \ No newline at end of file From 90a7ec0dec0c634a0ecaf8ef1403a01ef046b751 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Wed, 13 Sep 2017 11:16:48 -0400 Subject: [PATCH 595/771] debugging soil2netcdf & adding example --- modules/data.land/R/extract_soil_nc.R | 4 ++++ modules/data.land/R/soil2netcdf.R | 23 +++++++++++++++++------ 2 files changed, 21 insertions(+), 6 deletions(-) diff --git a/modules/data.land/R/extract_soil_nc.R b/modules/data.land/R/extract_soil_nc.R index 220838e134b..ca487bf27da 100644 --- a/modules/data.land/R/extract_soil_nc.R +++ b/modules/data.land/R/extract_soil_nc.R @@ -89,6 +89,10 @@ extract_soil_nc <- function(in.file,outdir,lat,lon){ names(soil.data)[which(names(soil.data) == "cec")] <- "soil_cec" ## units = meq/100g names(soil.data)[which(names(soil.data) == "oc")] <- "soilC" ## this is currently the BETY name, would like to change and make units SI + ## calc new filename + prefix <- tools::file_path_sans_ext(basename(in.file)) + new.file <- file.path(outdir,paste0(prefix,".nc")) + ## Calculate soil parameters and export to netcdf soil2netcdf(soil.data,new.file) diff --git a/modules/data.land/R/soil2netcdf.R b/modules/data.land/R/soil2netcdf.R index 96c63826655..a8c86bc5695 100644 --- a/modules/data.land/R/soil2netcdf.R +++ b/modules/data.land/R/soil2netcdf.R @@ -1,7 +1,7 @@ #' Save soil texture & parameters in PEcAn standard netCDF CF #' -#' @param soil.data List of soil variables in standard names & units. Minimum is two of [sand, silt, clay]. Bulk density encouraged. -#' @param out.file +#' @param soil.data List of soil variables in standard names & units. Minimum is soil_depth and two of [sand, silt, clay]. Bulk density encouraged. +#' @param new.file #' #' @return none #' @export @@ -18,7 +18,16 @@ #' Conversion back can be done by load(system.file("data/soil_class.RData",package = "PEcAn.data.land")) and then soil.name[soil_n] #' #' @examples -soil2netcdf <- function(soil.data,out.file){ +#' \dontrun{ +#' soil.data <- list(volume_fraction_of_sand_in_soil = c(0.3,0.4,0.5), +#' volume_fraction_of_clay_in_soil = c(0.3,0.3,0.3), +#' soil_depth = c(0.2,0.5,1.0)) +#' +#' soil2netcdf(soil.data,"soil.nc") +#' } +soil2netcdf <- function(soil.data,new.file){ + soil.data <- as.list(soil.data) + ## convert soil type to parameters via look-up-table / equations mysoil <- PEcAn.data.land::soil_params(sand=soil.data$volume_fraction_of_sand_in_soil, silt=soil.data$volume_fraction_of_silt_in_soil, @@ -36,13 +45,14 @@ soil2netcdf <- function(soil.data,out.file){ soil.data$soil_type <- soil.data$soil_n soil.data$soil_n <- NULL - ## open new file - prefix <- tools::file_path_sans_ext(basename(in.file)) - new.file <- file.path(outdir,paste0(prefix,".nc")) + ## create depth dimension + depth <- ncdf4::ncdim_def(name = "depth", units = "meters", vals = soil.data$soil_depth, create_dimvar = TRUE) + soil.data$soil_depth <- NULL ## deleting so don't ALSO write as a variable ## create netCDF variables ncvar <- list() for(n in seq_along(soil.data)){ + if(is.null(soil.data[[n]])) next varname <- names(soil.data)[n] if(length(soil.data[[n]])>1){ ## if vector, save by depth @@ -62,6 +72,7 @@ soil2netcdf <- function(soil.data,out.file){ ## add data for (i in seq_along(ncvar)) { + if(is.null(soil.data[[n]]) || length(soil.data[[i]])==0) next ncdf4::ncvar_put(nc, ncvar[[i]], soil.data[[i]]) } From bdffd22860ae45ad3c6387a431827d93e4202b24 Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Wed, 13 Sep 2017 11:25:19 -0400 Subject: [PATCH 596/771] Updates to modules/data.atmosphere/R/download.CRUNCEP_Global.R to address issue #1649. Created new retry.func() in base/utils.R. Updated documentation. --- base/utils/NAMESPACE | 1 + base/utils/R/utils.R | 73 ++++++++++++++++++- base/utils/man/bibtexify.Rd | 3 + base/utils/man/retry.func.Rd | 35 +++++++++ .../R/download.CRUNCEP_Global.R | 17 +++-- .../data.atmosphere/man/download.CRUNCEP.Rd | 6 +- 6 files changed, 124 insertions(+), 11 deletions(-) create mode 100644 base/utils/man/retry.func.Rd diff --git a/base/utils/NAMESPACE b/base/utils/NAMESPACE index cde2e4dd9ad..44fd8da49c9 100644 --- a/base/utils/NAMESPACE +++ b/base/utils/NAMESPACE @@ -67,6 +67,7 @@ export(remote.copy.to) export(remote.copy.update) export(remote.execute.R) export(remote.execute.cmd) +export(retry.func) export(rsync) export(run.write.configs) export(runModule.get.results) diff --git a/base/utils/R/utils.R b/base/utils/R/utils.R index b2105787d64..8a9f67af82f 100644 --- a/base/utils/R/utils.R +++ b/base/utils/R/utils.R @@ -332,6 +332,7 @@ get.parameter.stat <- function(mcmc.summary, parameter) { ucl = mcmc.summary$quantiles[parameter, c("97.5%")], n = 2) } # get.parameter.stat +#--------------------------------------------------------------------------------------------------# #--------------------------------------------------------------------------------------------------# @@ -364,6 +365,7 @@ pdf.stats <- function(distn, A, B) { out <- unlist(list(mean = mean, var = var, lcl = lcl, ucl = ucl)) return(out) } # pdf.stats +#--------------------------------------------------------------------------------------------------# #--------------------------------------------------------------------------------------------------# @@ -416,6 +418,7 @@ tabnum <- function(x, n = 3) { names(ans) <- names(x) return(ans) } # tabnum +#--------------------------------------------------------------------------------------------------# #--------------------------------------------------------------------------------------------------# @@ -433,6 +436,7 @@ arrhenius.scaling <- function(observed.value, old.temp, new.temp = 25) { old.temp.K <- udunits2::ud.convert(old.temp, "degC", "K") return(observed.value / exp(3000 * (1 / (new.temp.K) - 1 / (old.temp.K)))) } # arrhenius.scaling +#--------------------------------------------------------------------------------------------------# #--------------------------------------------------------------------------------------------------# @@ -442,7 +446,6 @@ arrhenius.scaling <- function(observed.value, old.temp, new.temp = 25) { ##' @param x string ##' @return x, capitalized ##' @author David LeBauer -#--------------------------------------------------------------------------------------------------# capitalize <- function(x) { x <- as.character(x) s <- strsplit(x, " ")[[1]] @@ -450,6 +453,7 @@ capitalize <- function(x) { } # capitalize isFALSE <- function(x) !isTRUE(x) +#--------------------------------------------------------------------------------------------------# #--------------------------------------------------------------------------------------------------# @@ -475,6 +479,7 @@ newxtable <- function(x, environment = "table", table.placement = "ht", label = # sanitize.text.function = function(x) gsub("%", "\\\\%", x), sanitize.rownames.function = function(x) paste('')) } # newxtable +#--------------------------------------------------------------------------------------------------# #--------------------------------------------------------------------------------------------------# @@ -486,11 +491,12 @@ newxtable <- function(x, environment = "table", table.placement = "ht", label = ##' @param year year of publication ##' @param title manuscript title ##' @return bibtex citation -#--------------------------------------------------------------------------------------------------# +##' @author unknown bibtexify <- function(author, year, title) { acronym <- abbreviate(title, minlength = 3, strict = TRUE) return(paste0(author, year, acronym)) } # bibtexify +#--------------------------------------------------------------------------------------------------# #--------------------------------------------------------------------------------------------------# @@ -514,6 +520,7 @@ as.sequence <- function(x, na.rm = TRUE) { } return(x2) } # as.sequence +#--------------------------------------------------------------------------------------------------# #--------------------------------------------------------------------------------------------------# @@ -528,8 +535,10 @@ as.sequence <- function(x, na.rm = TRUE) { test.remote <- function(host) { return(try(remote.execute.cmd(host, "/bin/true")) == 0) } # test.remote +#--------------------------------------------------------------------------------------------------# +#--------------------------------------------------------------------------------------------------# ##' Create a temporary settings file ##' ##' Uses \code{\link{tempfile}} function to provide a valid temporary file (OS independent) @@ -547,8 +556,10 @@ temp.settings <- function(settings.txt) { settings <- readLines(temp) return(settings) } # temp.settings +#--------------------------------------------------------------------------------------------------# +#--------------------------------------------------------------------------------------------------# ##' Test if function gives an error ##' ##' adaptation of try that returns a logical value (FALSE if error) @@ -567,8 +578,10 @@ tryl <- function(FUN) { ans <- !any(class(out) == "error") return(ans) } # tryl +#--------------------------------------------------------------------------------------------------# +#--------------------------------------------------------------------------------------------------# ##' load model package ##' @title Load model package ##' @param model name of model @@ -588,7 +601,10 @@ load.modelpkg <- function(model) { } } } # load.modelpkg +#--------------------------------------------------------------------------------------------------# + +#--------------------------------------------------------------------------------------------------# ##' conversion function for the unit conversions that udunits cannot handle but often needed in PEcAn calculations ##' @title misc.convert ##' @export @@ -624,8 +640,10 @@ misc.convert <- function(x, u1, u2) { } return(val) } # misc.convert +#--------------------------------------------------------------------------------------------------# +#--------------------------------------------------------------------------------------------------# ##' function to check whether units are convertible by misc.convert function ##' @title misc.are.convertible ##' @export @@ -653,8 +671,10 @@ misc.are.convertible <- function(u1, u2) { return(FALSE) } } +#--------------------------------------------------------------------------------------------------# +#--------------------------------------------------------------------------------------------------# ##' Convert expression to variable names ##' @title convert.expr ##' @param expression expression string @@ -678,8 +698,10 @@ convert.expr <- function(expression) { return(list(variable.drv = deri.var, variable.eqn = list(variables = variables, expression = deri.eqn))) } +#--------------------------------------------------------------------------------------------------# +#--------------------------------------------------------------------------------------------------# ##' Simple function to use ncftpget for FTP downloads behind a firewall. ##' Requires ncftpget and a properly formatted config file in the users ##' home directory @@ -714,9 +736,54 @@ download.file <- function(url, filename, method) { utils::download.file(url, filename) } } +#--------------------------------------------------------------------------------------------------# + +#--------------------------------------------------------------------------------------------------# +##' Retry function X times before stopping in error +##' +##' @title retry.func +##' @name retry.func +##' @description Retry function X times before stopping in error +##' +##' @param expr The function to try running +##' @param maxErrors The number of times to retry the function +##' @param sleep How long to wait before retrying the function call +##' +##' @return retval returns the results of the function call +##' +##' @examples +##' \dontrun{ +##' dap <- retry.func(ncdf4::nc_open('https://thredds.daac.ornl.gov/thredds/dodsC/ornldaac/1220/mstmip_driver_global_hd_climate_lwdown_1999_v1.nc4'), +##' maxErrors=10, sleep=2) +##' } +##' +##' @export +##' @author Shawn Serbin + +retry.func <- function(expr, isError=function(x) "try-error" %in% class(x), maxErrors=5, sleep=0) { + attempts = 0 + retval = try(eval(expr)) + while (isError(retval)) { + attempts = attempts + 1 + if (attempts >= maxErrors) { + msg = sprintf("retry: too many retries [[%s]]", capture.output(str(retval))) + PEcAn.logger::logger.warn(msg) + stop(msg) + } else { + msg = sprintf("retry: error in attempt %i/%i [[%s]]", attempts, maxErrors, + capture.output(str(retval))) + PEcAn.logger::logger.warn(msg) + #warning(msg) + } + if (sleep > 0) Sys.sleep(sleep) + retval = try(eval(expr)) + } + return(retval) +} +#--------------------------------------------------------------------------------------------------# #################################################################################################### ### EOF. End of R script file. -#################################################################################################### +#################################################################################################### \ No newline at end of file diff --git a/base/utils/man/bibtexify.Rd b/base/utils/man/bibtexify.Rd index 63eaf307ce2..db981ef1ecc 100644 --- a/base/utils/man/bibtexify.Rd +++ b/base/utils/man/bibtexify.Rd @@ -22,3 +22,6 @@ Convert author, year, title to bibtex citation format \details{ Converts author year title to author1999abc format } +\author{ +unknown +} diff --git a/base/utils/man/retry.func.Rd b/base/utils/man/retry.func.Rd new file mode 100644 index 00000000000..f24e5416c72 --- /dev/null +++ b/base/utils/man/retry.func.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{retry.func} +\alias{retry.func} +\title{retry.func} +\usage{ +retry.func(expr, isError = function(x) "try-error" \%in\% class(x), + maxErrors = 5, sleep = 0) +} +\arguments{ +\item{expr}{The function to try running} + +\item{maxErrors}{The number of times to retry the function} + +\item{sleep}{How long to wait before retrying the function call} +} +\value{ +retval returns the results of the function call +} +\description{ +Retry function X times before stopping in error +} +\details{ +Retry function X times before stopping in error +} +\examples{ +\dontrun{ +dap <- retry.func(ncdf4::nc_open('https://thredds.daac.ornl.gov/thredds/dodsC/ornldaac/1220/mstmip_driver_global_hd_climate_lwdown_1999_v1.nc4'), +maxErrors=10, sleep=2) +} + +} +\author{ +Shawn Serbin +} diff --git a/modules/data.atmosphere/R/download.CRUNCEP_Global.R b/modules/data.atmosphere/R/download.CRUNCEP_Global.R index 839c9a7050d..09ea13773ca 100644 --- a/modules/data.atmosphere/R/download.CRUNCEP_Global.R +++ b/modules/data.atmosphere/R/download.CRUNCEP_Global.R @@ -10,12 +10,14 @@ ##' @param overwrite logical. Download a fresh version even if a local file with the same name already exists? ##' @param verbose logical. Passed on to \code{\link[ncdf4]{ncvar_def}} and \code{\link[ncdf4]{nc_create}} ##' to control printing of debug info +##' @param maxErrors Maximum times to re-try folloing an error accessing netCDF data through THREDDS +##' @param sleep Wait time between attempts following a THREDDS or other error ##' @param ... Other arguments, currently ignored ##' @export ##' ##' @author James Simkins, Mike Dietze download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, lon.in, - overwrite = FALSE, verbose = FALSE, ...) { + overwrite = FALSE, verbose = FALSE, maxErrors = 10, sleep = 2, ...) { start_date <- as.POSIXlt(start_date, tz = "UTC") end_date <- as.POSIXlt(end_date, tz = "UTC") @@ -97,8 +99,9 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l PEcAn.logger::logger.info(dap_file) # This throws an error if file not found - dap <- ncdf4::nc_open(dap_file) - + #dap <- ncdf4::nc_open(dap_file, verbose=FALSE) + dap <- retry.func(ncdf4::nc_open(dap_file, verbose=verbose), maxErrors=maxErrors, sleep=sleep) + # confirm that timestamps match if (dap$dim$time$len != ntime) { PEcAn.logger::logger.severe("Expected", ntime, "observations, but", dap_file, "contained", dap$dim$time$len) @@ -113,16 +116,16 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l } - dat.list[[j]] <- ncdf4::ncvar_get(dap, + dat.list[[j]] <- retry.func(ncdf4::ncvar_get(dap, as.character(var$DAP.name[j]), c(lon_grid, lat_grid, 1), - c(1, 1, ntime)) + c(1, 1, ntime)), maxErrors=maxErrors, sleep=sleep) - var.list[[j]] <- ncdf4::ncvar_def(name = as.character(var$CF.name[j]), + var.list[[j]] <- retry.func(ncdf4::ncvar_def(name = as.character(var$CF.name[j]), units = as.character(var$units[j]), dim = dim, missval = -999, - verbose = verbose) + verbose = verbose), maxErrors=maxErrors, sleep=sleep) ncdf4::nc_close(dap) } ## change units of precip to kg/m2/s instead of 6 hour accumulated precip diff --git a/modules/data.atmosphere/man/download.CRUNCEP.Rd b/modules/data.atmosphere/man/download.CRUNCEP.Rd index 1c174c15883..4fde088fa2f 100644 --- a/modules/data.atmosphere/man/download.CRUNCEP.Rd +++ b/modules/data.atmosphere/man/download.CRUNCEP.Rd @@ -5,7 +5,7 @@ \title{Download CRUNCEP data} \usage{ download.CRUNCEP(outfolder, start_date, end_date, site_id, lat.in, lon.in, - overwrite = FALSE, verbose = FALSE, ...) + overwrite = FALSE, verbose = FALSE, maxErrors = 10, sleep = 2, ...) } \arguments{ \item{outfolder}{Directory where results should be written} @@ -24,6 +24,10 @@ but only the year portion is used and the resulting files always contain a full \item{verbose}{logical. Passed on to \code{\link[ncdf4]{ncvar_def}} and \code{\link[ncdf4]{nc_create}} to control printing of debug info} +\item{maxErrors}{Maximum times to re-try folloing an error accessing netCDF data through THREDDS} + +\item{sleep}{Wait time between attempts following a THREDDS or other error} + \item{...}{Other arguments, currently ignored} } \description{ From b284cc3b74bb7307b667c7cbabd7d1598f3615d3 Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Wed, 13 Sep 2017 11:31:19 -0400 Subject: [PATCH 597/771] Updated changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index e8a3a089424..d787db0271e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,6 +22,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - SIPNET output netcdf now includes LAI; some variable names changed to match standard - Cleanup of leap year logic, using new `PEcAn.utils::days_in_year(year)` function (#801). - Replace many hard-coded unit conversions with `udunits2::ud.convert` for consistency, readability, and clarity +- Added a new retry.func() to base/utils to provide ability to re-try a function X times before stopping. Currently using this function in the download.CRUNCEP() function to handle slow responses from THREDDS. ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) From a45c859a919f2b956c77f83d75c7e9de56a437ee Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Wed, 13 Sep 2017 11:58:01 -0400 Subject: [PATCH 598/771] updated documentation and changelog --- CHANGELOG.md | 1 + .../basic_users_guide/Choosing-soils.Rmd | 28 +++++++++++++++++++ modules/data.land/R/extract_soil_nc.R | 7 +++-- 3 files changed, 34 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e8a3a089424..77527473ce8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,6 +22,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - SIPNET output netcdf now includes LAI; some variable names changed to match standard - Cleanup of leap year logic, using new `PEcAn.utils::days_in_year(year)` function (#801). - Replace many hard-coded unit conversions with `udunits2::ud.convert` for consistency, readability, and clarity +- Refactored extract_soil_nc to create soil2netcdf, which will write soil data out in PEcAn standard. ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) diff --git a/book_source/basic_users_guide/Choosing-soils.Rmd b/book_source/basic_users_guide/Choosing-soils.Rmd index d104ed134e1..94d35de4d2d 100755 --- a/book_source/basic_users_guide/Choosing-soils.Rmd +++ b/book_source/basic_users_guide/Choosing-soils.Rmd @@ -4,4 +4,32 @@ Many models have requirements for soils information, which may include: site-spe As with [[Choosing initial vegetation]], we eventually hope to develop data standards, soils workflows, and spin-up tools, but at the moment model requirements need to be met by [inserting Input data](../developers_guide/How-to-insert-new-Input-data.html) into the database or using files that have already been uploaded. +### Soil texture, depth, and physical parameters + +A PEcAn-standard netCDF file format exists for soil texture, depth, and physical parameters, using PEcAn standard names that are largely a direct extention of the CF standard. A table of standard names and units can be listed using ```PEcAn.data.land::soil.units()``` with no arguements. + +Local data that has the correct names and units can easily be written out in PEcAn standard using the function soil2netcdf. + +``` +soil.data <- list(volume_fraction_of_sand_in_soil = c(0.3,0.4,0.5), + volume_fraction_of_clay_in_soil = c(0.3,0.3,0.3), + soil_depth = c(0.2,0.5,1.0)) + +soil2netcdf(soil.data,"soil.nc") +``` + +At the moment this file would need to be inserted into Inputs manually. By default, this function also calls soil_params, which will estimate a number of hydraulic and thermal parameters from texture. Be aware that at the moment not all model couplers are yet set up to read this file and/or convert it to model-specific formats. + +In addition to location-specific soil data, PEcAn can extract soil texture information from the PalEON regional soil product, which itself is a subset of the MsTMIP Unified North American Soil Map. If this product is installed on your machine, the appropriate step in the do_conversions workflow is enabled by adding the following tag under `````` in your pecan.xml + +``` + + 1000012896 + +``` + +In the future we aim to extend this extraction to a wider range of soil products. + +## Other model inputs + Finally, any other model-specific inputs (e.g. N deposition, land use history, etc), should be met by [inserting Input data](../developers_guide/How-to-insert-new-Input-data.html) into the database or using files that have already been uploaded. diff --git a/modules/data.land/R/extract_soil_nc.R b/modules/data.land/R/extract_soil_nc.R index ca487bf27da..ac38dd4df3f 100644 --- a/modules/data.land/R/extract_soil_nc.R +++ b/modules/data.land/R/extract_soil_nc.R @@ -143,8 +143,11 @@ soil.units <- function(varname = NA){ unit = which(variables$var == varname) if(length(unit) == 0){ - print(variables) - return(NA) + if(is.na(varname)){ + return(variables) + } else { + return(NA) + } }else{ unit = as.character(variables$unit[unit]) return(unit) From 296e0d8ccc22b38d074e1b24bf955c0d44f4e066 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Wed, 13 Sep 2017 12:23:04 -0400 Subject: [PATCH 599/771] Add soil variable table to documentation --- book_source/basic_users_guide/Choosing-soils.Rmd | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/book_source/basic_users_guide/Choosing-soils.Rmd b/book_source/basic_users_guide/Choosing-soils.Rmd index 94d35de4d2d..5d310652c63 100755 --- a/book_source/basic_users_guide/Choosing-soils.Rmd +++ b/book_source/basic_users_guide/Choosing-soils.Rmd @@ -8,6 +8,11 @@ As with [[Choosing initial vegetation]], we eventually hope to develop data stan A PEcAn-standard netCDF file format exists for soil texture, depth, and physical parameters, using PEcAn standard names that are largely a direct extention of the CF standard. A table of standard names and units can be listed using ```PEcAn.data.land::soil.units()``` with no arguements. +```{r} +knitr::kable(PEcAn.data.land::soil.units()) +``` + + Local data that has the correct names and units can easily be written out in PEcAn standard using the function soil2netcdf. ``` From d66e5a33b1ccec463fda34dd36c10083eee47e6e Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 13 Sep 2017 13:06:31 -0400 Subject: [PATCH 600/771] remote: Create the remote package This commit moves functions related to remote execution, and to starting model runs, from `utils` to their own package `base/remote`. It also contains a major refactor of the `start.model.runs` code that makes this code more modular and, hopefully, easier to maintain. --- base/remote/.Rbuildignore | 2 + base/remote/DESCRIPTION | 13 + base/remote/LICENSE | 29 ++ base/remote/NAMESPACE | 21 ++ base/remote/R/check_model_run.R | 17 + base/remote/R/check_qsub_status.R | 32 ++ base/remote/R/is.localhost.R | 21 ++ base/{utils => remote}/R/kill.tunnel.R | 0 base/{utils => remote}/R/open.tunnel.R | 46 +-- base/remote/R/qsub_get_jobid.R | 24 ++ base/remote/R/remote.copy.from.R | 48 +++ base/remote/R/remote.copy.to.R | 50 +++ base/remote/R/remote.copy.update.R | 41 +++ base/remote/R/remote.execute.R.R | 47 +++ base/remote/R/remote.execute.cmd.R | 41 +++ base/remote/R/setup_modellauncher.R | 19 ++ base/remote/R/stamp.R | 26 ++ base/remote/R/start.model.runs.R | 206 ++++++++++++ base/remote/R/start_qsub.R | 41 +++ base/remote/R/start_serial.R | 14 + base/remote/R/test_remote.R | 42 +++ base/remote/man/check_model_run.Rd | 16 + base/remote/man/hello.Rd | 12 + base/{utils => remote}/man/is.localhost.Rd | 2 +- base/{utils => remote}/man/kill.tunnel.Rd | 0 base/{utils => remote}/man/open_tunnel.Rd | 9 +- base/remote/man/qsub_get_jobid.Rd | 19 ++ base/remote/man/qsub_run_finished.Rd | 21 ++ .../{utils => remote}/man/remote.copy.from.Rd | 2 +- base/{utils => remote}/man/remote.copy.to.Rd | 11 +- .../man/remote.copy.update.Rd | 2 +- base/remote/man/remote.execute.R.Rd | 38 +++ .../man/remote.execute.cmd.Rd | 4 +- base/remote/man/setup_modellauncher.Rd | 22 ++ base/remote/man/stamp_started.Rd | 22 ++ .../{utils => remote}/man/start.model.runs.Rd | 10 +- base/remote/man/start_qsub.Rd | 36 ++ base/remote/man/start_serial.Rd | 20 ++ base/remote/man/test_remote.Rd | 32 ++ base/remote/tests/testthat.R | 4 + .../tests/testthat/test.localhost.R | 0 base/remote/tests/testthat/test.remote.R | 29 ++ base/utils/NAMESPACE | 10 - base/utils/R/remote.R | 312 ------------------ base/utils/R/start.model.runs.R | 306 ----------------- base/utils/man/remote.execute.R.Rd | 39 --- 46 files changed, 1049 insertions(+), 709 deletions(-) create mode 100644 base/remote/.Rbuildignore create mode 100644 base/remote/DESCRIPTION create mode 100644 base/remote/LICENSE create mode 100644 base/remote/NAMESPACE create mode 100644 base/remote/R/check_model_run.R create mode 100644 base/remote/R/check_qsub_status.R create mode 100644 base/remote/R/is.localhost.R rename base/{utils => remote}/R/kill.tunnel.R (100%) rename base/{utils => remote}/R/open.tunnel.R (66%) create mode 100644 base/remote/R/qsub_get_jobid.R create mode 100644 base/remote/R/remote.copy.from.R create mode 100644 base/remote/R/remote.copy.to.R create mode 100644 base/remote/R/remote.copy.update.R create mode 100644 base/remote/R/remote.execute.R.R create mode 100644 base/remote/R/remote.execute.cmd.R create mode 100644 base/remote/R/setup_modellauncher.R create mode 100644 base/remote/R/stamp.R create mode 100644 base/remote/R/start.model.runs.R create mode 100644 base/remote/R/start_qsub.R create mode 100644 base/remote/R/start_serial.R create mode 100644 base/remote/R/test_remote.R create mode 100644 base/remote/man/check_model_run.Rd create mode 100644 base/remote/man/hello.Rd rename base/{utils => remote}/man/is.localhost.Rd (91%) rename base/{utils => remote}/man/kill.tunnel.Rd (100%) rename base/{utils => remote}/man/open_tunnel.Rd (71%) create mode 100644 base/remote/man/qsub_get_jobid.Rd create mode 100644 base/remote/man/qsub_run_finished.Rd rename base/{utils => remote}/man/remote.copy.from.Rd (94%) rename base/{utils => remote}/man/remote.copy.to.Rd (73%) rename base/{utils => remote}/man/remote.copy.update.Rd (91%) create mode 100644 base/remote/man/remote.execute.R.Rd rename base/{utils => remote}/man/remote.execute.cmd.Rd (88%) create mode 100644 base/remote/man/setup_modellauncher.Rd create mode 100644 base/remote/man/stamp_started.Rd rename base/{utils => remote}/man/start.model.runs.Rd (57%) create mode 100644 base/remote/man/start_qsub.Rd create mode 100644 base/remote/man/start_serial.Rd create mode 100644 base/remote/man/test_remote.Rd create mode 100644 base/remote/tests/testthat.R rename base/{utils => remote}/tests/testthat/test.localhost.R (100%) create mode 100644 base/remote/tests/testthat/test.remote.R delete mode 100644 base/utils/R/remote.R delete mode 100644 base/utils/R/start.model.runs.R delete mode 100644 base/utils/man/remote.execute.R.Rd diff --git a/base/remote/.Rbuildignore b/base/remote/.Rbuildignore new file mode 100644 index 00000000000..91114bf2f2b --- /dev/null +++ b/base/remote/.Rbuildignore @@ -0,0 +1,2 @@ +^.*\.Rproj$ +^\.Rproj\.user$ diff --git a/base/remote/DESCRIPTION b/base/remote/DESCRIPTION new file mode 100644 index 00000000000..abb40fca92a --- /dev/null +++ b/base/remote/DESCRIPTION @@ -0,0 +1,13 @@ +Package: PEcAn.remote +Type: Package +Title: PEcAn model execution utilities +Version: 0.1.0 +Author: Alexey Shiklomanov, Rob Kooper, Shawn Serbin, David LeBauer +Maintainer: Alexey Shiklomanov +Description: This package contains utilities for communicating with and executing code on local and remote hosts. + In particular, it has PEcAn-specific utilities for starting ecosystem model runs. +License: FreeBSD + file LICENSE +Encoding: UTF-8 +LazyData: true +Roxygen: list(markdown = TRUE) +RoxygenNote: 6.0.1 diff --git a/base/remote/LICENSE b/base/remote/LICENSE new file mode 100644 index 00000000000..9e38c2dc685 --- /dev/null +++ b/base/remote/LICENSE @@ -0,0 +1,29 @@ +University of Illinois/NCSA Open Source License + +Copyright (c) 2012, University of Illinois, NCSA. All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal with the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimers. +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimers in the + documentation and/or other materials provided with the distribution. +- Neither the names of University of Illinois, NCSA, nor the names + of its contributors may be used to endorse or promote products + derived from this Software without specific prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR +ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF +CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. + diff --git a/base/remote/NAMESPACE b/base/remote/NAMESPACE new file mode 100644 index 00000000000..172687efd19 --- /dev/null +++ b/base/remote/NAMESPACE @@ -0,0 +1,21 @@ +# Generated by roxygen2: do not edit by hand + +export(check_model_run) +export(is.localhost) +export(kill.tunnel) +export(open_tunnel) +export(qsub_get_jobid) +export(qsub_run_finished) +export(remote.copy.from) +export(remote.copy.to) +export(remote.copy.update) +export(remote.execute.R) +export(remote.execute.cmd) +export(runModule.start.model.runs) +export(setup_modellauncher) +export(stamp_finished) +export(stamp_started) +export(start.model.runs) +export(start_qsub) +export(start_serial) +export(test_remote) diff --git a/base/remote/R/check_model_run.R b/base/remote/R/check_model_run.R new file mode 100644 index 00000000000..e3fa735caa6 --- /dev/null +++ b/base/remote/R/check_model_run.R @@ -0,0 +1,17 @@ +#' Check if model run was successful +#' +#' @param out Output from model execution, as a character. +#' @inheritParams start.model.runs +#' +#' @return +#' @export +check_model_run <- function(out, stop.on.error = TRUE) { + if ("ERROR IN MODEL RUN" %in% out) { + msg <- paste0("Model run aborted with the following error:\n", out) + if (stop.on.error) { + PEcAn.logger::logger.severe(msg) + } else { + PEcAn.logger::logger.error(msg) + } + } +} \ No newline at end of file diff --git a/base/remote/R/check_qsub_status.R b/base/remote/R/check_qsub_status.R new file mode 100644 index 00000000000..44a141c7711 --- /dev/null +++ b/base/remote/R/check_qsub_status.R @@ -0,0 +1,32 @@ +#' Check if qsub run finished +#' +#' @param run run ID, as an integer +#' @param qstat (string) qstat command for checking job status +#' @inheritParams remote.execute.cmd +#' +#' @return `TRUE` if run is marked as DONE, otherwise FALSE. +#' @export +qsub_run_finished <- function(run, host, qstat) { + if (is.na(run)) { + PEcAn.logger::logger.warn("Job", run, "encountered an error during submission.", + "NOTE that the job will be stamped as 'finished' in BETY.") + return(FALSE) + } + run_id_string <- format(run, scientific = FALSE) + check <- gsub("@JOBID", run, qstat) + cmd_list <- strsplit(check, " (?=([^\"']*\"[^\"']*\")*[^\"']*$)", perl = TRUE) + cmd <- cmd_list[[1]] + args <- cmd_list[-1] + if (is.localhost(host)) { + out <- system2(cmd, args, stdout = TRUE, stderr = TRUE) + } else { + out <- remote.execute.cmd(host = host, cmd = cmd, args = args, stderr = TRUE) + } + + if (length(out) > 0 && substring(out, nchar(out) - 3) == "DONE") { + PEcAn.logger::logger.debug("Job", run, "for run", run_id_string, "finished") + return(TRUE) + } else { + return(FALSE) + } +} \ No newline at end of file diff --git a/base/remote/R/is.localhost.R b/base/remote/R/is.localhost.R new file mode 100644 index 00000000000..8b32c190f56 --- /dev/null +++ b/base/remote/R/is.localhost.R @@ -0,0 +1,21 @@ +#' Check if host is local +#' +#' Given the hostname is this the localhost. This returns true if either +#' the value is localhost, or the value is the same as the fqdn. +#' +#' @title Check if local host +#' @param host the hostname to be checked +#' @return true if the host is the local host name +#' @author Rob Kooper +#' @export +#' @examples +#' is.localhost(fqdn()) +is.localhost <- function(host) { + if (is.character(host)) { + return((host == "localhost") || (host == PEcAn.utils::fqdn())) + } else if (is.list(host)) { + return((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) + } else { + return(FALSE) + } +} # is.localhost diff --git a/base/utils/R/kill.tunnel.R b/base/remote/R/kill.tunnel.R similarity index 100% rename from base/utils/R/kill.tunnel.R rename to base/remote/R/kill.tunnel.R diff --git a/base/utils/R/open.tunnel.R b/base/remote/R/open.tunnel.R similarity index 66% rename from base/utils/R/open.tunnel.R rename to base/remote/R/open.tunnel.R index bc17beb7eca..b55c56675c3 100644 --- a/base/utils/R/open.tunnel.R +++ b/base/remote/R/open.tunnel.R @@ -1,63 +1,65 @@ -#' Title +#' Open an SSH tunnel #' #' @param remote_host name of remote server to connect to (e.g. geo.bu.edu) #' @param tunnel_dir directory to store tunnel file in, typically from settings$host #' @param user username on remote_host #' @param password password on remote_host #' @param wait.time how long to give system to connect before deleting password (seconds) +#' @param tunnel_script Path to sshtunnel.sh script file for opening tunnel #' #' @return #' @export #' #' @examples -open_tunnel <- function(remote_host,user=NULL,password=NULL,tunnel_dir = "~/.pecan/tunnel/",wait.time=15){ - +open_tunnel <- function(remote_host, user = NULL, password = NULL, tunnel_dir = "~/.pecan/tunnel/", + wait.time = 15, tunnel_script = '~/pecan/web/sshtunnel.sh'){ + ## make sure local tunnel directory exists dir.create(tunnel_dir) - + ## get username if not provided if(is.null(user)){ user <- readline("Username:: ") } - + ## get password if not provided if(is.null(password)){ password <- getPass::getPass() } - - sshTunnel <- file.path(tunnel_dir,"tunnel") - sshPID <- file.path(tunnel_dir,"pid") - sshPassFile <- file.path(tunnel_dir,"password") - + + sshTunnel <- file.path(tunnel_dir, "tunnel") + sshPID <- file.path(tunnel_dir, "pid") + sshPassFile <- file.path(tunnel_dir, "password") + if(file.exists(sshTunnel)){ PEcAn.logger::logger.warn("Tunnel already exists. If tunnel is not working try calling kill.tunnel then reopen") return(TRUE) } - + ## write password to temporary file PEcAn.logger::logger.warn(sshPassFile) - write(password,file = sshPassFile) + write(password, file = sshPassFile) # start <- system(paste0("ssh -nN -o ControlMaster=yes -o ControlPath=",sshTunnel," -l ",user," ",remote_host),wait = FALSE,input = password) # Sys.sleep(5) # end <- system2("send",password) - - stat <- system(paste("~/pecan/web/sshtunnel.sh",remote_host,user,tunnel_dir),wait=FALSE) - + + stat <- system(paste(tunnel_script, remote_host, user, tunnel_dir), wait=FALSE) + ##wait for tunnel to connect Sys.sleep(wait.time) - - if(file.exists(sshPassFile)){ + + if (file.exists(sshPassFile)) { file.remove(sshPassFile) PEcAn.logger::logger.error("Tunnel open failed") return(FALSE) - } - - if(file.exists(sshPID)){ - pid <- readLines(sshPID,n = -1) + } + + if (file.exists(sshPID)) { + pid <- readLines(sshPID, n = -1) return(as.numeric(pid)) } else { return(TRUE) } - + } diff --git a/base/remote/R/qsub_get_jobid.R b/base/remote/R/qsub_get_jobid.R new file mode 100644 index 00000000000..44096889269 --- /dev/null +++ b/base/remote/R/qsub_get_jobid.R @@ -0,0 +1,24 @@ +#' Get Job ID from qsub output +#' +#' @inheritParams check_model_run +#' @inheritParams start.model.runs +#' @param qsub.jobid (character) Regular expression string for extracting job ID from qsub output. +#' Usually from `settings$host$qsub.jobid` +#' +#' @return +#' @export +qsub_get_jobid <- function(out, qsub.jobid, stop.on.error) { + qsub_worked <- grepl(qsub.jobid, out) + if (!qsub_worked) { + msg <- paste0("Job ID not assigned by qsub. The following qsub output may be relevant:\n", out) + if (stop.on.error) { + PEcAn.logger::logger.severe(msg) + } else { + PEcAn.logger::logger.error(msg) + } + jobid <- NA + } else { + jobid <- sub(qsub.jobid, '\\1', out) + } + return(jobid) +} \ No newline at end of file diff --git a/base/remote/R/remote.copy.from.R b/base/remote/R/remote.copy.from.R new file mode 100644 index 00000000000..5fda749feec --- /dev/null +++ b/base/remote/R/remote.copy.from.R @@ -0,0 +1,48 @@ +#' Copy file/dir from remote server to local server +#' +#' Copies the file/dir from the remote server to the local server. If the dst +#' is a folder it will copy the file into that folder. +#' +#' @title Copy file from remote to local +#' @param host list with server, user and optionally tunnel to use. +#' @param src remote file/dir to copy +#' @param dst local file/dir to copy to +#' @param delete in case of local dir should all non-existent files be removed +#' @param stderr should stderr be returned +#' @return output of command executed +#' +#' @author Rob Kooper +#' @export +#' @examples +#' \dontrun{ +#' host <- list(name='geo.bu.edu', user='kooper', tunnel='/tmp/geo.tunnel') +#' remote.copy.from(host, '/tmp/kooper', '/tmp/geo.tmp', delete=TRUE) +#' } +remote.copy.from <- function(host, src, dst, delete = FALSE, stderr = FALSE) { + args <- c("-az", "-q") + if (as.logical(delete)) { + args <- c(args, "--delete") + } + if (is.localhost(host)) { + args <- c(args, src, dst) + } else { + tunnel <- host$tunnel + if(!is.null(host$data_tunnel)) tunnel <- host$data_tunnel + hostname <- host$name + if(!is.null(host$data_hostname)) hostname <- host$data_hostname + if (!is.null(tunnel)) { + if (!file.exists(tunnel)) { + PEcAn.logger::logger.severe("Could not find tunnel", tunnel) + } + args <- c(args, "-e", paste0("ssh -o ControlPath=\"", tunnel, "\"", + collapse = "")) + args <- c(args, paste0(hostname, ":", src), dst) + } else if (!is.null(host$user)) { + args <- c(args, paste0(host$user, "@", hostname, ":", src), dst) + } else { + args <- c(args, paste0(hostname, ":", src), dst) + } + } + PEcAn.logger::logger.debug("rsync", shQuote(args)) + system2("rsync", shQuote(args), stdout = TRUE, stderr = as.logical(stderr)) +} # remote.copy.from diff --git a/base/remote/R/remote.copy.to.R b/base/remote/R/remote.copy.to.R new file mode 100644 index 00000000000..e307c3a362f --- /dev/null +++ b/base/remote/R/remote.copy.to.R @@ -0,0 +1,50 @@ +#' Copy file/dir to remote server from local server +#' +#' Copies the file/dir to the remote server from the local server. If the dst +#' is a folder it will copy the file into that folder. +#' +#' @inheritParams remote.execute.cmd +#' @param src local file/dir to copy +#' @param dst remote file/dir to copy to +#' @param delete in case of local dir should all non-existent files be removed +#' @return output of command executed +#' +#' @author Rob Kooper +#' @export +#' @examples +#' \dontrun{ +#' host <- list(name='geo.bu.edu', user='kooper', tunnel='/tmp/geo.tunnel') +#' remote.copy.to(host, '/tmp/kooper', '/tmp/kooper', delete=TRUE) +#' } +remote.copy.to <- function(host, src, dst, delete = FALSE, stderr = FALSE) { + args <- c("-a", "-q") + if (as.logical(delete)) { + args <- c(args, "--delete") + } + if (is.localhost(host)) { + args <- c(args, src, dst) + } else { + tunnel <- host$tunnel + if (!is.null(host$data_tunnel)) { + tunnel <- host$data_tunnel + } + hostname <- host$name + if (!is.null(host$data_hostname)) { + hostname <- host$data_hostname + } + if (!is.null(tunnel)) { + if (!file.exists(tunnel)) { + PEcAn.logger::logger.severe("Could not find tunnel", tunnel) + } + args <- c(args, "-e", paste0("ssh -o ControlPath=\"", tunnel, "\"", + collapse = "")) + args <- c(args, src, paste0(hostname, ":", dst)) + } else if (!is.null(host$user)) { + args <- c(args, src, paste0(host$user, "@", hostname, ":", dst)) + } else { + args <- c(args, src, paste0(hostname, ":", dst)) + } + } + PEcAn.logger::logger.debug("rsync", shQuote(args)) + system2("rsync", shQuote(args), stdout = TRUE, stderr = as.logical(stderr)) +} # remote.copy.to diff --git a/base/remote/R/remote.copy.update.R b/base/remote/R/remote.copy.update.R new file mode 100644 index 00000000000..d11149be0e5 --- /dev/null +++ b/base/remote/R/remote.copy.update.R @@ -0,0 +1,41 @@ +#' Copy to remote and update DB +#' @param input_id +#' @param remote_dir remote folder path +#' @param remote_file_name remote file name, no need to provide if it's the same as local +#' @param host as in settings$host +#' @param con +#' @param stderr should stderr be returned +#' @return remote_id remote dbfile record +#' +#' @author Istem Fer +#' @export +remote.copy.update <- function(input_id, remote_dir, remote_file_name = NULL, host, con){ + + remote.execute.cmd(host, "mkdir", c("-p", remote_dir)) + + local_file_record <- db.query(paste("SELECT * from dbfiles where container_id =", input_id), con) + + if(is.null(remote_file_name)){ + local_file_name <- local_file_record$file_name + if(length(local_file_name) > 1){ + PEcAn.logger::logger.warn(paste0("Multiple file names found in the DB and no remote file name provided. Using the first file name for remote file name: ", + local_file_record$file_name[1])) + local_file_name <- local_file_record$file_name[1] + } + remote_file_name <- local_file_name + } + + local_file_path <- file.path(local_file_record$file_path, local_file_record$file_name) + remote_file_path <- file.path(remote_dir, remote_file_name) + + remote.copy.to(host, local_file_path, remote_file_path) + + # update DB record + remote_id <- dbfile.insert(in.path = remote_dir, in.prefix = remote_file_name, + type = local_file_record$container_type, id = local_file_record$container_id, + con = con, hostname = host$name) + + + return(remote_id) + +} # remote.copy.update diff --git a/base/remote/R/remote.execute.R.R b/base/remote/R/remote.execute.R.R new file mode 100644 index 00000000000..8174ba5d1ff --- /dev/null +++ b/base/remote/R/remote.execute.R.R @@ -0,0 +1,47 @@ +#' Remotely execute R code +#' +#' Runs an unevaluated R expression remotely. Wrap R code in `quote({...})` to generate an unevaluated expression. +#' Wrapped code should contain a `dput()` statement, or a warning will be thrown. +#' `dput()` is used to return outputs, so if it is absent, the output will be ` +#' +#' @author Alexey Shiklomanov +#' @param code Unevaluated R expression containing code to be run on remote. To generate, use the `quote()` function. +#' @inheritParams remote.execute.cmd +#' @param ... Additional arguments passed to [remote.execute.cmd()]. +#' +#' @return Exactly the output of `code`, or `NULL` if no `dput()` statement can be found in the wrapped code. +#' @export +#' +#' @examples +#' host <- list(name = "localhost") +#' code <- quote({ +#' x <- 5 +#' y <- 10 +#' out <- list(xx = seq_len(x), yy = seq_len(y) * 2) +#' dput(out) +#' }) +#' result <- remote.execute.R2(code = code, host = host) +remote.execute.R <- function(code, host, stderr = TRUE, ...) { + if (!typeof(code) == "language") { + stop("Code must be an R expression, for instance a block of code wrappen in the `quote()` function.") + } + code_string <- deparse(code) + has_dput <- any(grepl("dput", code_string)) + if (!has_dput) { + PEcAn.logger::logger.error("No dput statement found in code string.", + "This means no values will be returned.") + } + code_string_c <- paste(code_string, collapse = ';') + cmd <- "Rscript" + args <- c("-e", shQuote(code_string_c)) + result <- remote.execute.cmd(host = host, cmd = cmd, args = args, stderr = stderr, ...) + if (!has_dput) { + PEcAn.logger::logger.debug("Command ran successfuly, but no values returned because `dput` was not found.", + "Returning NULL.") + return(NULL) + } else { + parsed <- parse(text = result) + evalled <- eval(parsed) + return(evalled) + } +} # remote.execute.R \ No newline at end of file diff --git a/base/remote/R/remote.execute.cmd.R b/base/remote/R/remote.execute.cmd.R new file mode 100644 index 00000000000..8361e04ee0b --- /dev/null +++ b/base/remote/R/remote.execute.cmd.R @@ -0,0 +1,41 @@ +#' Execute command remotely +#' +#' Executes the given command on the remote host using ssh. If the user is set +#' the system will login as the given user. If the host given is the local +#' machine it will execute the command locally without ssh. +#' +#' @title Execute command remotely +#' @param command the system command to be invoked, as a character string. +#' @param host host structure to execute command on +#' @param args a character vector of arguments to command. +#' @param stderr should stderr be returned as well. +#' @return the captured output of the command (both stdout and stderr) +#' @author Rob Kooper +#' @export +#' @examples +#' \dontrun{ +#' host <- list(name='geo.bu.edu', user='kooper', tunnel='/tmp/geo.tunnel') +#' print(remote.execute.cmd(host, 'ls', c('-l', '/'), stderr=TRUE)) +#' } +remote.execute.cmd <- function(host, cmd, args = character(), stderr = FALSE) { + if (is.character(host)) { + host <- list(name = host) + } + + if ((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) { + PEcAn.logger::logger.debug(paste(cmd, args)) + system2(cmd, args, stdout = TRUE, stderr = as.logical(stderr)) + } else { + remote <- host$name + if (!is.null(host$tunnel)) { + if (!file.exists(host$tunnel)) { + PEcAn.logger::logger.severe("Could not find tunnel", host$tunnel) + } + remote <- c("-o", paste0("ControlPath=\"", host$tunnel, "\""), remote) + } else if (!is.null(host$user)) { + remote <- c("-l", host$user, remote) + } + PEcAn.logger::logger.debug(paste(c("ssh", "-T", remote, cmd, args), collapse = " ")) + system2("ssh", c("-T", remote, cmd, args), stdout = TRUE, stderr = as.logical(stderr)) + } +} # remote.execute.cmd diff --git a/base/remote/R/setup_modellauncher.R b/base/remote/R/setup_modellauncher.R new file mode 100644 index 00000000000..5e90877dd01 --- /dev/null +++ b/base/remote/R/setup_modellauncher.R @@ -0,0 +1,19 @@ +#' Setup model launcher script and job list +#' +#' @inheritParams start_qsub +#' @param mpirun MPI info, usually from `settings$host$modellauncher$mpirun` +#' @param binary Binary info, usually from `settings$host$modellauncher$binary` +#' +#' @return +#' @export +setup_modellauncher <- function(run, rundir, host_rundir, mpirun, binary) { + run_string <- format(run, scientific = FALSE) + run_id_dir <- file.path(rundir, run_string) + launcherfile <- file.path(run_id_dir, "launcher.sh") + file.remove(file.path(run_id_dir, "joblist.txt")) + jobfile <- file(file.path(run_id_dir, "joblist.txt"), "w") + + writeLines(c("#!/bin/bash", paste(mpirun, binary, file.path(host_rundir, run_string, "joblist.txt"))), + con = launcherfile) + writeLines("./job.sh", con = jobfile) +} \ No newline at end of file diff --git a/base/remote/R/stamp.R b/base/remote/R/stamp.R new file mode 100644 index 00000000000..b34c1047a94 --- /dev/null +++ b/base/remote/R/stamp.R @@ -0,0 +1,26 @@ +#' Stamp start and stop times of runs +#' +#' @param con BETY database connection +#' @param run (numeric) run ID +#' +#' @return `NULL` +#' @export +stamp_started <- function(con, run) { + if (!is.null(con)) { + run_id_string <- format(run, scientific = TRUE) + db.query(paste("UPDATE runs SET started_at = NOW() WHERE id = ", run_id_string)) + } else { + PEcAn.logger::logger.debug("Connection is null. Not actually writing timestamps to database") + } +} + +#' @rdname stamp_started +#' @export +stamp_finished <- function(con, run) { + if (!is.null(con)) { + run_id_string <- format(run, scientific = TRUE) + db.query(paste("UPDATE runs SET finished_at = NOW() WHERE id = ", run_id_string)) + } else { + PEcAn.logger::logger.debug("Connection is null. Not actually writing timestamps to database") + } +} \ No newline at end of file diff --git a/base/remote/R/start.model.runs.R b/base/remote/R/start.model.runs.R new file mode 100644 index 00000000000..87cd9b93f06 --- /dev/null +++ b/base/remote/R/start.model.runs.R @@ -0,0 +1,206 @@ +##------------------------------------------------------------------------------- +## Copyright (c) 2012 University of Illinois, NCSA. All rights reserved. This +## program and the accompanying materials are made available under the terms of +## the University of Illinois/NCSA Open Source License which accompanies this +## distribution, and is available at +## http://opensource.ncsa.illinois.edu/license.html +##------------------------------------------------------------------------------- + + +##' Start selected ecosystem model runs within PEcAn workflow +##' +##' @param settings pecan settings object +##' @param write (logical) Whether or not to write to the database. Default TRUE. +##' @param stop.on.error Throw error if _any_ of the runs fails. Default TRUE. +##' @export start.model.runs +##' @examples +##' \dontrun{ +##' start.model.runs(settings) +##' } +##' @author Shawn Serbin, Rob Kooper, David LeBauer +##' +start.model.runs <- function(settings, write = TRUE, stop.on.error = TRUE) { + + run_file <- file.path(settings$rundir, "runs.txt") + # check if runs need to be done + if (!file.exists(file.path(settings$rundir, "runs.txt"))) { + PEcAn.logger::logger.warn("runs.txt not found, assuming no runs need to be done") + return() + } + run_list <- readLines(con = run_file) + nruns <- length(run_list) + if (nruns == 0) { + PEcAn.logger::logger.warn("runs.txt found, but is empty. Assuming no runs need to be done") + return() + } + + model <- settings$model$type + PEcAn.logger::logger.info("-------------------------------------------------------------------") + PEcAn.logger::logger.info(paste(" Starting model runs", model)) + PEcAn.logger::logger.info("-------------------------------------------------------------------") + + is_local <- is.localhost(settings$host) + is_qsub <- !is.null(settings$host$qsub) + is_modellauncher <- !is.null(settings$host$modellauncher) + + # loop through runs and either call start run, or launch job on remote machine + jobids <- list() + + ## setup progressbar + pb <- txtProgressBar(min = 0, max = nruns, style = 3) + pbi <- 0 + + # create database connection + if (write) { + dbcon <- db.open(settings$database$bety) + on.exit(db.close(dbcon)) + } else { + dbcon <- NULL + } + + # launcher folder + jobfile <- NULL + firstrun <- NULL + + # launch each of the jobs + for (run in run_list) { + run_id_string <- format(run, scientific = FALSE) + # write start time to database + stamp_started(con = dbcon, run = run) + + # if running on a remote cluster, create folders and copy any data to remote host + if (!is_local) { + remote.execute.cmd(settings$host, "mkdir", c("-p", file.path(settings$host$outdir, run_id_string))) + remote.copy.to(settings$host, file.path(settings$rundir, run_id_string), settings$host$rundir, delete = TRUE) + } + + # check to see if we use the model launcer + if (is_modellauncher) { + # set up launcher script if we use modellauncher + if (is.null(firstrun)) { + firstrun <- run + setup_modellauncher(run = run, rundir = settings$rundir, host_rundir = settings$host$rundir, + mpirun = settings$host$modellauncher$mpirun, binary = settings$host$modellauncher$binary) + } + writeLines(c(file.path(settings$host$rundir, run_id_string)), con = jobfile) + pbi <- pbi + 1 + + } else { + if (is_qsub) { + out <- start_qsub(run = run, qsub_string = settings$host$qsub, rundir = settings$rundir, + host = settings$host, host_rundir = settings$host$rundir, host_outdir = settings$host$outdir, + stdout_log = "stdout.log", stderr_log = "stderr.log", job_script = "job.sh") + PEcAn.logger::logger.debug("JOB.SH submit status:", out) + jobids[run] <- qsub_get_jobid(out = out, qsub.jobid = settings$host$qsub.jobid, stop.on.error = stop.on.error) + + } else { + # if qsub option is not invoked. just start model runs in serial. + out <- start_serial(host = settings$host, rundir = settings$rundir, host_rundir = settings$host$rundir, job_script = "job.sh") + + # check output to see if an error occurred during the model run + check_model_run(out = out, stop.on.error = stop.on.error) + + if (!is_local) { + # copy data back to local + remote.copy.from(settings$host, file.path(settings$host$outdir, run_id_string), settings$modeloutdir) + } + + # write finished time to database + stamp_finished(con = dbcon, run = run) + + pbi <- pbi + 1 + setTxtProgressBar(pb, pbi) + } + } + } # end loop over runs + close(pb) + + if (is_modellauncher) { + close(jobfile) + + if (!is_local) { + # copy launcher and joblist + remote.copy.to(settings$host, file.path(settings$rundir, + format(firstrun, scientific = FALSE)), settings$host$rundir, delete = TRUE) + } + + if (is_qsub) { + out <- start_qsub(run = firstrun, qsub_string = settings$host$qsub, rundir = settings$rundir, + host = settings$host, host_rundir = settings$host$rundir, host_outdir = settings$host$outdir, + stdout_log = "launcher.out.log", stderr_log = "launcher.err.log", job_script = "launcher.sh", + qsub_extra = settings$host$modellauncher$qsub) + + # HACK: Code below gets 'run' from names(jobids) so need an entry for each run. + # But when using modellauncher all runs have the same jobid + for (run in run_list) { + jobids[run] <- sub(settings$host$qsub.jobid, "\\1", out) + } + } else { + out <- start_serial(host = settings$host, rundir = settings$rundir, host_rundir = settings$host$rundir, + job_script = "launcher.sh") + + # check output to see if an error occurred during the model run + check_model_run(out = out, stop.on.error = TRUE) + + # write finished time to database + for (run in run_list) { + stamp_finished(con = dbcon, run = run) + } + + setTxtProgressBar(pb, pbi) + } + } + + # wait for all qsub jobs to finish + if (length(jobids) > 0) { + PEcAn.logger::logger.debug("Waiting for the following jobs:", unlist(jobids, use.names = FALSE)) + } + + while (length(jobids) > 0) { + Sys.sleep(10) + for (run in names(jobids)) { + run_id_string <- format(run, scientific = FALSE) + # check to see if job is done + job_finished <- qsub_run_finished(run = jobids[run], host = settings$host, qstat = settings$host$qstat) + + if (job_finished) { + jobids[run] <- NULL + + # Copy data back to local + if (!is_local) { + remote.copy.from(host = settings$host, + src = file.path(settings$host$outdir, run_id_string), + dst = settings$modeloutdir) + } + + # TODO check output log + + # Write finish time to database + if (is_modellauncher) { + for (run in run_list) { + stamp_finished(con = dbcon, run = run) + } + } else { + stamp_finished(con = dbcon, run = run) + } + + if (!is_modellauncher) { + pbi <- pbi + 1 + } + setTxtProgressBar(pb, pb1) + } # End check if job finished + } # end loop over runs + } # end while loop checking runs + +} # start.model.runs + + +##' @export +runModule.start.model.runs <- function(settings,stop.on.error=TRUE) { + if (is.MultiSettings(settings) || is.Settings(settings)) { + write <- settings$database$bety$write + return(start.model.runs(settings, write,stop.on.error)) + } else { + PEcAn.logger::logger.severe("runModule.start.model.runs only works with Settings or MultiSettings") + } +} # runModule.start.model.runs diff --git a/base/remote/R/start_qsub.R b/base/remote/R/start_qsub.R new file mode 100644 index 00000000000..01a38599086 --- /dev/null +++ b/base/remote/R/start_qsub.R @@ -0,0 +1,41 @@ +#' Start qsub runs +#' +#' @param run (numeric) run ID, as an integer +#' @param qsub_string qsub command string, with arguments. Usually from `settings$host$qsub` +#' @param rundir Local run directory. Usually from `settings$rundir` +#' @param host Remote host, as a list or character. Usually from `settings$host`. +#' @param host_rundir Remote host run directory. Usually from `settings$host$rundir` +#' @param host_outdir Remote host output directory. Usually from `settings$host$outdir` +#' @param stdout_log Logfile for redirecting `stdout`. +#' @param stderr_log Logfile for redirecting `stderr` +#' @param job_script Base name (no path) of script to run. Usually either `job.sh` or `launcher.sh`. +#' @param qsub_extra Extra `qsub` arguments. Usually from `settings$host$modellauncher$qsub.extra` +#' +#' @return Output of qsub command, as a character. This output can be parsed for ascertaining submission success. +#' @export +start_qsub <- function(run, qsub_string, rundir, + host, host_rundir, host_outdir, + stdout_log, stderr_log, job_script, qsub_extra = NULL) { + run_id_string <- format(run, scientific = FALSE) + qsub <- gsub("@NAME@", paste0("PEcAn-", run_id_string), qsub_string) + qsub <- gsub("@STDOUT@", file.path(outdir, run_id_string, stdout_log), qsub) + qsub <- gsub("@STDERR@", file.path(outdir, run_id_string, stderr_log), qsub) + if (!is.null(qsub_extra)) { + qsub <- paste(qsub, qsub_extra) + } + # NOTE: This converts `qsub` to a list. + qsub <- strsplit(qsub, " (?=([^\"']*\"[^\"']*\")*[^\"']*$)", perl = TRUE) + + # start the actual model run + cmd <- qsub[[1]] + args <- qsub[-1] + PEcAn.logger::logger.debug(cmd, args) + if (is.localhost(host)) { + out <- system2(cmd, c(args, file.path(rundir, run_id_string, job_script)), stdout = TRUE, stderr = TRUE) + PEcAn.logger::logger.debug("Running locally:", run_id_string) + } else { + out <- remote.execute.cmd(host, cmd, c(args, file.path(host_rundir, run_id_string, job_script)), stderr = TRUE) + PEcAn.logger::logger.debug("Running on remote", host, ":", run_id_string) + } + return(out) +} diff --git a/base/remote/R/start_serial.R b/base/remote/R/start_serial.R new file mode 100644 index 00000000000..6d54c1c35e5 --- /dev/null +++ b/base/remote/R/start_serial.R @@ -0,0 +1,14 @@ +#' Start model execution in serial mode +#' +#' @inheritParams start_qsub +#' +#' @return +#' @export +start_serial <- function(host, rundir, host_rundir, job_script) { + run_id_string <- format(run, scientific = FALSE) + if (is.localhost(host)) { + out <- system2(file.path(rundir, run_id_string, job_script), stdout = TRUE, stderr = TRUE) + } else { + out <- remote.execute.cmd(host, file.path(host_rundir, run_id_string, job_script), stderr = TRUE) + } +} \ No newline at end of file diff --git a/base/remote/R/test_remote.R b/base/remote/R/test_remote.R new file mode 100644 index 00000000000..863451bf976 --- /dev/null +++ b/base/remote/R/test_remote.R @@ -0,0 +1,42 @@ +#' Test remote execution +#' +#' @inheritParams remote.execute.cmd +#' +#' @return `TRUE` is remote execution is successful. +#' If unsuccessful, depends on the value of `stderr`. +#' If `stderr` = TRUE (default), this function will throw an error. +#' If `stderr` = FALSE, this function will print a logger error and return FALSE. +#' @export +#' +#' @examples +#' # Localhost execution should always work +#' good_host <- list(name = "localhost") +#' test_remote(good_host) +#' +#' bad_host <- list(name = "bigbadwolf") +#' if (!test_remote(bad_host, stderr = FALSE)) { +#' print("Big Bad Wolf is a bad host.") +#' } +test_remote <- function(host, stderr = TRUE, ...) { + dots <- list(...) + cmd <- "echo" + test_string <- paste("Testing remote", host$name) + if (!is.null(dots$args)) { + args <- c(test_string, dots$args) + } else { + args <- test_string + } + out <- remote.execute.cmd(host, cmd, args = args, stderr = stderr) + + if (length(out) > 0 && out == test_string) { + return(TRUE) + } else { + msg <- paste("Error in remote execution. Here is the remote output:\n", paste(out, collapse = '\n')) + if (stderr) { + PEcAn.logger::logger.severe(msg) + } else { + PEcAn.logger::logger.error(msg) + return(FALSE) + } + } +} diff --git a/base/remote/man/check_model_run.Rd b/base/remote/man/check_model_run.Rd new file mode 100644 index 00000000000..3049fe18265 --- /dev/null +++ b/base/remote/man/check_model_run.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/check_model_run.R +\name{check_model_run} +\alias{check_model_run} +\title{Check if model run was successful} +\usage{ +check_model_run(out, stop.on.error = TRUE) +} +\arguments{ +\item{out}{Output from model execution, as a character.} + +\item{stop.on.error}{Throw error if \emph{any} of the runs fails. Default TRUE.} +} +\description{ +Check if model run was successful +} diff --git a/base/remote/man/hello.Rd b/base/remote/man/hello.Rd new file mode 100644 index 00000000000..0fa7c4b8817 --- /dev/null +++ b/base/remote/man/hello.Rd @@ -0,0 +1,12 @@ +\name{hello} +\alias{hello} +\title{Hello, World!} +\usage{ +hello() +} +\description{ +Prints 'Hello, world!'. +} +\examples{ +hello() +} diff --git a/base/utils/man/is.localhost.Rd b/base/remote/man/is.localhost.Rd similarity index 91% rename from base/utils/man/is.localhost.Rd rename to base/remote/man/is.localhost.Rd index a6f31495386..4472a8b0b8f 100644 --- a/base/utils/man/is.localhost.Rd +++ b/base/remote/man/is.localhost.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/remote.R +% Please edit documentation in R/is.localhost.R \name{is.localhost} \alias{is.localhost} \title{Check if local host} diff --git a/base/utils/man/kill.tunnel.Rd b/base/remote/man/kill.tunnel.Rd similarity index 100% rename from base/utils/man/kill.tunnel.Rd rename to base/remote/man/kill.tunnel.Rd diff --git a/base/utils/man/open_tunnel.Rd b/base/remote/man/open_tunnel.Rd similarity index 71% rename from base/utils/man/open_tunnel.Rd rename to base/remote/man/open_tunnel.Rd index afbf44c8297..b76a626a832 100644 --- a/base/utils/man/open_tunnel.Rd +++ b/base/remote/man/open_tunnel.Rd @@ -2,10 +2,11 @@ % Please edit documentation in R/open.tunnel.R \name{open_tunnel} \alias{open_tunnel} -\title{Title} +\title{Open an SSH tunnel} \usage{ open_tunnel(remote_host, user = NULL, password = NULL, - tunnel_dir = "~/.pecan/tunnel/", wait.time = 15) + tunnel_dir = "~/.pecan/tunnel/", wait.time = 15, + tunnel_script = "~/pecan/web/sshtunnel.sh") } \arguments{ \item{remote_host}{name of remote server to connect to (e.g. geo.bu.edu)} @@ -17,7 +18,9 @@ open_tunnel(remote_host, user = NULL, password = NULL, \item{tunnel_dir}{directory to store tunnel file in, typically from settings$host} \item{wait.time}{how long to give system to connect before deleting password (seconds)} + +\item{tunnel_script}{Path to sshtunnel.sh script file for opening tunnel} } \description{ -Title +Open an SSH tunnel } diff --git a/base/remote/man/qsub_get_jobid.Rd b/base/remote/man/qsub_get_jobid.Rd new file mode 100644 index 00000000000..c52325a2c13 --- /dev/null +++ b/base/remote/man/qsub_get_jobid.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/qsub_get_jobid.R +\name{qsub_get_jobid} +\alias{qsub_get_jobid} +\title{Get Job ID from qsub output} +\usage{ +qsub_get_jobid(out, qsub.jobid, stop.on.error) +} +\arguments{ +\item{out}{Output from model execution, as a character.} + +\item{qsub.jobid}{(character) Regular expression string for extracting job ID from qsub output. +Usually from \code{settings$host$qsub.jobid}} + +\item{stop.on.error}{Throw error if \emph{any} of the runs fails. Default TRUE.} +} +\description{ +Get Job ID from qsub output +} diff --git a/base/remote/man/qsub_run_finished.Rd b/base/remote/man/qsub_run_finished.Rd new file mode 100644 index 00000000000..a7db5352e35 --- /dev/null +++ b/base/remote/man/qsub_run_finished.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/check_qsub_status.R +\name{qsub_run_finished} +\alias{qsub_run_finished} +\title{Check if qsub run finished} +\usage{ +qsub_run_finished(run, host, qstat) +} +\arguments{ +\item{run}{run ID, as an integer} + +\item{host}{host structure to execute command on} + +\item{qstat}{(string) qstat command for checking job status} +} +\value{ +\code{TRUE} if run is marked as DONE, otherwise FALSE. +} +\description{ +Check if qsub run finished +} diff --git a/base/utils/man/remote.copy.from.Rd b/base/remote/man/remote.copy.from.Rd similarity index 94% rename from base/utils/man/remote.copy.from.Rd rename to base/remote/man/remote.copy.from.Rd index a570b8488c0..2e0ec3b367a 100644 --- a/base/utils/man/remote.copy.from.Rd +++ b/base/remote/man/remote.copy.from.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/remote.R +% Please edit documentation in R/remote.copy.from.R \name{remote.copy.from} \alias{remote.copy.from} \title{Copy file from remote to local} diff --git a/base/utils/man/remote.copy.to.Rd b/base/remote/man/remote.copy.to.Rd similarity index 73% rename from base/utils/man/remote.copy.to.Rd rename to base/remote/man/remote.copy.to.Rd index 590dab1e50a..fe759aa61fe 100644 --- a/base/utils/man/remote.copy.to.Rd +++ b/base/remote/man/remote.copy.to.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/remote.R +% Please edit documentation in R/remote.copy.to.R \name{remote.copy.to} \alias{remote.copy.to} -\title{Copy file from remote to local} +\title{Copy file/dir to remote server from local server} \usage{ remote.copy.to(host, src, dst, delete = FALSE, stderr = FALSE) } \arguments{ -\item{host}{list with server, user and optionally tunnel to use.} +\item{host}{host structure to execute command on} \item{src}{local file/dir to copy} @@ -15,15 +15,12 @@ remote.copy.to(host, src, dst, delete = FALSE, stderr = FALSE) \item{delete}{in case of local dir should all non-existent files be removed} -\item{stderr}{should stderr be returned} +\item{stderr}{should stderr be returned as well.} } \value{ output of command executed } \description{ -Copy file/dir to remote server from local server -} -\details{ Copies the file/dir to the remote server from the local server. If the dst is a folder it will copy the file into that folder. } diff --git a/base/utils/man/remote.copy.update.Rd b/base/remote/man/remote.copy.update.Rd similarity index 91% rename from base/utils/man/remote.copy.update.Rd rename to base/remote/man/remote.copy.update.Rd index b163c3f1ba9..b84a64c4eab 100644 --- a/base/utils/man/remote.copy.update.Rd +++ b/base/remote/man/remote.copy.update.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/remote.R +% Please edit documentation in R/remote.copy.update.R \name{remote.copy.update} \alias{remote.copy.update} \title{Copy to remote and update DB} diff --git a/base/remote/man/remote.execute.R.Rd b/base/remote/man/remote.execute.R.Rd new file mode 100644 index 00000000000..a16d6aaf19c --- /dev/null +++ b/base/remote/man/remote.execute.R.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/remote.execute.R.R +\name{remote.execute.R} +\alias{remote.execute.R} +\title{Remotely execute R code} +\usage{ +remote.execute.R(code, host, stderr = TRUE, ...) +} +\arguments{ +\item{code}{Unevaluated R expression containing code to be run on remote. To generate, use the \code{quote()} function.} + +\item{host}{host structure to execute command on} + +\item{stderr}{should stderr be returned as well.} + +\item{...}{Additional arguments passed to \code{\link[=remote.execute.cmd]{remote.execute.cmd()}}.} +} +\value{ +Exactly the output of \code{code}, or \code{NULL} if no \code{dput()} statement can be found in the wrapped code. +} +\description{ +Runs an unevaluated R expression remotely. Wrap R code in \code{quote({...})} to generate an unevaluated expression. +Wrapped code should contain a \code{dput()} statement, or a warning will be thrown. +\code{dput()} is used to return outputs, so if it is absent, the output will be ` +} +\examples{ +host <- list(name = "localhost") +code <- quote({ + x <- 5 + y <- 10 + out <- list(xx = seq_len(x), yy = seq_len(y) * 2) + dput(out) +}) +result <- remote.execute.R2(code = code, host = host) +} +\author{ +Alexey Shiklomanov +} diff --git a/base/utils/man/remote.execute.cmd.Rd b/base/remote/man/remote.execute.cmd.Rd similarity index 88% rename from base/utils/man/remote.execute.cmd.Rd rename to base/remote/man/remote.execute.cmd.Rd index 0c6ec714488..c45d7974587 100644 --- a/base/utils/man/remote.execute.cmd.Rd +++ b/base/remote/man/remote.execute.cmd.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/remote.R +% Please edit documentation in R/remote.execute.cmd.R \name{remote.execute.cmd} \alias{remote.execute.cmd} \title{Execute command remotely} @@ -29,7 +29,7 @@ machine it will execute the command locally without ssh. \examples{ \dontrun{ host <- list(name='geo.bu.edu', user='kooper', tunnel='/tmp/geo.tunnel') - pritn(remote.execute.cmd(host, 'ls', c('-l', '/'), stderr=TRUE)) + print(remote.execute.cmd(host, 'ls', c('-l', '/'), stderr=TRUE)) } } \author{ diff --git a/base/remote/man/setup_modellauncher.Rd b/base/remote/man/setup_modellauncher.Rd new file mode 100644 index 00000000000..f0cda52ba96 --- /dev/null +++ b/base/remote/man/setup_modellauncher.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/setup_modellauncher.R +\name{setup_modellauncher} +\alias{setup_modellauncher} +\title{Setup model launcher script and job list} +\usage{ +setup_modellauncher(run, rundir, host_rundir, mpirun, binary) +} +\arguments{ +\item{run}{(numeric) run ID, as an integer} + +\item{rundir}{Local run directory. Usually from \code{settings$rundir}} + +\item{host_rundir}{Remote host run directory. Usually from \code{settings$host$rundir}} + +\item{mpirun}{MPI info, usually from \code{settings$host$modellauncher$mpirun}} + +\item{binary}{Binary info, usually from \code{settings$host$modellauncher$binary}} +} +\description{ +Setup model launcher script and job list +} diff --git a/base/remote/man/stamp_started.Rd b/base/remote/man/stamp_started.Rd new file mode 100644 index 00000000000..534593823cc --- /dev/null +++ b/base/remote/man/stamp_started.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/stamp.R +\name{stamp_started} +\alias{stamp_started} +\alias{stamp_finished} +\title{Stamp start and stop times of runs} +\usage{ +stamp_started(con, run) + +stamp_finished(con, run) +} +\arguments{ +\item{con}{BETY database connection} + +\item{run}{(numeric) run ID} +} +\value{ +\code{NULL} +} +\description{ +Stamp start and stop times of runs +} diff --git a/base/utils/man/start.model.runs.Rd b/base/remote/man/start.model.runs.Rd similarity index 57% rename from base/utils/man/start.model.runs.Rd rename to base/remote/man/start.model.runs.Rd index 88c81ffcf5f..a1ac44558a1 100644 --- a/base/utils/man/start.model.runs.Rd +++ b/base/remote/man/start.model.runs.Rd @@ -2,23 +2,23 @@ % Please edit documentation in R/start.model.runs.R \name{start.model.runs} \alias{start.model.runs} -\title{Start ecosystem model runs} +\title{Start selected ecosystem model runs within PEcAn workflow} \usage{ \method{start}{model.runs}(settings, write = TRUE, stop.on.error = TRUE) } \arguments{ -\item{settings}{input pecan settings file} +\item{settings}{pecan settings object} -\item{write}{TRUE/FALSE. Default TRUE} +\item{write}{(logical) Whether or not to write to the database. Default TRUE.} -\item{stop.on.error}{TRUE/FALSE. Default TRUE} +\item{stop.on.error}{Throw error if \emph{any} of the runs fails. Default TRUE.} } \description{ Start selected ecosystem model runs within PEcAn workflow } \examples{ \dontrun{ -start.model.runs(settings) + start.model.runs(settings) } } \author{ diff --git a/base/remote/man/start_qsub.Rd b/base/remote/man/start_qsub.Rd new file mode 100644 index 00000000000..e5bb651e883 --- /dev/null +++ b/base/remote/man/start_qsub.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/start_qsub.R +\name{start_qsub} +\alias{start_qsub} +\title{Start qsub runs} +\usage{ +start_qsub(run, qsub_string, rundir, host, host_rundir, host_outdir, stdout_log, + stderr_log, job_script, qsub_extra = NULL) +} +\arguments{ +\item{run}{(numeric) run ID, as an integer} + +\item{qsub_string}{qsub command string, with arguments. Usually from \code{settings$host$qsub}} + +\item{rundir}{Local run directory. Usually from \code{settings$rundir}} + +\item{host}{Remote host, as a list or character. Usually from \code{settings$host}.} + +\item{host_rundir}{Remote host run directory. Usually from \code{settings$host$rundir}} + +\item{host_outdir}{Remote host output directory. Usually from \code{settings$host$outdir}} + +\item{stdout_log}{Logfile for redirecting \code{stdout}.} + +\item{stderr_log}{Logfile for redirecting \code{stderr}} + +\item{job_script}{Base name (no path) of script to run. Usually either \code{job.sh} or \code{launcher.sh}.} + +\item{qsub_extra}{Extra \code{qsub} arguments. Usually from \code{settings$host$modellauncher$qsub.extra}} +} +\value{ +Output of qsub command, as a character. This output can be parsed for ascertaining submission success. +} +\description{ +Start qsub runs +} diff --git a/base/remote/man/start_serial.Rd b/base/remote/man/start_serial.Rd new file mode 100644 index 00000000000..e2d065ab059 --- /dev/null +++ b/base/remote/man/start_serial.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/start_serial.R +\name{start_serial} +\alias{start_serial} +\title{Start model execution in serial mode} +\usage{ +start_serial(host, rundir, host_rundir, job_script) +} +\arguments{ +\item{host}{Remote host, as a list or character. Usually from \code{settings$host}.} + +\item{rundir}{Local run directory. Usually from \code{settings$rundir}} + +\item{host_rundir}{Remote host run directory. Usually from \code{settings$host$rundir}} + +\item{job_script}{Base name (no path) of script to run. Usually either \code{job.sh} or \code{launcher.sh}.} +} +\description{ +Start model execution in serial mode +} diff --git a/base/remote/man/test_remote.Rd b/base/remote/man/test_remote.Rd new file mode 100644 index 00000000000..2b7319665da --- /dev/null +++ b/base/remote/man/test_remote.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/test_remote.R +\name{test_remote} +\alias{test_remote} +\title{Test remote execution} +\usage{ +test_remote(host, stderr = TRUE, ...) +} +\arguments{ +\item{host}{host structure to execute command on} + +\item{stderr}{should stderr be returned as well.} +} +\value{ +\code{TRUE} is remote execution is successful. +If unsuccessful, depends on the value of \code{stderr}. +If \code{stderr} = TRUE (default), this function will throw an error. +If \code{stderr} = FALSE, this function will print a logger error and return FALSE. +} +\description{ +Test remote execution +} +\examples{ +# Localhost execution should always work +good_host <- list(name = "localhost") +test_remote(good_host) + +bad_host <- list(name = "bigbadwolf") +if (!test_remote(bad_host, stderr = FALSE)) { + print("Big Bad Wolf is a bad host.") +} +} diff --git a/base/remote/tests/testthat.R b/base/remote/tests/testthat.R new file mode 100644 index 00000000000..70fc27e668b --- /dev/null +++ b/base/remote/tests/testthat.R @@ -0,0 +1,4 @@ +library(PEcAn.remote) +library(testthat) + +test_check("PEcAn.remote") \ No newline at end of file diff --git a/base/utils/tests/testthat/test.localhost.R b/base/remote/tests/testthat/test.localhost.R similarity index 100% rename from base/utils/tests/testthat/test.localhost.R rename to base/remote/tests/testthat/test.localhost.R diff --git a/base/remote/tests/testthat/test.remote.R b/base/remote/tests/testthat/test.remote.R new file mode 100644 index 00000000000..cb06459fa65 --- /dev/null +++ b/base/remote/tests/testthat/test.remote.R @@ -0,0 +1,29 @@ +# Quick test of remote functions +library(PEcAn.remote) +library(testthat) + +good_host <- list(name = "localhost") +bad_host <- list(name = 'bigbadwolf') +test_that("test_remote identifies good and bad hosts", { + expect_true(test_remote(good_host)) + expect_error(test_remote(bad_host)) + expect_false(test_remote(bad_host, stderr = FALSE)) +}) + +echo_string <- "Hello!" +out <- remote.execute.cmd(host = good_host, cmd = "echo", args = echo_string) + +test_that("Basic remote execution works as expected", { + expect_identical(out, echo_string) +}) + +code <- quote({ + x <- 10 + result <- seq_len(x) + dput(result) +}) + +out2 <- remote.execute.R(code = code, host = good_host) +test_that("Remote execution of R code works", { + expect_identical(out2, seq_len(10)) +}) diff --git a/base/utils/NAMESPACE b/base/utils/NAMESPACE index cde2e4dd9ad..80b1da1b671 100644 --- a/base/utils/NAMESPACE +++ b/base/utils/NAMESPACE @@ -33,8 +33,6 @@ export(get.run.id) export(get.sa.sample.list) export(get.sa.samples) export(is.SafeList) -export(is.localhost) -export(kill.tunnel) export(left.pad.zeros) export(listToArgString) export(listToXml) @@ -55,28 +53,20 @@ export(misc.convert) export(model2netcdf) export(mstmipvar) export(n_leap_day) -export(open_tunnel) export(paste.stats) export(plot_data) export(r2bugs.distributions) export(read.ensemble.output) export(read.output) export(read.sa.output) -export(remote.copy.from) -export(remote.copy.to) -export(remote.copy.update) -export(remote.execute.R) -export(remote.execute.cmd) export(rsync) export(run.write.configs) export(runModule.get.results) export(runModule.run.write.configs) -export(runModule.start.model.runs) export(seconds_in_year) export(sendmail) export(sensitivity.filename) export(ssh) -export(start.model.runs) export(status.check) export(status.end) export(status.skip) diff --git a/base/utils/R/remote.R b/base/utils/R/remote.R deleted file mode 100644 index 6b17bc3a048..00000000000 --- a/base/utils/R/remote.R +++ /dev/null @@ -1,312 +0,0 @@ -#------------------------------------------------------------------------------- -# Copyright (c) 2012 University of Illinois, NCSA. -# All rights reserved. This program and the accompanying materials -# are made available under the terms of the -# University of Illinois/NCSA Open Source License -# which accompanies this distribution, and is available at -# http://opensource.ncsa.illinois.edu/license.html -#------------------------------------------------------------------------------- - -#------------------------------------------------------------------------------- -# Remote utilities. Allows for the following functionality -# - execute system call on remote machine -# - execute R call on remote machine, returns result -# - copy files to/from remote machines -#------------------------------------------------------------------------------- - -#' Execute command remotely -#' -#' Executes the given command on the remote host using ssh. If the user is set -#' the system will login as the given user. If the host given is the local -#' machine it will execute the command locally without ssh. -#' -#' @title Execute command remotely -#' @param command the system command to be invoked, as a character string. -#' @param host host structure to execute command on -#' @param args a character vector of arguments to command. -#' @param stderr should stderr be returned as well. -#' @return the captured output of the command (both stdout and stderr) -#' @author Rob Kooper -#' @export -#' @examples -#' \dontrun{ -#' host <- list(name='geo.bu.edu', user='kooper', tunnel='/tmp/geo.tunnel') -#' pritn(remote.execute.cmd(host, 'ls', c('-l', '/'), stderr=TRUE)) -#' } -remote.execute.cmd <- function(host, cmd, args = character(), stderr = FALSE) { - if (is.character(host)) { - host <- list(name = host) - } - - if ((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) { - PEcAn.logger::logger.debug(paste(cmd, args)) - system2(cmd, args, stdout = TRUE, stderr = as.logical(stderr)) - } else { - remote <- c(host$name) - if (!is.null(host$tunnel)) { - if (!file.exists(host$tunnel)) { - PEcAn.logger::logger.severe("Could not find tunnel", host$tunnel) - } - remote <- c("-o", paste0("ControlPath=\"", host$tunnel, "\""), remote) - } else if (!is.null(host$user)) { - remote <- c("-l", host$user, remote) - } - PEcAn.logger::logger.debug(paste(c("ssh", "-T", remote, cmd, args), collapse = " ")) - system2("ssh", c("-T", remote, cmd, args), stdout = TRUE, stderr = as.logical(stderr)) - } -} # remote.execute.cmd - - -#' Copy file/dir from remote server to local server -#' -#' Copies the file/dir from the remote server to the local server. If the dst -#' is a folder it will copy the file into that folder. -#' -#' @title Copy file from remote to local -#' @param host list with server, user and optionally tunnel to use. -#' @param src remote file/dir to copy -#' @param dst local file/dir to copy to -#' @param delete in case of local dir should all non-existent files be removed -#' @param stderr should stderr be returned -#' @return output of command executed -#' -#' @author Rob Kooper -#' @export -#' @examples -#' \dontrun{ -#' host <- list(name='geo.bu.edu', user='kooper', tunnel='/tmp/geo.tunnel') -#' remote.copy.from(host, '/tmp/kooper', '/tmp/geo.tmp', delete=TRUE) -#' } -remote.copy.from <- function(host, src, dst, delete = FALSE, stderr = FALSE) { - args <- c("-az", "-q") - if (as.logical(delete)) { - args <- c(args, "--delete") - } - if (is.localhost(host)) { - args <- c(args, src, dst) - } else { - tunnel <- host$tunnel - if(!is.null(host$data_tunnel)) tunnel <- host$data_tunnel - hostname <- host$name - if(!is.null(host$data_hostname)) hostname <- host$data_hostname - if (!is.null(tunnel)) { - if (!file.exists(tunnel)) { - PEcAn.logger::logger.severe("Could not find tunnel", tunnel) - } - args <- c(args, "-e", paste0("ssh -o ControlPath=\"", tunnel, "\"", - collapse = "")) - args <- c(args, paste0(hostname, ":", src), dst) - } else if (!is.null(host$user)) { - args <- c(args, paste0(host$user, "@", hostname, ":", src), dst) - } else { - args <- c(args, paste0(hostname, ":", src), dst) - } - } - PEcAn.logger::logger.debug("rsync", shQuote(args)) - system2("rsync", shQuote(args), stdout = TRUE, stderr = as.logical(stderr)) -} # remote.copy.from - - -#' Copy file/dir to remote server from local server -#' -#' Copies the file/dir to the remote server from the local server. If the dst -#' is a folder it will copy the file into that folder. -#' -#' @title Copy file from remote to local -#' @param host list with server, user and optionally tunnel to use. -#' @param src local file/dir to copy -#' @param dst remote file/dir to copy to -#' @param delete in case of local dir should all non-existent files be removed -#' @param stderr should stderr be returned -#' @return output of command executed -#' -#' @author Rob Kooper -#' @export -#' @examples -#' \dontrun{ -#' host <- list(name='geo.bu.edu', user='kooper', tunnel='/tmp/geo.tunnel') -#' remote.copy.to(host, '/tmp/kooper', '/tmp/kooper', delete=TRUE) -#' } -remote.copy.to <- function(host, src, dst, delete = FALSE, stderr = FALSE) { - args <- c("-a", "-q") - if (as.logical(delete)) { - args <- c(args, "--delete") - } - if (is.localhost(host)) { - args <- c(args, src, dst) - } else { - tunnel <- host$tunnel - if(!is.null(host$data_tunnel)) tunnel <- host$data_tunnel - hostname <- host$name - if(!is.null(host$data_hostname)) hostname <- host$data_hostname - if (!is.null(tunnel)) { - if (!file.exists(tunnel)) { - PEcAn.logger::logger.severe("Could not find tunnel", tunnel) - } - args <- c(args, "-e", paste0("ssh -o ControlPath=\"", tunnel, "\"", - collapse = "")) - args <- c(args, src, paste0(hostname, ":", dst)) - } else if (!is.null(host$user)) { - args <- c(args, src, paste0(host$user, "@", hostname, ":", dst)) - } else { - args <- c(args, src, paste0(hostname, ":", dst)) - } - } - PEcAn.logger::logger.debug("rsync", shQuote(args)) - system2("rsync", shQuote(args), stdout = TRUE, stderr = as.logical(stderr)) -} # remote.copy.to - - -#' Check if host is local -#' -#' Given the hostname is this the localhost. This returns true if either -#' the value is localhost, or the value is the same as the fqdn. -#' -#' @title Check if local host -#' @param host the hostname to be checked -#' @return true if the host is the local host name -#' @author Rob Kooper -#' @export -#' @examples -#' is.localhost(fqdn()) -is.localhost <- function(host) { - if (is.character(host)) { - return((host == "localhost") || (host == PEcAn.utils::fqdn())) - } else if (is.list(host)) { - return((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) - } else { - return(FALSE) - } -} # is.localhost - -# host <- list(name='geo.bu.edu', user='kooper', tunnel='/tmp/geo.tunnel') -# out <- remote.copy.to(host, '/tmp/kooper/', '/tmp/kooper/', delete=TRUE, stderr=TRUE) -# print(out) - - -#' Execute command remotely -#' -#' Executes the given command on the remote host using ssh. If the user is set -#' the system will login as the given user. If the host given is the local -#' machine it will execute the command locally without ssh. -#' -#' @title Execute command remotely -#' @param script the script to be invoked, as a list of commands. -#' @param args a character vector of arguments to command. -#' @param host settings host list -#' @param user the username to use for remote login -#' @param verbose should the output be printed to the console -#' @return the captured output of the command (both stdout and stderr) -#' @author Rob Kooper -#' @export -#' @examples -#' \dontrun{ -#' remote.execute.R('list.files()', host='localhost', verbose=FALSE) -#' } -remote.execute.R <- function(script, host = "localhost", user = NA, verbose = FALSE, - R = "R",scratchdir = "/tmp") { - if (is.character(host)) { - host <- list(name = host) - } - uuid <- paste0("pecan-", paste(sample(c(letters[1:6], 0:9), 30, replace = TRUE), - collapse = "")) - tmpfile <- file.path(scratchdir, uuid) - input <- c(paste0("remotefunc <- function() {", script, "}"), - "remoteout <- remotefunc()", - "print(remoteout)", - paste0("fp <- file('", tmpfile, "', 'w')"), - paste0("ign <- serialize(remoteout, fp)"), - "close(fp)") - verbose <- ifelse(as.logical(verbose), "", FALSE) - if ((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) { - if (R == "R") { - Rbinary <- file.path(Sys.getenv("R_HOME"), "bin", "R") - if (file.exists(Rbinary)) { - R <- Rbinary - } - } - result <- try(system2(R, "--no-save","--no-restore", stdout = verbose, stderr = verbose, - input = input)) - print(result) - if (!file.exists(tmpfile)) { - fp <- file(tmpfile, "w") - serialize(result, fp) - close(fp) - } - ## get result - fp <- file(tmpfile, "r") - result <- unserialize(fp) - close(fp) - file.remove(tmpfile) - return(invisible(result)) - - } else { - remote <- c(host$name) - if (!is.null(host$tunnel)) { - if (!file.exists(host$tunnel)) { - PEcAn.logger::logger.severe("Could not find tunnel", host$tunnel) - } - remote <- c("-o", paste0("ControlPath=\"", host$tunnel, "\""), remote) - } else if (!is.null(host$user)) { - remote <- c("-l", host$user, remote) - } - PEcAn.logger::logger.debug(paste(c("ssh", "-T", remote, R), collapse = " ")) - result <- system2("ssh", c("-T", remote, R, "--no-save","--no-restore"), stdout = verbose, - stderr = verbose, input = input) - remote.copy.from(host, tmpfile, uuid) - remote.execute.cmd(host, "rm", c("-f", tmpfile)) - # load result - fp <- file(uuid, "r") - result <- unserialize(fp) - close(fp) - file.remove(uuid) - return(invisible(result)) - } - - -} # remote.execute.R - -# remote.execute.cmd <- function(host, cmd, args=character(), stderr=FALSE) { - - -#' Copy to remote and update DB -#' @param input_id -#' @param remote_dir remote folder path -#' @param remote_file_name remote file name, no need to provide if it's the same as local -#' @param host as in settings$host -#' @param con -#' @param stderr should stderr be returned -#' @return remote_id remote dbfile record -#' -#' @author Istem Fer -#' @export -remote.copy.update <- function(input_id, remote_dir, remote_file_name = NULL, host, con){ - - remote.execute.cmd(host, "mkdir", c("-p", remote_dir)) - - local_file_record <- db.query(paste("SELECT * from dbfiles where container_id =", input_id), con) - - if(is.null(remote_file_name)){ - local_file_name <- local_file_record$file_name - if(length(local_file_name) > 1){ - PEcAn.logger::logger.warn(paste0("Multiple file names found in the DB and no remote file name provided. Using the first file name for remote file name: ", - local_file_record$file_name[1])) - local_file_name <- local_file_record$file_name[1] - } - remote_file_name <- local_file_name - } - - local_file_path <- file.path(local_file_record$file_path, local_file_record$file_name) - remote_file_path <- file.path(remote_dir, remote_file_name) - - remote.copy.to(host, local_file_path, remote_file_path) - - # update DB record - remote_id <- dbfile.insert(in.path = remote_dir, in.prefix = remote_file_name, - type = local_file_record$container_type, id = local_file_record$container_id, - con = con, hostname = host$name) - - - return(remote_id) - -} # remote.copy.update diff --git a/base/utils/R/start.model.runs.R b/base/utils/R/start.model.runs.R deleted file mode 100644 index 56eff754f52..00000000000 --- a/base/utils/R/start.model.runs.R +++ /dev/null @@ -1,306 +0,0 @@ -##------------------------------------------------------------------------------- -## Copyright (c) 2012 University of Illinois, NCSA. All rights reserved. This -## program and the accompanying materials are made available under the terms of -## the University of Illinois/NCSA Open Source License which accompanies this -## distribution, and is available at -## http://opensource.ncsa.illinois.edu/license.html -##------------------------------------------------------------------------------- - - -##' -##' Start selected ecosystem model runs within PEcAn workflow -##' -##' @name start.model.runs -##' @title Start ecosystem model runs -##' @param settings input pecan settings file -##' @param write TRUE/FALSE. Default TRUE -##' @param stop.on.error TRUE/FALSE. Default TRUE -##' @export start.model.runs -##' @examples -##' \dontrun{ -##' start.model.runs(settings) -##' } -##' @author Shawn Serbin, Rob Kooper, David LeBauer -##' -start.model.runs <- function(settings, write = TRUE, stop.on.error=TRUE) { - - # check if runs need to be done - if(!file.exists(file.path(settings$rundir, "runs.txt"))){ - PEcAn.logger::logger.warn("runs.txt not found, assuming no runs need to be done") - return() - } - - - model <- settings$model$type - PEcAn.logger::logger.info("-------------------------------------------------------------------") - PEcAn.logger::logger.info(paste(" Starting model runs", model)) - PEcAn.logger::logger.info("-------------------------------------------------------------------") - - # loop through runs and either call start run, or launch job on remote machine - jobids <- list() - - ## setup progressbar - nruns <- length(readLines(con = file.path(settings$rundir, "runs.txt"))) - pb <- txtProgressBar(min = 0, max = nruns, style = 3) - pbi <- 0 - - # create database connection - if (write) { - dbcon <- db.open(settings$database$bety) - on.exit(db.close(dbcon)) - } else { - dbcon <- NULL - } - - # launcher folder - launcherfile <- NULL - jobfile <- NULL - firstrun <- NULL - - # launch each of the jobs - for (run in readLines(con = file.path(settings$rundir, "runs.txt"))) { - # write start time to database - if (!is.null(dbcon)) { - db.query(paste("UPDATE runs SET started_at = NOW() WHERE id = ", - format(run, scientific = FALSE)), con = dbcon) - } - - # if running on a remote cluster, create folders and copy any data to remote host - if (!is.localhost(settings$host)) { - remote.execute.cmd(settings$host, "mkdir", c("-p", file.path(settings$host$outdir, - format(run, scientific = FALSE)))) - remote.copy.to(settings$host, file.path(settings$rundir, format(run, - scientific = FALSE)), settings$host$rundir, delete = TRUE) - } - - # check to see if we use the model launcer - if (!is.null(settings$host$modellauncher)) { - pbi <- pbi + 1 - - # set up launcher script if we use modellauncher - if (is.null(firstrun)) { - firstrun <- run - launcherfile <- file.path(settings$rundir, - format(run, scientific = FALSE), - "launcher.sh") - unlink(file.path(settings$rundir, - format(run, scientific = FALSE), - "joblist.txt")) - jobfile <- file(file.path(settings$rundir, - format(run, scientific = FALSE), - "joblist.txt"), "w") - - writeLines(c("#!/bin/bash", paste(settings$host$modellauncher$mpirun, - settings$host$modellauncher$binary, - file.path(settings$host$rundir, format(run, scientific = FALSE), - "joblist.txt"))), con = launcherfile) - writeLines(c("./job.sh"), con = jobfile) - } - writeLines(c(file.path(settings$host$rundir, format(run, scientific = FALSE))), - con = jobfile) - - } else { - # if qsub is requested - if (!is.null(settings$host$qsub)) { - qsub <- gsub("@NAME@", paste0("PEcAn-", format(run, scientific = FALSE)), settings$host$qsub) - qsub <- gsub("@STDOUT@", file.path(settings$host$outdir, - format(run, scientific = FALSE), "stdout.log"), qsub) - qsub <- gsub("@STDERR@", file.path(settings$host$outdir, - format(run, scientific = FALSE), "stderr.log"), qsub) - qsub <- strsplit(qsub, " (?=([^\"']*\"[^\"']*\")*[^\"']*$)", perl = TRUE) - - # start the actual model run - cmd <- qsub[[1]] - args <- qsub[-1] - PEcAn.logger::logger.debug(cmd,args) - if (is.localhost(settings$host)) { - out <- system2(cmd, c(args, file.path(settings$rundir, format(run, - scientific = FALSE), "job.sh")), stdout = TRUE, stderr = TRUE) - } else { - out <- remote.execute.cmd(settings$host, cmd, c(args, file.path(settings$host$rundir, - format(run, scientific = FALSE), "job.sh")), stderr = TRUE) - PEcAn.logger::logger.debug(settings$host,format(run, scientific = FALSE)) - - } - PEcAn.logger::logger.debug("JOB.SH submit status:", out) - qsub_worked <- grepl(settings$host$qsub.jobid, out) - if (!qsub_worked) { - PEcAn.logger::logger.severe("Job ID not assigned by qsub. The following qsub output may be relevant:\n", out) - } - jobids[run] <- sub(settings$host$qsub.jobid, "\\1", out) - - # if qsub option is not invoked. just start model runs in serial. - } else { - if (is.localhost(settings$host)) { - out <- system2(file.path(settings$rundir, format(run, scientific = FALSE), - "job.sh"), stdout = TRUE, stderr = TRUE) - } else { - out <- remote.execute.cmd(settings$host, file.path(settings$host$rundir, - format(run, scientific = FALSE), "job.sh"), stderr = TRUE) - } - - # check output to see if an error occurred during the model run - if ("ERROR IN MODEL RUN" %in% out) { - if(stop.on.error){ - PEcAn.logger::logger.severe("Model run aborted, with error.\n", out) - } else { - PEcAn.logger::logger.error("Model run aborted, with error.\n",out) - } - } - - # copy data back to local - if (!is.localhost(settings$host)) { - remote.copy.from(settings$host, file.path(settings$host$outdir, - format(run, scientific = FALSE)), settings$modeloutdir) - } - - # write finished time to database - if (!is.null(dbcon)) { - db.query(paste("UPDATE runs SET finished_at = NOW() WHERE id = ", - format(run, scientific = FALSE)), con = dbcon) - } - - # update progress bar - pbi <- pbi + 1 - setTxtProgressBar(pb, pbi) - } - } - } - close(pb) - - # if using the model launcer - if (!is.null(settings$host$modellauncher)) { - close(jobfile) - - # copy launcer and joblist - if (!is.localhost(settings$host)) { - remote.copy.to(settings$host, file.path(settings$rundir, - format(firstrun, scientific = FALSE)), settings$host$rundir, delete = TRUE) - } - - # if qsub is requested - if (!is.null(settings$host$qsub)) { - qsub <- gsub("@NAME@", "PEcAn-all", settings$host$qsub) - qsub <- gsub("@STDOUT@", file.path(settings$host$outdir, - format(firstrun, scientific = FALSE), "launcher.out.log"), qsub) - qsub <- gsub("@STDERR@", file.path(settings$host$outdir, - format(firstrun, scientific = FALSE), "launcher.err.log"), qsub) - qsub <- strsplit(paste(qsub, settings$host$modellauncher$qsub.extra), - " (?=([^\"']*\"[^\"']*\")*[^\"']*$)", perl = TRUE) - - # start the actual model run - if (is.localhost(settings$host)) { - cmd <- qsub[[1]] - qsub <- qsub[-1] - out <- system2(cmd, c(qsub, file.path(settings$rundir, - format(run, scientific = FALSE), "launcher.sh"), recursive = TRUE), stdout = TRUE) - } else { - out <- system2("ssh", c(settings$host$name, qsub, - file.path(settings$host$rundir, format(firstrun, scientific = FALSE), "launcher.sh"), recursive = TRUE), - stdout = TRUE) - } - # print(out) # <-- for debugging - - # HACK: Code below gets 'run' from names(jobids) so need an entry for each run. - # But when using modellauncher all runs have the same jobid - for (run in readLines(con = file.path(settings$rundir, "runs.txt"))) { - jobids[run] <- sub(settings$host$qsub.jobid, "\\1", out) - } - } else { - if (is.localhost(settings$host)) { - out <- system2(file.path(settings$rundir, format(firstrun, scientific = FALSE), - "launcher.sh"), stdout = TRUE) - } else { - out <- system2("ssh", c(settings$host$name, file.path(settings$host$rundir, - format(firstrun, scientific = FALSE), - "launcher.sh")), stdout = TRUE) - } - - # check output to see if an error occurred during the model run - if ("ERROR IN MODEL RUN" %in% out) { - PEcAn.logger::logger.severe("Model run aborted, with error.\n", out) - } - - # write finished time to database - if (!is.null(dbcon)) { - for (run in readLines(con = file.path(settings$rundir, "runs.txt"))) { - db.query(paste("UPDATE runs SET finished_at = NOW() WHERE id = ", - format(run, scientific = FALSE)), con = dbcon) - } - } - - # update progress bar - setTxtProgressBar(pb, pbi) - } - } - - # wait for all qsub jobs to finish - if (length(jobids) > 0) { - PEcAn.logger::logger.debug("Waiting for the following jobs:", unlist(jobids, use.names = FALSE)) - while (length(jobids) > 0) { - Sys.sleep(10) - for (run in names(jobids)) { - # check to see if job is done - check <- gsub("@JOBID@", jobids[run], settings$host$qstat) - args <- strsplit(check, " (?=([^\"']*\"[^\"']*\")*[^\"']*$)", perl = TRUE) - if (is.localhost(settings$host)) { - # cmd <- args[[1]] args <- args[-1] out <- system2(cmd, args, stdout=TRUE) - out <- system(check, - intern = TRUE, - ignore.stdout = FALSE, - ignore.stderr = FALSE, - wait = TRUE) - } else { - out <- remote.execute.cmd(settings$host, check, stderr = TRUE) - } - - if ((length(out) > 0) && (substring(out, nchar(out) - 3) == "DONE")) - { - PEcAn.logger::logger.debug("Job", jobids[run], "for run", format(run, scientific = FALSE), - "finished") - jobids[run] <- NULL - - # copy data back to local - if (!is.localhost(settings$host)) { - remote.copy.from(settings$host, file.path(settings$host$outdir, - format(run, scientific = FALSE)), settings$modeloutdir) - } - - # TODO check output log - - # write finish time to database - if (!is.null(dbcon)) - { - if (!is.null(settings$host$modellauncher)) { - for (run in readLines(con = file.path(settings$rundir, "runs.txt"))) { - db.query(paste("UPDATE runs SET finished_at = NOW() WHERE id = ", - format(run, scientific = FALSE)), con = dbcon) - } - } else { - db.query(paste("UPDATE runs SET finished_at = NOW() WHERE id = ", - format(run, scientific = FALSE)), con = dbcon) - } - } # end writing to database - - # update progress bar - if (is.null(settings$host$modellauncher)) { - pbi <- pbi + 1 - } - setTxtProgressBar(pb, pbi) - } # end job done if loop - } # end for loop - } # end while loop - } - -} # start.model.runs - - -##' @export -runModule.start.model.runs <- function(settings,stop.on.error=TRUE) { - if (is.MultiSettings(settings) || is.Settings(settings)) { - write <- settings$database$bety$write - return(start.model.runs(settings, write,stop.on.error)) - } else { - stop("runModule.start.model.runs only works with Settings or MultiSettings") - } -} # runModule.start.model.runs diff --git a/base/utils/man/remote.execute.R.Rd b/base/utils/man/remote.execute.R.Rd deleted file mode 100644 index 5a1239f6f6b..00000000000 --- a/base/utils/man/remote.execute.R.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/remote.R -\name{remote.execute.R} -\alias{remote.execute.R} -\title{Execute command remotely} -\usage{ -remote.execute.R(script, host = "localhost", user = NA, verbose = FALSE, - R = "R", scratchdir = "/tmp") -} -\arguments{ -\item{script}{the script to be invoked, as a list of commands.} - -\item{host}{settings host list} - -\item{user}{the username to use for remote login} - -\item{verbose}{should the output be printed to the console} - -\item{args}{a character vector of arguments to command.} -} -\value{ -the captured output of the command (both stdout and stderr) -} -\description{ -Execute command remotely -} -\details{ -Executes the given command on the remote host using ssh. If the user is set -the system will login as the given user. If the host given is the local -machine it will execute the command locally without ssh. -} -\examples{ -\dontrun{ - remote.execute.R('list.files()', host='localhost', verbose=FALSE) -} -} -\author{ -Rob Kooper -} From dbf75653f7070ddf86c31779f8e993140c457ccd Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Wed, 13 Sep 2017 13:16:53 -0400 Subject: [PATCH 601/771] roxygen soil2netcdf --- modules/data.land/NAMESPACE | 1 + modules/data.land/man/soil.units.Rd | 2 +- modules/data.land/man/soil2netcdf.Rd | 38 ++++++++++++++++++++++++++++ 3 files changed, 40 insertions(+), 1 deletion(-) create mode 100644 modules/data.land/man/soil2netcdf.Rd diff --git a/modules/data.land/NAMESPACE b/modules/data.land/NAMESPACE index fec745a1e27..647eb45c0d6 100644 --- a/modules/data.land/NAMESPACE +++ b/modules/data.land/NAMESPACE @@ -35,6 +35,7 @@ export(prepare_pools) export(sclass) export(shp2kml) export(soil.units) +export(soil2netcdf) export(soil_params) export(soil_process) export(subset.layer) diff --git a/modules/data.land/man/soil.units.Rd b/modules/data.land/man/soil.units.Rd index 541096173d5..c582332cbe8 100644 --- a/modules/data.land/man/soil.units.Rd +++ b/modules/data.land/man/soil.units.Rd @@ -4,7 +4,7 @@ \alias{soil.units} \title{Get standard units for a soil variable} \usage{ -soil.units(varname) +soil.units(varname = NA) } \arguments{ \item{varname}{} diff --git a/modules/data.land/man/soil2netcdf.Rd b/modules/data.land/man/soil2netcdf.Rd new file mode 100644 index 00000000000..48935a9cb07 --- /dev/null +++ b/modules/data.land/man/soil2netcdf.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/soil2netcdf.R +\name{soil2netcdf} +\alias{soil2netcdf} +\title{Save soil texture & parameters in PEcAn standard netCDF CF} +\usage{ +soil2netcdf(soil.data, new.file) +} +\arguments{ +\item{soil.data}{List of soil variables in standard names & units. Minimum is soil_depth and two of [sand, silt, clay]. Bulk density encouraged.} + +\item{new.file}{} +} +\value{ +none +} +\description{ +Save soil texture & parameters in PEcAn standard netCDF CF +} +\details{ +A table of standard names and units can be displayed by running soil.units() without any arguements + +soil_params is called internally to estimate additional soil physical parameters from sand/silt/clay & bulk density. Will not overwrite any provided values + +Need to expand to alternatively take soil_type (texture class) as an input + +On output, soil_type named class is converted to a number because netCDF is a pain for storing strings. +Conversion back can be done by load(system.file("data/soil_class.RData",package = "PEcAn.data.land")) and then soil.name[soil_n] +} +\examples{ +\dontrun{ +soil.data <- list(volume_fraction_of_sand_in_soil = c(0.3,0.4,0.5), + volume_fraction_of_clay_in_soil = c(0.3,0.3,0.3), + soil_depth = c(0.2,0.5,1.0)) + +soil2netcdf(soil.data,"soil.nc") +} +} From 6be8506f8bed12f7cfbad2a90e654c6d6c247088 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 13 Sep 2017 13:30:59 -0400 Subject: [PATCH 602/771] Try different order of nrow/ncol --- modules/data.remote/inst/modisWSDL.py | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index 84c66bcc6bb..b0033e62946 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -361,8 +361,8 @@ def m_data_to_netCDF(filename, m, k, kmLR, kmAB): year = startDate.year m_date.units = 'days since %d-01-01 00:00:00.0'%(year) - m_data = rootgrp.createVariable('LAI', 'f8', ('time', 'ncol', 'nrow')) - m_std = rootgrp.createVariable('LAIStd', 'f8', ('time', 'ncol', 'nrow')) + m_data = rootgrp.createVariable('LAI', 'f8', ('time', 'nrow', 'ncol')) + m_std = rootgrp.createVariable('LAIStd', 'f8', ('time', 'nrow', 'ncol')) str_dates = [str(d) for d in m.dateInt] datetimes = [(datetime.datetime.strptime(d, '%Y%j')- datetime.datetime(year,1,1)).days+1 for d in str_dates] From f57baedf810f686d3ec7141b05848537b49c8e5d Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Wed, 13 Sep 2017 14:00:59 -0400 Subject: [PATCH 603/771] Quick fix --- modules/data.atmosphere/R/download.CRUNCEP_Global.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/modules/data.atmosphere/R/download.CRUNCEP_Global.R b/modules/data.atmosphere/R/download.CRUNCEP_Global.R index 09ea13773ca..79abf585543 100644 --- a/modules/data.atmosphere/R/download.CRUNCEP_Global.R +++ b/modules/data.atmosphere/R/download.CRUNCEP_Global.R @@ -100,7 +100,7 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l # This throws an error if file not found #dap <- ncdf4::nc_open(dap_file, verbose=FALSE) - dap <- retry.func(ncdf4::nc_open(dap_file, verbose=verbose), maxErrors=maxErrors, sleep=sleep) + dap <- PEcAn.utils::retry.func(ncdf4::nc_open(dap_file, verbose=verbose), maxErrors=maxErrors, sleep=sleep) # confirm that timestamps match if (dap$dim$time$len != ntime) { @@ -116,16 +116,16 @@ download.CRUNCEP <- function(outfolder, start_date, end_date, site_id, lat.in, l } - dat.list[[j]] <- retry.func(ncdf4::ncvar_get(dap, + dat.list[[j]] <- PEcAn.utils::retry.func(ncdf4::ncvar_get(dap, as.character(var$DAP.name[j]), c(lon_grid, lat_grid, 1), c(1, 1, ntime)), maxErrors=maxErrors, sleep=sleep) - var.list[[j]] <- retry.func(ncdf4::ncvar_def(name = as.character(var$CF.name[j]), + var.list[[j]] <- ncdf4::ncvar_def(name = as.character(var$CF.name[j]), units = as.character(var$units[j]), dim = dim, missval = -999, - verbose = verbose), maxErrors=maxErrors, sleep=sleep) + verbose = verbose) ncdf4::nc_close(dap) } ## change units of precip to kg/m2/s instead of 6 hour accumulated precip From 49acd74d73ef8047ea9626b5df9f999a90a6f6ce Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 13 Sep 2017 15:32:08 -0400 Subject: [PATCH 604/771] Remote: Allow remote.execute.R to take strings Also, fix documentation. --- base/remote/R/check_model_run.R | 2 +- base/remote/R/open.tunnel.R | 4 +-- base/remote/R/qsub_get_jobid.R | 2 +- base/remote/R/remote.copy.update.R | 4 +-- base/remote/R/remote.execute.R.R | 32 ++++++++++++++++++------ base/remote/R/remote.execute.cmd.R | 2 +- base/remote/R/setup_modellauncher.R | 2 +- base/remote/R/start_serial.R | 3 ++- base/remote/man/check_model_run.Rd | 3 +++ base/remote/man/open_tunnel.Rd | 3 +++ base/remote/man/qsub_get_jobid.Rd | 3 +++ base/remote/man/remote.copy.update.Rd | 4 +++ base/remote/man/remote.execute.R.Rd | 20 ++++++++++++--- base/remote/man/start_serial.Rd | 3 +++ base/remote/tests/testthat/test.remote.R | 24 ++++++++++++------ 15 files changed, 82 insertions(+), 29 deletions(-) diff --git a/base/remote/R/check_model_run.R b/base/remote/R/check_model_run.R index e3fa735caa6..077efddd6f0 100644 --- a/base/remote/R/check_model_run.R +++ b/base/remote/R/check_model_run.R @@ -3,7 +3,7 @@ #' @param out Output from model execution, as a character. #' @inheritParams start.model.runs #' -#' @return +#' @return `NULL` #' @export check_model_run <- function(out, stop.on.error = TRUE) { if ("ERROR IN MODEL RUN" %in% out) { diff --git a/base/remote/R/open.tunnel.R b/base/remote/R/open.tunnel.R index b55c56675c3..4895671481b 100644 --- a/base/remote/R/open.tunnel.R +++ b/base/remote/R/open.tunnel.R @@ -7,10 +7,8 @@ #' @param wait.time how long to give system to connect before deleting password (seconds) #' @param tunnel_script Path to sshtunnel.sh script file for opening tunnel #' -#' @return +#' @return `TRUE` if successful, or `FALSE` otherwise #' @export -#' -#' @examples open_tunnel <- function(remote_host, user = NULL, password = NULL, tunnel_dir = "~/.pecan/tunnel/", wait.time = 15, tunnel_script = '~/pecan/web/sshtunnel.sh'){ diff --git a/base/remote/R/qsub_get_jobid.R b/base/remote/R/qsub_get_jobid.R index 44096889269..c1a4897b6b8 100644 --- a/base/remote/R/qsub_get_jobid.R +++ b/base/remote/R/qsub_get_jobid.R @@ -5,7 +5,7 @@ #' @param qsub.jobid (character) Regular expression string for extracting job ID from qsub output. #' Usually from `settings$host$qsub.jobid` #' -#' @return +#' @return Job ID, as a string #' @export qsub_get_jobid <- function(out, qsub.jobid, stop.on.error) { qsub_worked <- grepl(qsub.jobid, out) diff --git a/base/remote/R/remote.copy.update.R b/base/remote/R/remote.copy.update.R index d11149be0e5..79393b5641c 100644 --- a/base/remote/R/remote.copy.update.R +++ b/base/remote/R/remote.copy.update.R @@ -1,9 +1,9 @@ #' Copy to remote and update DB -#' @param input_id +#' @param input_id Input ID, as a numeric or character #' @param remote_dir remote folder path #' @param remote_file_name remote file name, no need to provide if it's the same as local #' @param host as in settings$host -#' @param con +#' @param con BETY database connection #' @param stderr should stderr be returned #' @return remote_id remote dbfile record #' diff --git a/base/remote/R/remote.execute.R.R b/base/remote/R/remote.execute.R.R index 8174ba5d1ff..976a4f19be6 100644 --- a/base/remote/R/remote.execute.R.R +++ b/base/remote/R/remote.execute.R.R @@ -1,11 +1,11 @@ #' Remotely execute R code #' -#' Runs an unevaluated R expression remotely. Wrap R code in `quote({...})` to generate an unevaluated expression. #' Wrapped code should contain a `dput()` statement, or a warning will be thrown. -#' `dput()` is used to return outputs, so if it is absent, the output will be ` +#' `dput()` is used to return outputs, so if it is absent, the output will be `NULL`. #' #' @author Alexey Shiklomanov -#' @param code Unevaluated R expression containing code to be run on remote. To generate, use the `quote()` function. +#' @param code R code to be run on remote, either as an unevaluated expression, +#' a single character string, or a vector of strings to be run in sequence. #' @inheritParams remote.execute.cmd #' @param ... Additional arguments passed to [remote.execute.cmd()]. #' @@ -20,18 +20,34 @@ #' out <- list(xx = seq_len(x), yy = seq_len(y) * 2) #' dput(out) #' }) -#' result <- remote.execute.R2(code = code, host = host) +#' result <- remote.execute.R(code = code, host = host) +#' +#' code2 <- c("x <- 10", "y <- 7", "out <- list(x = seq(x), y = seq(y))", "dput(out)") +#' result <- remote.execute.R(code = code2, host = host) +#' +#' code3 <- " +#' n <- 10 +#' x <- rnorm(n) +#' y <- runif(n) +#' df <- data.frame(norm = x, unif = y) +#' dput(df) +#' " +#' result <- remote.execute.R(code = code3, host = host) remote.execute.R <- function(code, host, stderr = TRUE, ...) { - if (!typeof(code) == "language") { - stop("Code must be an R expression, for instance a block of code wrappen in the `quote()` function.") + if (is.character(code)) { + code_string <- code + } else if (typeof(code) == "language") { + code_string <- deparse(code) + } else { + PEcAn.logger::logger.severe("Code must be an R quoted expression or a character string.") } - code_string <- deparse(code) has_dput <- any(grepl("dput", code_string)) if (!has_dput) { PEcAn.logger::logger.error("No dput statement found in code string.", "This means no values will be returned.") } - code_string_c <- paste(code_string, collapse = ';') + code_string_c <- gsub("\n", "; ", paste(code_string, collapse = '; ')) + code_string_c <- gsub("^; *", "", code_string_c) cmd <- "Rscript" args <- c("-e", shQuote(code_string_c)) result <- remote.execute.cmd(host = host, cmd = cmd, args = args, stderr = stderr, ...) diff --git a/base/remote/R/remote.execute.cmd.R b/base/remote/R/remote.execute.cmd.R index 8361e04ee0b..fbfa5c11630 100644 --- a/base/remote/R/remote.execute.cmd.R +++ b/base/remote/R/remote.execute.cmd.R @@ -23,7 +23,7 @@ remote.execute.cmd <- function(host, cmd, args = character(), stderr = FALSE) { } if ((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) { - PEcAn.logger::logger.debug(paste(cmd, args)) + PEcAn.logger::logger.debug(paste(c(cmd, args), collapse = ' ')) system2(cmd, args, stdout = TRUE, stderr = as.logical(stderr)) } else { remote <- host$name diff --git a/base/remote/R/setup_modellauncher.R b/base/remote/R/setup_modellauncher.R index 5e90877dd01..eb141fe0bed 100644 --- a/base/remote/R/setup_modellauncher.R +++ b/base/remote/R/setup_modellauncher.R @@ -4,7 +4,7 @@ #' @param mpirun MPI info, usually from `settings$host$modellauncher$mpirun` #' @param binary Binary info, usually from `settings$host$modellauncher$binary` #' -#' @return +#' @return NULL #' @export setup_modellauncher <- function(run, rundir, host_rundir, mpirun, binary) { run_string <- format(run, scientific = FALSE) diff --git a/base/remote/R/start_serial.R b/base/remote/R/start_serial.R index 6d54c1c35e5..a9ba42d1cc3 100644 --- a/base/remote/R/start_serial.R +++ b/base/remote/R/start_serial.R @@ -2,7 +2,7 @@ #' #' @inheritParams start_qsub #' -#' @return +#' @return Output of execution command, as a character (see [remote.execute.cmd()]). #' @export start_serial <- function(host, rundir, host_rundir, job_script) { run_id_string <- format(run, scientific = FALSE) @@ -11,4 +11,5 @@ start_serial <- function(host, rundir, host_rundir, job_script) { } else { out <- remote.execute.cmd(host, file.path(host_rundir, run_id_string, job_script), stderr = TRUE) } + return(out) } \ No newline at end of file diff --git a/base/remote/man/check_model_run.Rd b/base/remote/man/check_model_run.Rd index 3049fe18265..8ae60b37fc5 100644 --- a/base/remote/man/check_model_run.Rd +++ b/base/remote/man/check_model_run.Rd @@ -11,6 +11,9 @@ check_model_run(out, stop.on.error = TRUE) \item{stop.on.error}{Throw error if \emph{any} of the runs fails. Default TRUE.} } +\value{ +\code{NULL} +} \description{ Check if model run was successful } diff --git a/base/remote/man/open_tunnel.Rd b/base/remote/man/open_tunnel.Rd index b76a626a832..afcbf0ab13f 100644 --- a/base/remote/man/open_tunnel.Rd +++ b/base/remote/man/open_tunnel.Rd @@ -21,6 +21,9 @@ open_tunnel(remote_host, user = NULL, password = NULL, \item{tunnel_script}{Path to sshtunnel.sh script file for opening tunnel} } +\value{ +\code{TRUE} if successful, or \code{FALSE} otherwise +} \description{ Open an SSH tunnel } diff --git a/base/remote/man/qsub_get_jobid.Rd b/base/remote/man/qsub_get_jobid.Rd index c52325a2c13..706bccee555 100644 --- a/base/remote/man/qsub_get_jobid.Rd +++ b/base/remote/man/qsub_get_jobid.Rd @@ -14,6 +14,9 @@ Usually from \code{settings$host$qsub.jobid}} \item{stop.on.error}{Throw error if \emph{any} of the runs fails. Default TRUE.} } +\value{ +Job ID, as a string +} \description{ Get Job ID from qsub output } diff --git a/base/remote/man/remote.copy.update.Rd b/base/remote/man/remote.copy.update.Rd index b84a64c4eab..a41ea32a833 100644 --- a/base/remote/man/remote.copy.update.Rd +++ b/base/remote/man/remote.copy.update.Rd @@ -7,12 +7,16 @@ remote.copy.update(input_id, remote_dir, remote_file_name = NULL, host, con) } \arguments{ +\item{input_id}{Input ID, as a numeric or character} + \item{remote_dir}{remote folder path} \item{remote_file_name}{remote file name, no need to provide if it's the same as local} \item{host}{as in settings$host} +\item{con}{BETY database connection} + \item{stderr}{should stderr be returned} } \value{ diff --git a/base/remote/man/remote.execute.R.Rd b/base/remote/man/remote.execute.R.Rd index a16d6aaf19c..ee9d1501c57 100644 --- a/base/remote/man/remote.execute.R.Rd +++ b/base/remote/man/remote.execute.R.Rd @@ -7,7 +7,8 @@ remote.execute.R(code, host, stderr = TRUE, ...) } \arguments{ -\item{code}{Unevaluated R expression containing code to be run on remote. To generate, use the \code{quote()} function.} +\item{code}{R code to be run on remote, either as an unevaluated expression, +a single character string, or a vector of strings to be run in sequence.} \item{host}{host structure to execute command on} @@ -19,9 +20,8 @@ remote.execute.R(code, host, stderr = TRUE, ...) Exactly the output of \code{code}, or \code{NULL} if no \code{dput()} statement can be found in the wrapped code. } \description{ -Runs an unevaluated R expression remotely. Wrap R code in \code{quote({...})} to generate an unevaluated expression. Wrapped code should contain a \code{dput()} statement, or a warning will be thrown. -\code{dput()} is used to return outputs, so if it is absent, the output will be ` +\code{dput()} is used to return outputs, so if it is absent, the output will be \code{NULL}. } \examples{ host <- list(name = "localhost") @@ -31,7 +31,19 @@ code <- quote({ out <- list(xx = seq_len(x), yy = seq_len(y) * 2) dput(out) }) -result <- remote.execute.R2(code = code, host = host) +result <- remote.execute.R(code = code, host = host) + +code2 <- c("x <- 10", "y <- 7", "out <- list(x = seq(x), y = seq(y))", "dput(out)") +result <- remote.execute.R(code = code2, host = host) + +code3 <- " + n <- 10 + x <- rnorm(n) + y <- runif(n) + df <- data.frame(norm = x, unif = y) + dput(df) +" +result <- remote.execute.R(code = code3, host = host) } \author{ Alexey Shiklomanov diff --git a/base/remote/man/start_serial.Rd b/base/remote/man/start_serial.Rd index e2d065ab059..bcf0b54d6ef 100644 --- a/base/remote/man/start_serial.Rd +++ b/base/remote/man/start_serial.Rd @@ -15,6 +15,9 @@ start_serial(host, rundir, host_rundir, job_script) \item{job_script}{Base name (no path) of script to run. Usually either \code{job.sh} or \code{launcher.sh}.} } +\value{ +Output of execution command, as a character (see \code{\link[=remote.execute.cmd]{remote.execute.cmd()}}). +} \description{ Start model execution in serial mode } diff --git a/base/remote/tests/testthat/test.remote.R b/base/remote/tests/testthat/test.remote.R index cb06459fa65..9dcca333ec8 100644 --- a/base/remote/tests/testthat/test.remote.R +++ b/base/remote/tests/testthat/test.remote.R @@ -17,13 +17,23 @@ test_that("Basic remote execution works as expected", { expect_identical(out, echo_string) }) +host <- list(name = "localhost") code <- quote({ - x <- 10 - result <- seq_len(x) - dput(result) + x <- 5 + y <- 10 + out <- list(xx = seq_len(x), yy = seq_len(y) * 2) + dput(out) }) +result <- remote.execute.R(code = code, host = host) -out2 <- remote.execute.R(code = code, host = good_host) -test_that("Remote execution of R code works", { - expect_identical(out2, seq_len(10)) -}) +code2 <- c("x <- 10", "y <- 7", "out <- list(x = seq(x), y = seq(y))", "dput(out)") +result <- remote.execute.R(code = code2, host = host) + +code3 <- " + n <- 10 + x <- rnorm(n) + y <- runif(n) + df <- data.frame(norm = x, unif = y) + dput(df) +" +result <- remote.execute.R(code = code3, host = host) \ No newline at end of file From 049947b319449ac037100eb122a3f4072270ea75 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 13 Sep 2017 15:56:37 -0400 Subject: [PATCH 605/771] remote: Update DESCRIPTION, minor fixes --- base/remote/DESCRIPTION | 6 ++++++ base/remote/R/start.model.runs.R | 2 +- base/remote/man/start.model.runs.Rd | 2 +- base/remote/tests/testthat/test.localhost.R | 4 ++-- 4 files changed, 10 insertions(+), 4 deletions(-) diff --git a/base/remote/DESCRIPTION b/base/remote/DESCRIPTION index abb40fca92a..c585810b73d 100644 --- a/base/remote/DESCRIPTION +++ b/base/remote/DESCRIPTION @@ -6,6 +6,12 @@ Author: Alexey Shiklomanov, Rob Kooper, Shawn Serbin, David LeBauer Maintainer: Alexey Shiklomanov Description: This package contains utilities for communicating with and executing code on local and remote hosts. In particular, it has PEcAn-specific utilities for starting ecosystem model runs. +Imports: + PEcAn.utils, + PEcAn.logger +Suggests: + tools, + getPass License: FreeBSD + file LICENSE Encoding: UTF-8 LazyData: true diff --git a/base/remote/R/start.model.runs.R b/base/remote/R/start.model.runs.R index 87cd9b93f06..a0f9c742e2f 100644 --- a/base/remote/R/start.model.runs.R +++ b/base/remote/R/start.model.runs.R @@ -17,7 +17,7 @@ ##' \dontrun{ ##' start.model.runs(settings) ##' } -##' @author Shawn Serbin, Rob Kooper, David LeBauer +##' @author Shawn Serbin, Rob Kooper, David LeBauer, Alexey Shiklomanov ##' start.model.runs <- function(settings, write = TRUE, stop.on.error = TRUE) { diff --git a/base/remote/man/start.model.runs.Rd b/base/remote/man/start.model.runs.Rd index a1ac44558a1..85d06d5fbd9 100644 --- a/base/remote/man/start.model.runs.Rd +++ b/base/remote/man/start.model.runs.Rd @@ -22,5 +22,5 @@ Start selected ecosystem model runs within PEcAn workflow } } \author{ -Shawn Serbin, Rob Kooper, David LeBauer +Shawn Serbin, Rob Kooper, David LeBauer, Alexey Shiklomanov } diff --git a/base/remote/tests/testthat/test.localhost.R b/base/remote/tests/testthat/test.localhost.R index cd2e3dbb7a6..e9a21676b91 100644 --- a/base/remote/tests/testthat/test.localhost.R +++ b/base/remote/tests/testthat/test.localhost.R @@ -8,7 +8,7 @@ #------------------------------------------------------------------------------- test_that('is.localhost works', { expect_true(is.localhost("localhost")) - expect_true(is.localhost(fqdn())) - expect_true(is.localhost(list(name=fqdn()))) + expect_true(is.localhost(PEcAn.utils::fqdn())) + expect_true(is.localhost(list(name = PEcAn.utils::fqdn()))) expect_false(is.localhost("notarealmachine")) }) From f96b877ec739bb4689bedb5ae6ec29c2678c9326 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 13 Sep 2017 15:59:35 -0400 Subject: [PATCH 606/771] Update changelog, and add remote CLI documentation --- CHANGELOG.md | 7 +- .../Enabling-Remote-Execution.Rmd | 58 ----- .../adv_user_guide_cmd/Remote-execution.Rmd | 223 ++++++++++++++++++ 3 files changed, 227 insertions(+), 61 deletions(-) delete mode 100755 book_source/adv_user_guide_cmd/Enabling-Remote-Execution.Rmd create mode 100644 book_source/adv_user_guide_cmd/Remote-execution.Rmd diff --git a/CHANGELOG.md b/CHANGELOG.md index cf64ab1d119..6a06c86f7e1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,8 +22,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - SIPNET output netcdf now includes LAI; some variable names changed to match standard - Cleanup of leap year logic, using new `PEcAn.utils::days_in_year(year)` function (#801). - Replace many hard-coded unit conversions with `udunits2::ud.convert` for consistency, readability, and clarity -- Bugfixes to remote: - - Check that `qsub` step works, and fail loudly if it doesn't +- Remote execution is more robust to errors in the submission process, not just the actual model execution ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) @@ -42,8 +41,10 @@ For more information about this file see also [Keep a Changelog](http://keepacha ### Changed - Clean up directory structure: * Move `base` packages (`utils`, `settings`, `db`, `visualizaton`) to a `base` directory, for consistency with `modules` and `models` - * Move `logger.*` functions out of the `PEcAn.utils` package and into the `pecan.logger` package + * Move `logger.*` functions out of the `PEcAn.utils` package and into the `PEcAn.logger` package + * More `remote` functions out of the `PEcAn.utils` package and into their own `PEcAn.remote` package. - #1594 shiny/workflowPlot Refactoring of code. `get_workflow_ids` in db/R/query.dplyr.R changed with `ensemble = FALSE`. Also allowing to load all workflow IDs. `load_data_single_run` and `var_names_all` also moved from shiny/workflowPlot/server.R to query.dplyr.R +- `PEcAn.remote::start.model.runs` has been significantly refactored to be less redundant and more robust ## [1.5.0] - 2017-07-13 ### Added diff --git a/book_source/adv_user_guide_cmd/Enabling-Remote-Execution.Rmd b/book_source/adv_user_guide_cmd/Enabling-Remote-Execution.Rmd deleted file mode 100755 index 58b69e8d326..00000000000 --- a/book_source/adv_user_guide_cmd/Enabling-Remote-Execution.Rmd +++ /dev/null @@ -1,58 +0,0 @@ -# Remote execution - -PEcAn can be configured to run workflows on remote machines (with or without qsub). This does assume PEcAn is installed on the remote machine. To execute the workflows PEcAn will use SSH to connect to the remote machine. To allow for password less connections you can either setup a ssh keypair, or setup a shared tunnel. - -The easiest way to create the keypair is to use `ssh-keygen` and `ssh-copy-id user@hostname`. The first command will create the key, and the second will copy it to the remote host. `ssh-keygen` will ask for a password, leaving this blank will allow you to connect to the remote host without using a password. Once done, you should be able to login without typing your password. - -The shared tunnel requires you to login once to the remote host and keep this ssh connection alive. This works well in case of an additional security request (such as a one time password), or if you have do not want to store your password less key on the machine. To setup the shared tunnel you will need to add the following to your ~/.ssh/config - -``` -Host * - ControlMaster auto - ControlPath /tmp/%r@%h:%p -``` - -You can add the following to your .ssh/config as well, which will make it so when you login to the remote machine it will use XYZ as your login name. - -``` -Host remotehost - User XYZ -``` - -For example the following will set this up for you with the right permissions. - -```bash -mkdir ~/.ssh -chmod 700 ~/.ssh -cat > ~/.ssh/config << EOF -Host * - ControlMaster auto - ControlPath /tmp/%r@%h:%p -EOF -chmod 600 ~/.ssh/config -``` - -## Running PEcAn remotely - -Initial option is for the user to open a SSH tunnel and use this tunnel in the pecan.xml file. - -Create the tunnel: -``` -ssh -nN -o ControlMaster=yes -o ControlPath="/tmp/geo.kooper.tunnel" -l kooper geo.bu.edu -``` - -Test the tunnel: -``` -ssh -o ControlPath=/tmp/geo.kooper.tunnel geo.bu.edu pwd -``` - -Add following to pecan.xml: -``` - - geo.bu.edu - kooper - /tmp/geo.kooper.tunnel - -``` - -now as long as the tunnel is active, pecan will use the tunnel to connect. diff --git a/book_source/adv_user_guide_cmd/Remote-execution.Rmd b/book_source/adv_user_guide_cmd/Remote-execution.Rmd new file mode 100644 index 00000000000..ce393f713ea --- /dev/null +++ b/book_source/adv_user_guide_cmd/Remote-execution.Rmd @@ -0,0 +1,223 @@ +## Remote execution + +### Introduction + +Remote execution allows the user to leverage the power and storage of high performance computing clusters, AWS instances, or specially configured virtual machines, but without leaving their local working environment. +PEcAn uses remote execution primarily to run ecosystem models. + +The infrastructure for remote execution lives in the `PEcAn.remote` package (`base/remote` in the PEcAn repository). + +### Basics of SSH + +All of the PEcAn remote infrastructure depends on the system `ssh` utility, so it's important to make sure this works before attempting the advanced remote execution functionality in PEcAn. + +To connect to a remote server interactively, the command is simply: + +```sh +ssh @ +``` + +For instance, my connection to the BU shared computing cluster looks like: + +```sh +ssh ashiklom@geo.bu.edu +``` + +...which will prompt me for my BU password, and, if successful, will drop me into a login shell on the remote machine. + +Alternatively to the login shell, `ssh` can be used to execute arbitrary code, whose output will be returned exactly as it would if you ran the command locally. +For example, the following: + +```sh +ssh ashiklom@geo.bu.edu pwd +``` + +...will run the `pwd` command, and return the path to my home directory on the BU SCC. +The more advanced example below will run some simple R code on the BU SCC and return the output as if it was run locally. + +```sh +ssh ashiklom@geo.bu.edu Rscript -e "seq(1, 10)" +``` + +### SSH authentication -- password vs. SSH key + +Because this server uses passwords for authentication, this command will then prompt me for my password. + +An alternative to password authentication is using SSH keys. +Under this system, the host machine (say, your laptop, or the PEcAn VM) has to generate a public and private key pair (using the `ssh-keygen` command). +The private key (by default, a file in `~/.ssh/id_rsa`) lives on the host machine, and should **never** be shared with anyone. +The public key will be distributed to any remote machines to which you want the host to be able to connect. +On each remote machine, the public key should be added to a list of authorized keys located in the `~/.ssh/authorized_keys` file (on the remote machine). +The authorized keys list indicates which machines (technically, which keys -- a single machine, and even a single user, can have many keys) are allowed to connect to it. +This is the system used by all of the PEcAn servers (`pecan1`, `pecan2`, `test-pecan`). + +### SSH tunneling + +SSH authentication can be more advanced than indicated above, especially on systems that require dual authentication. +Even simple password-protection can be tricky in scripts, since (by design) it is fairly difficult to get SSH to accept a password from anything other than the raw keyboard input (i.e. SSH doesn't let you pass passwords as input or arguments, because this exposes your password as plain text). + +A convenient and secure way to follow SSH security protocol, but prevent having to go through the full authentication process every time, is to use SSH tunnels (or "sockets", which are effectively synonymous). +Essentially, an SSH socket is a read- and write-protectected file that contains all of the information about an SSH connection. + +To create an SSH tunnel, use a command like the following: + +``` +ssh -n -N -f -o ControlMaster=yes -S /path/to/socket/file @ +``` + +If appropriate, this will prompt you for your password (if using password authentication), and then will drop you back to the command line (thanks to the `-N` flag, which runs SSH without executing a command, the `-f` flag, which pushes SSH into the background, and the `-n` flag, which prevents ssh from reading any input). +It will also create the file `/path/to/socket/file`. + +To use this socket with another command, use the `-S /path/to/file` flag, pointing to the same tunnel file you just created. + +``` +ssh -S /path/to/socket/file +``` + +This will let you access the server without any sort of authentication step. +As before, if `` is blank, you will be dropped into an interactive shell on the remote, or if it's a command, that command will be executed and the output returned. + +To close a socket, use the following: + +``` +ssh -S /path/to/socket/file -O exit +``` + +This will delete the socket file and close the connection. +Alternatively, a scorched earth approach to closing the SSH tunnel if you don't remember where you put the socket file is something like the following: + +``` +pgrep ssh # See which processes will be killed +pkill ssh # Kill those processes +``` + +...which will kill all user processes called `ssh`. + +### SSH tunnels and PEcAn + +Many of the `PEcAn.remote` functions assume that a tunnel is already open. +If working from the web interface, the tunnel will be opened for you by some under-the-hood PHP and Bash code, but if debugging or working locally, you will have to create the tunnel yourself. +The best way to do this is to create the tunnel first, outside of R, as described above. +(In the following examples, I'll use my username `ashiklom` connecting to the `test-pecan` server with a socket stored in `/tmp/testpecan`. +To follow along, replace these with your own username and designated server, respectively). + +```{sh} +ssh -nNf -o ControlMaster=yes -S /tmp/testpecan ashiklom@test-pecan.bu.edu +``` + +Then, in R, create a `host` object, which is just a list containing the elements `name` (hostname) and `tunnel` (path to tunnel file). + +```{r} +my_host <- list(name = "test-pecan.bu.edu", tunnel = "/tmp/testpecan") +``` + +This host object can then be used in any of the remote execution functions. + + +## Basic remote execute functions + +The `PEcAn.remote::remote.execute.cmd` function runs a system command on a remote server (or on the local server, if `host$name == "localhost"`). + +```{r} +x <- PEcAn.remote::remote.execute.cmd(host = my_host, cmd = "echo", args = "Hello world") +x +``` + +Note that `remote.execute.cmd` is similar to base R's `system2`, in that the base command (in this case, `echo`) is passed separately from its arguments (`"Hello world"`). +Note also that the output of the remote command is returned as a character. + +For R code, there is a special wrapper around `remote.execute.cmd` -- `PEcAn.remote::remote.execute.R`, which runs R code on a remote and returns the output. +R code can be passed in as a list of strings... + +```{r} +code <- c("x <- 2:4", "y <- 3:1", "dput(x ^ y)") +``` + +...as a single string... + +```{r} +code <- " + x <- 2:4 + y <- 3:1 + dput(x ^ y) +" +``` + +...or as an unevaluated R expression (generated by the base R `quote` function). + +```{r} +code <- quote({ + x <- 2:4 + y <- 3:1 + dput(x ^ y) +}) +out <- PEcAn.remote::remote.execute.R(code = code, host = my_host) +out +``` + +Note that the `dput()` statement at the end is required to properly return output. + +For additional functions related to file operations and other stuff, see the `PEcAn.remote` package documentation. + + +## Remote model execution with PEcAn + +The workhorse of remote model execution is the `PEcAn.remote::start.model.runs` function, which distributes execution of each run in a list of runs (e.g. multiple runs in an ensemble) to the local machine or a remote based on the configuration in the PEcAn settings. + +Broadly, there are three major types of model execution: + +- Serialized (`PEcAn.remote::start_serial`) -- This runs models one at a time, directly on the local machine or remote (i.e. same as calling the executables one at a time for each run). +- Via a queue system, (`PEcAn.remote::start_qsub`) -- This uses a queue management system, such as SGE (e.g. `qsub`, `qstat`) found on the BU SCC machines, to submit jobs. + For computationally intensive tasks, this is the recommended way to go. +- Via a model launcher script (`PEcAn.remote::setup_modellauncher`) -- This is a highly customizable approach where task submission is controlled by a user-provided script (`launcher.sh`). + +### XML configuration + +The relevant section of the PEcAn XML file is the `` block. +Here is a minimal example from one of my recent runs: + +``` + + geo.bu.edu + ashiklom + /home/carya/output//PEcAn_99000000008/tunnel/tunnel + +``` + +Breaking this down: + +- `name` -- The hostname of the machine where the runs will be performed. + Set it to `localhost` to run on the local machine. +- `user` -- Your username on the remote machine (note that this may be different from the username on your local machine). +- `tunnel` -- This is the tunnel file for the connection used by all remote execution files. + The tunnel is created automatically by the web interface, but must be created by the user for command line execution. + +This configuration will run in serialized mode. +To use `qsub`, the configuration is slightly more involved: + +``` + + geo.bu.edu + ashiklom + qsub -V -N @NAME@ -o @STDOUT@ -e @STDERR@ -S /bin/bash + Your job ([0-9]+) .* + qstat -j @JOBID@ || echo DONE + /home/carya/output//PEcAn_99000000008/tunnel/tunnel + +``` + +The additional fields are as follows: + +- `qsub` -- The command used to submit jobs to the queue system. + Despite the name, this can be any command used for any queue system. + The following variables are available to be set here: + - `@NAME@` -- Job name to display + - `@STDOUT@` -- File to which `stdout` will be redirected + - `@STDERR@` -- File to which `stderr` will be redirected +- `qsub.jobid` -- A regular expression, from which the job ID will be determined. + This string will be parsed by R as `jobid <- gsub(qsub.jobid, "\\1", output)` -- note that the first pattern match is taken as the job ID. +- `qstat` -- The command used to check the status of a job. + Internally, PEcAn will look for the `DONE` string at the end, so a structure like ` || echo DONE` is required. + The `@JOBID@` here is the job ID determined from the `qsub.jobid` parsing. + +Documentation for using the model launcher is currently unavailable. From 07797e8fcf0b4d5d15d00e65ee43b3c204385b06 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 13 Sep 2017 16:14:56 -0400 Subject: [PATCH 607/771] Update `PEcAn.remote` calls throughout PEcAn --- Makefile | 3 ++- base/all/DESCRIPTION | 3 ++- base/db/R/query.file.path.R | 2 +- base/remote/R/check_model_run.R | 2 +- base/remote/R/remote.copy.update.R | 2 +- base/remote/R/start.model.runs.R | 10 +++++----- base/utils/R/convert.input.R | 18 +++++++++--------- base/utils/R/utils.R | 17 +---------------- base/utils/inst/LBNL_remote_test.R | 14 +++++++------- .../tutorials/ParameterAssimilation/PDA.Rmd | 2 +- models/biocro/inst/workflow.R | 2 +- models/biocro/vignettes/C4grass_sa_vd.Rmd | 2 +- models/biocro/vignettes/workflow.R | 2 +- models/biocro/vignettes/workflow.Rmd | 2 +- models/ed/R/write.configs.ed.R | 4 ++-- models/jules/R/write.config.JULES.R | 4 ++-- models/maat/inst/simple_workflow.R | 2 +- modules/assim.batch/R/pda.bayesian.tools.R | 2 +- modules/assim.batch/R/pda.emulator.R | 2 +- modules/assim.batch/R/pda.mcmc.R | 2 +- modules/assim.batch/R/pda.mcmc.bs.R | 2 +- modules/assim.sequential/R/sda.enkf.R | 4 ++-- modules/data.land/R/fia2ED.R | 8 ++++---- scripts/workflow.bm.R | 2 +- scripts/workflow.pda.R | 4 ++-- tests/interactive-workflow.R | 2 +- web/workflow.R | 2 +- 27 files changed, 54 insertions(+), 67 deletions(-) diff --git a/Makefile b/Makefile index 6c3f0f8fa48..21d1c5e8c4b 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,6 @@ NCPUS ?= 1 -BASE := logger utils db settings visualization qaqc +BASE := logger utils db settings visualization qaqc remote MODELS := biocro clm45 dalec ed fates gday jules linkages \ lpjguess maat maespa preles sipnet @@ -56,6 +56,7 @@ $(call depends,base/db): .install/base/logger .install/base/utils $(call depends,base/settings): .install/base/logger .install/base/utils .install/base/db $(call depends,base/visualization): .install/base/logger .install/base/db $(call depends,base/qaqc): .install/base/logger +$(call depends,base/remote): .install/base/logger .install/base/utils $(call depends,modules/data.atmosphere): .install/base/logger .install/base/utils $(call depends,modules/data.land): .install/base/logger .install/base/db .install/base/utils $(call depends,modules/meta.analysis): .install/base/logger .install/base/utils .install/base/db diff --git a/base/all/DESCRIPTION b/base/all/DESCRIPTION index 4af39ff46c2..5ef5e6729bf 100644 --- a/base/all/DESCRIPTION +++ b/base/all/DESCRIPTION @@ -27,7 +27,8 @@ Depends: PEcAn.assim.batch, PEcAn.emulator, PEcAn.priors, - PEcAn.benchmark + PEcAn.benchmark, + PEcAn.remote Suggests: PEcAn.ed, PEcAn.sipnet, diff --git a/base/db/R/query.file.path.R b/base/db/R/query.file.path.R index 9b399a8f789..33e4e727582 100644 --- a/base/db/R/query.file.path.R +++ b/base/db/R/query.file.path.R @@ -18,7 +18,7 @@ query.file.path <- function(input.id, host_name, con){ ) path <- file.path(dbfile$file_path,dbfile$file_name) cmd <- paste0("file.exists( '",path,"')") - PEcAn.utils::remote.execute.R(script = cmd, host = machine.host, verbose=TRUE) + PEcAn.remote::remote.execute.R(script = cmd, host = machine.host, verbose=TRUE) # Check - to be determined later # if(file.exists(path)){ # return(path) diff --git a/base/remote/R/check_model_run.R b/base/remote/R/check_model_run.R index 077efddd6f0..3a9556bc315 100644 --- a/base/remote/R/check_model_run.R +++ b/base/remote/R/check_model_run.R @@ -14,4 +14,4 @@ check_model_run <- function(out, stop.on.error = TRUE) { PEcAn.logger::logger.error(msg) } } -} \ No newline at end of file +} diff --git a/base/remote/R/remote.copy.update.R b/base/remote/R/remote.copy.update.R index 79393b5641c..455ba63b66c 100644 --- a/base/remote/R/remote.copy.update.R +++ b/base/remote/R/remote.copy.update.R @@ -11,7 +11,7 @@ #' @export remote.copy.update <- function(input_id, remote_dir, remote_file_name = NULL, host, con){ - remote.execute.cmd(host, "mkdir", c("-p", remote_dir)) + PEcAn.remote::remote.execute.cmd(host, "mkdir", c("-p", remote_dir)) local_file_record <- db.query(paste("SELECT * from dbfiles where container_id =", input_id), con) diff --git a/base/remote/R/start.model.runs.R b/base/remote/R/start.model.runs.R index a0f9c742e2f..be8a405bef2 100644 --- a/base/remote/R/start.model.runs.R +++ b/base/remote/R/start.model.runs.R @@ -70,8 +70,8 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error = TRUE) { # if running on a remote cluster, create folders and copy any data to remote host if (!is_local) { - remote.execute.cmd(settings$host, "mkdir", c("-p", file.path(settings$host$outdir, run_id_string))) - remote.copy.to(settings$host, file.path(settings$rundir, run_id_string), settings$host$rundir, delete = TRUE) + PEcAn.remote::remote.execute.cmd(settings$host, "mkdir", c("-p", file.path(settings$host$outdir, run_id_string))) + PEcAn.remote::remote.copy.to(settings$host, file.path(settings$rundir, run_id_string), settings$host$rundir, delete = TRUE) } # check to see if we use the model launcer @@ -102,7 +102,7 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error = TRUE) { if (!is_local) { # copy data back to local - remote.copy.from(settings$host, file.path(settings$host$outdir, run_id_string), settings$modeloutdir) + PEcAn.remote::remote.copy.from(settings$host, file.path(settings$host$outdir, run_id_string), settings$modeloutdir) } # write finished time to database @@ -120,7 +120,7 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error = TRUE) { if (!is_local) { # copy launcher and joblist - remote.copy.to(settings$host, file.path(settings$rundir, + PEcAn.remote::remote.copy.to(settings$host, file.path(settings$rundir, format(firstrun, scientific = FALSE)), settings$host$rundir, delete = TRUE) } @@ -168,7 +168,7 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error = TRUE) { # Copy data back to local if (!is_local) { - remote.copy.from(host = settings$host, + PEcAn.remote::remote.copy.from(host = settings$host, src = file.path(settings$host$outdir, run_id_string), dst = settings$modeloutdir) } diff --git a/base/utils/R/convert.input.R b/base/utils/R/convert.input.R index e4b8b62333c..710f861e0a8 100644 --- a/base/utils/R/convert.input.R +++ b/base/utils/R/convert.input.R @@ -72,14 +72,14 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st ## Do overwrite if set to TRUE if(overwrite){ # collect files to flag for deletion - files.to.delete <- remote.execute.R( paste0("list.files('", + files.to.delete <- PEcAn.remote::remote.execute.R( paste0("list.files('", existing.dbfile[["file_path"]], "', full.names=TRUE)"), host, user = NA, verbose = TRUE,R = Rbinary, scratchdir = outfolder) file.deletion.commands <- .get.file.deletion.commands(files.to.delete) - remote.execute.R( file.deletion.commands$move.to.tmp, + PEcAn.remote::remote.execute.R( file.deletion.commands$move.to.tmp, host, user = NA, verbose = TRUE,R = Rbinary, scratchdir = outfolder) @@ -88,12 +88,12 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st successful <- FALSE on.exit(if (exists("successful") && successful) { PEcAn.logger::logger.info("Conversion successful, with overwrite=TRUE. Deleting old files.") - remote.execute.R( file.deletion.commands$delete.tmp, + PEcAn.remote::remote.execute.R( file.deletion.commands$delete.tmp, host, user = NA, verbose = TRUE, R = Rbinary, scratchdir = outfolder ) } else { PEcAn.logger::logger.info("Conversion failed. Replacing old files.") - remote.execute.R( file.deletion.commands$replace.from.tmp, + PEcAn.remote::remote.execute.R( file.deletion.commands$replace.from.tmp, host, user = NA, verbose = TRUE, R = Rbinary, scratchdir = outfolder ) } @@ -169,14 +169,14 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st if (overwrite) { # collect files to flag for deletion - files.to.delete <- remote.execute.R( paste0("list.files('", + files.to.delete <- PEcAn.remote::remote.execute.R( paste0("list.files('", existing.dbfile[["file_path"]], "', full.names=TRUE)"), host, user = NA, verbose = TRUE,R = Rbinary, scratchdir = outfolder) file.deletion.commands <- .get.file.deletion.commands(files.to.delete) - remote.execute.R( file.deletion.commands$move.to.tmp, + PEcAn.remote::remote.execute.R( file.deletion.commands$move.to.tmp, host, user = NA, verbose = TRUE,R = Rbinary, scratchdir = outfolder) @@ -184,14 +184,14 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st successful <- FALSE on.exit(if (exists("successful") && successful) { PEcAn.logger::logger.info("Conversion successful, with overwrite=TRUE. Deleting old files.") - remote.execute.R( file.deletion.commands$delete.tmp, + PEcAn.remote::remote.execute.R( file.deletion.commands$delete.tmp, host, user = NA, verbose = TRUE, R = Rbinary, scratchdir = outfolder ) } else { PEcAn.logger::logger.info("Conversion failed. Replacing old files.") - remote.execute.R( file.deletion.commands$replace.from.tmp, + PEcAn.remote::remote.execute.R( file.deletion.commands$replace.from.tmp, host, user = NA, verbose = TRUE, R = Rbinary, scratchdir = outfolder ) } @@ -403,7 +403,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st cmdFcn <- paste0(pkg, "::", fcn, "(", arg.string, ")") PEcAn.logger::logger.debug(paste0("convert.input executing the following function:\n", cmdFcn)) - result <- remote.execute.R(script = cmdFcn, host, user = NA, verbose = TRUE, R = Rbinary, scratchdir = outfolder) + result <- PEcAn.remote::remote.execute.R(script = cmdFcn, host, user = NA, verbose = TRUE, R = Rbinary, scratchdir = outfolder) } PEcAn.logger::logger.info("RESULTS: Convert.Input") diff --git a/base/utils/R/utils.R b/base/utils/R/utils.R index 8a9f67af82f..ec447d9bc68 100644 --- a/base/utils/R/utils.R +++ b/base/utils/R/utils.R @@ -523,21 +523,6 @@ as.sequence <- function(x, na.rm = TRUE) { #--------------------------------------------------------------------------------------------------# -#--------------------------------------------------------------------------------------------------# -##' Test ssh access -##' -##' Test to determine if access to a remote server is available. -##' Can be used to exclude / include tests or to prevent / identify access errors -##' @title Test Remote -##' @param host -##' @return logical - TRUE if remote connection is available -##' @author Rob Kooper -test.remote <- function(host) { - return(try(remote.execute.cmd(host, "/bin/true")) == 0) -} # test.remote -#--------------------------------------------------------------------------------------------------# - - #--------------------------------------------------------------------------------------------------# ##' Create a temporary settings file ##' @@ -786,4 +771,4 @@ retry.func <- function(expr, isError=function(x) "try-error" %in% class(x), maxE #################################################################################################### ### EOF. End of R script file. -#################################################################################################### \ No newline at end of file +#################################################################################################### diff --git a/base/utils/inst/LBNL_remote_test.R b/base/utils/inst/LBNL_remote_test.R index 7f85a9dcaaa..2e07f2e8158 100644 --- a/base/utils/inst/LBNL_remote_test.R +++ b/base/utils/inst/LBNL_remote_test.R @@ -34,22 +34,22 @@ settings <- list(host=host) ## test remote.copy.to -PEcAn.utils::remote.copy.to(host,"favicon.ico","~/favicon.ico") +PEcAn.remote::remote.copy.to(host,"favicon.ico","~/favicon.ico") ## test remote.execute.cmd -foo <- PEcAn.utils::remote.execute.cmd(host,"pwd") +foo <- PEcAn.remote::remote.execute.cmd(host,"pwd") print(foo) -PEcAn.utils::remote.execute.cmd(host,"mv",c("/global/home/users/dietze/favicon.ico","/global/home/users/dietze/favicon.jpg")) +PEcAn.remote::remote.execute.cmd(host,"mv",c("/global/home/users/dietze/favicon.ico","/global/home/users/dietze/favicon.jpg")) ## test remote.copy.from -PEcAn.utils::remote.copy.from(host,"~/favicon.jpg","favicon.jpg") +PEcAn.remote::remote.copy.from(host,"~/favicon.jpg","favicon.jpg") ## test remote.execute.R -b <- PEcAn.utils::remote.execute.R(script = "return(1)",host = host,R=R,verbose=TRUE,scratchdir="/global/scratch/dietze/") +b <- PEcAn.remote::remote.execute.R(script = "return(1)",host = host,R=R,verbose=TRUE,scratchdir="/global/scratch/dietze/") -c <- PEcAn.utils::remote.execute.R(script = "return(require(PEcAn.data.atmosphere))",host = host,R=R,verbose=TRUE,scratchdir="/global/scratch/dietze/") +c <- PEcAn.remote::remote.execute.R(script = "return(require(PEcAn.data.atmosphere))",host = host,R=R,verbose=TRUE,scratchdir="/global/scratch/dietze/") -d <- PEcAn.utils::remote.execute.R(script = "return(.libPaths())",host = host,R=R,verbose=TRUE,scratchdir="/global/scratch/dietze/") +d <- PEcAn.remote::remote.execute.R(script = "return(.libPaths())",host = host,R=R,verbose=TRUE,scratchdir="/global/scratch/dietze/") ## kill tunnels diff --git a/documentation/tutorials/ParameterAssimilation/PDA.Rmd b/documentation/tutorials/ParameterAssimilation/PDA.Rmd index b4e98468d2f..7a7bfcf5095 100644 --- a/documentation/tutorials/ParameterAssimilation/PDA.Rmd +++ b/documentation/tutorials/ParameterAssimilation/PDA.Rmd @@ -255,7 +255,7 @@ The PDA you ran has automatically produced an updated XML file (`pecan.pda***.xm PEcAn.settings::write.settings(settings, outputfile=paste0('pecan.pda', postPDA.settings$assim.batch$ensemble.id,'.xml')) # Start ecosystem model runs, this one takes awhile... - start.model.runs(postPDA.settings, postPDA.settings$database$bety$write) + PEcAn.remote::start.model.runs(postPDA.settings, postPDA.settings$database$bety$write) # Get results of model runs get.results(postPDA.settings) diff --git a/models/biocro/inst/workflow.R b/models/biocro/inst/workflow.R index df0cb64e414..1a503b45619 100644 --- a/models/biocro/inst/workflow.R +++ b/models/biocro/inst/workflow.R @@ -28,7 +28,7 @@ run.meta.analysis(settings$pfts, settings$meta.analysis$iter, settings$meta.anal run.write.configs(model) # Calls model specific write.configs e.g. write.config.ed.R ## load met data -start.model.runs(model) # Start ecosystem model runs +PEcAn.remote::start.model.runs(model) # Start ecosystem model runs get.results(settings) # Get results of model runs diff --git a/models/biocro/vignettes/C4grass_sa_vd.Rmd b/models/biocro/vignettes/C4grass_sa_vd.Rmd index 4a890d96b11..abfdcc22526 100644 --- a/models/biocro/vignettes/C4grass_sa_vd.Rmd +++ b/models/biocro/vignettes/C4grass_sa_vd.Rmd @@ -18,7 +18,7 @@ run.meta.analysis(pfts = settings$pfts, iterations = settings$meta.analysis$iter run.write.configs(settings = settings, write = FALSE) # Calls model specific write.configs e.g. write.config.ed.R ## load met data -start.model.runs(settings = settings, write = FALSE) # Start ecosystem model runs +PEcAn.remote::start.model.runs(settings = settings, write = FALSE) # Start ecosystem model runs get.results(settings) # Get results of model runs diff --git a/models/biocro/vignettes/workflow.R b/models/biocro/vignettes/workflow.R index 472423312a6..e37644308f1 100644 --- a/models/biocro/vignettes/workflow.R +++ b/models/biocro/vignettes/workflow.R @@ -26,7 +26,7 @@ run.meta.analysis(settings$pfts, settings$meta.analysis$iter, settings$meta.anal ## @knitr , echo=FALSE,warning=FALSE,cache=TRUE run.write.configs(model) # Calls model specific write.configs e.g. write.config.ed.R ## load met data -start.model.runs(model) # Start ecosystem model runs +PEcAn.remote::start.model.runs(model) # Start ecosystem model runs read.outputs(settings$model$type, settings) # read.outputs(model, settings) #, variables = 'StemBiom') diff --git a/models/biocro/vignettes/workflow.Rmd b/models/biocro/vignettes/workflow.Rmd index 53dcb67f75e..b1d691f64f6 100644 --- a/models/biocro/vignettes/workflow.Rmd +++ b/models/biocro/vignettes/workflow.Rmd @@ -36,7 +36,7 @@ run.write.configs(settings, settings$database$bety$write) ```{r, echo=FALSE,warning=FALSE,cache=TRUE} ## load met data -start.model.runs(settings, settings$database$bety$write) # Start ecosystem model runs +PEcAn.remote::start.model.runs(settings, settings$database$bety$write) # Start ecosystem model runs ``` ```{r, echo=FALSE,warning=FALSE,cache=TRUE} diff --git a/models/ed/R/write.configs.ed.R b/models/ed/R/write.configs.ed.R index 5d6536af248..500f2eb8f53 100644 --- a/models/ed/R/write.configs.ed.R +++ b/models/ed/R/write.configs.ed.R @@ -308,7 +308,7 @@ remove.config.ED2 <- function(main.outdir = settings$outdir, settings) { if (!settings$host$name == "localhost") { ## Remove model run congfig and log files on remote host remote_ls <- function(path, pattern) { - remote.execute.cmd(host = settings$host, cmd = "ls", args = file.path(path, pattern)) + PEcAn.remote::remote.execute.cmd(host = settings$host, cmd = "ls", args = file.path(path, pattern)) } config <- remote_ls(settings$host$rundir, "c.*") ed2in <- remote_ls(settings$host$rundir, "ED2INc.*") @@ -317,7 +317,7 @@ remove.config.ED2 <- function(main.outdir = settings$outdir, settings) { if (length(config) > 0 | length(ed2in) > 0) { todelete <- c(config, ed2in[-grep("log", ed2in)], output) ## Keep log files - remote.execute.cmd(settings$host, "rm", c("-f", todelete)) + PEcAn.remote::remote.execute.cmd(settings$host, "rm", c("-f", todelete)) } } } # remove.config.ED2 diff --git a/models/jules/R/write.config.JULES.R b/models/jules/R/write.config.JULES.R index 80ec82d3520..39c75057e20 100644 --- a/models/jules/R/write.config.JULES.R +++ b/models/jules/R/write.config.JULES.R @@ -104,7 +104,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { rmt.cmd <- paste0("PEcAn.JULES::detect.timestep(met.dir='", met.dir,"', met.regexp='",met.regexp, "', start_date= '",start_date,"')") - dt <- PEcAn.utils::remote.execute.R(script=rmt.cmd,host=settings$host,verbose=TRUE) + dt <- PEcAn.remote::remote.execute.R(script=rmt.cmd,host=settings$host,verbose=TRUE) } ## -------------------- END DETECT TIMESTEP -------------------- @@ -132,7 +132,7 @@ write.config.JULES <- function(defaults, trait.values, settings, run.id) { ", resample = ",settings$spin$resample, ", run_start_date = '",start_date, "')") - start_date <- PEcAn.utils::remote.execute.R(script=rmt.cmd,host=settings$host,verbose=TRUE) + start_date <- PEcAn.remote::remote.execute.R(script=rmt.cmd,host=settings$host,verbose=TRUE) } } ## end spin diff --git a/models/maat/inst/simple_workflow.R b/models/maat/inst/simple_workflow.R index 81bce360d8f..31328045eaa 100644 --- a/models/maat/inst/simple_workflow.R +++ b/models/maat/inst/simple_workflow.R @@ -48,7 +48,7 @@ if (!file.exists(file.path(settings$rundir, "runs.txt")) | settings$meta.analysi if (!file.exists(file.path(settings$rundir, "runs.txt"))) { PEcAn.logger::logger.severe("No ensemble or sensitivity analysis specified in pecan.xml, work is done.") } else { - start.model.runs(settings, settings$database$bety$write) + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) } #--------------------------------------------------------------------------------------------------# diff --git a/modules/assim.batch/R/pda.bayesian.tools.R b/modules/assim.batch/R/pda.bayesian.tools.R index 26ad52ecbf1..a447ab2b9ac 100644 --- a/modules/assim.batch/R/pda.bayesian.tools.R +++ b/modules/assim.batch/R/pda.bayesian.tools.R @@ -133,7 +133,7 @@ pda.bayesian.tools <- function(settings, params.id = NULL, param.names = NULL, p now, sep = ".")) ## Start model run - start.model.runs(settings, settings$database$bety$write) + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) ## Read model outputs align.return <- pda.get.model.output(settings, run.id, bety, inputs) diff --git a/modules/assim.batch/R/pda.emulator.R b/modules/assim.batch/R/pda.emulator.R index 2b91c15b49b..49da640ddca 100644 --- a/modules/assim.batch/R/pda.emulator.R +++ b/modules/assim.batch/R/pda.emulator.R @@ -239,7 +239,7 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) ## start model runs - start.model.runs(settings, settings$database$bety$write) + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) ## Retrieve model outputs and error statistics model.out <- list() diff --git a/modules/assim.batch/R/pda.mcmc.R b/modules/assim.batch/R/pda.mcmc.R index 7384e181d98..0c323ffcb9b 100644 --- a/modules/assim.batch/R/pda.mcmc.R +++ b/modules/assim.batch/R/pda.mcmc.R @@ -204,7 +204,7 @@ pda.mcmc <- function(settings, params.id = NULL, param.names = NULL, prior.id = run.names = paste0("MCMC_chain.", chain, "_iteration.", i, "_variable.", j)) ## Start model run - start.model.runs(settings, settings$database$bety$write) + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) ## Read model outputs align.return <- pda.get.model.output(settings, run.id, bety, inputs) diff --git a/modules/assim.batch/R/pda.mcmc.bs.R b/modules/assim.batch/R/pda.mcmc.bs.R index 5b5d2ca52d8..a2bbdf5bec7 100644 --- a/modules/assim.batch/R/pda.mcmc.bs.R +++ b/modules/assim.batch/R/pda.mcmc.bs.R @@ -204,7 +204,7 @@ pda.mcmc.bs <- function(settings, params.id = NULL, param.names = NULL, prior.id run.names = paste0("MCMC_chain.", chain, "_iteration.", i)) ## Start model run - start.model.runs(settings, settings$database$bety$write) + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) ## Read model outputs align.return <- pda.get.model.output(settings, run.id, bety, inputs) diff --git a/modules/assim.sequential/R/sda.enkf.R b/modules/assim.sequential/R/sda.enkf.R index 942c9aaddb4..4b4c0e059b4 100644 --- a/modules/assim.sequential/R/sda.enkf.R +++ b/modules/assim.sequential/R/sda.enkf.R @@ -208,7 +208,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL, adjustmen append = FALSE) ## start model runs - start.model.runs(settings, settings$database$bety$write) + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) save(list = ls(envir = environment(), all.names = TRUE), file = file.path(outdir, "sda.initial.runs.Rdata"), envir = environment()) @@ -905,7 +905,7 @@ sda.enkf <- function(settings, obs.mean, obs.cov, IC = NULL, Q = NULL, adjustmen ### Run model ### ###-------------------------------------------------------------------### print(paste("Running Model for Year", as.Date(obs.times[t]) + 1)) - start.model.runs(settings, settings$database$bety$write) + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) } ###-------------------------------------------------------------------### diff --git a/modules/data.land/R/fia2ED.R b/modules/data.land/R/fia2ED.R index 42bf49221ec..0871ba0f56d 100644 --- a/modules/data.land/R/fia2ED.R +++ b/modules/data.land/R/fia2ED.R @@ -338,10 +338,10 @@ fia.to.psscss <- function(settings, css.file.remote <- file.path(out.dir.remote, paste0(prefix.psscss, ".css")) site.file.remote <- file.path(out.dir.remote, paste0(prefix.site, ".site")) - remote.execute.cmd(settings$host, "mkdir", c("-p", out.dir.remote)) - remote.copy.to(settings$host, pss.file.local, pss.file.remote) - remote.copy.to(settings$host, css.file.local, css.file.remote) - remote.copy.to(settings$host, site.file.local, site.file.remote) + PEcAn.remote::remote.execute.cmd(settings$host, "mkdir", c("-p", out.dir.remote)) + PEcAn.remote::remote.copy.to(settings$host, pss.file.local, pss.file.remote) + PEcAn.remote::remote.copy.to(settings$host, css.file.local, css.file.remote) + PEcAn.remote::remote.copy.to(settings$host, site.file.local, site.file.remote) files <- c(pss.file.remote, css.file.remote, site.file.remote) } diff --git a/scripts/workflow.bm.R b/scripts/workflow.bm.R index 790e3748458..9cf3a1c5c44 100644 --- a/scripts/workflow.bm.R +++ b/scripts/workflow.bm.R @@ -181,7 +181,7 @@ if ((length(which(commandArgs() == "--advanced")) != 0) && (status.check("ADVANC # Start ecosystem model runs if (status.check("MODEL") == 0) { status.start("MODEL") - start.model.runs(settings, settings$database$bety$write) + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) status.end() } diff --git a/scripts/workflow.pda.R b/scripts/workflow.pda.R index abc3af6c2bf..539bbc24fc0 100755 --- a/scripts/workflow.pda.R +++ b/scripts/workflow.pda.R @@ -160,7 +160,7 @@ if (length(which(commandArgs() == "--continue")) == 0) { # Start ecosystem model runs if (check.status("MODEL") == 0) { status.start("MODEL") - start.model.runs(settings, settings$database$bety$write) + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) status.end() } @@ -216,7 +216,7 @@ if (!is.null(settings$assim.batch)) { # Start ecosystem model runs status.start("PDA.MODEL") - start.model.runs(settings, settings$database$bety$write) + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) status.end() # Get results of model runs diff --git a/tests/interactive-workflow.R b/tests/interactive-workflow.R index d5883428523..1c8e2aa8540 100644 --- a/tests/interactive-workflow.R +++ b/tests/interactive-workflow.R @@ -84,7 +84,7 @@ if (!file.exists(file.path(settings$rundir, "runs.txt")) | settings$meta.analysi if (!file.exists(file.path(settings$rundir, "runs.txt"))) { PEcAn.logger::logger.severe("No ensemble or sensitivity analysis specified in pecan.xml, work is done.") } else { - start.model.runs(settings, settings$database$bety$write) + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) } # get results diff --git a/web/workflow.R b/web/workflow.R index ba50434365f..be300da9450 100755 --- a/web/workflow.R +++ b/web/workflow.R @@ -108,7 +108,7 @@ if ((length(which(commandArgs() == "--advanced")) != 0) && (PEcAn.utils::status. # Start ecosystem model runs if (PEcAn.utils::status.check("MODEL") == 0) { PEcAn.utils::status.start("MODEL") - PEcAn.utils::runModule.start.model.runs(settings,stop.on.error=FALSE) + PEcAn.remote::runModule.start.model.runs(settings,stop.on.error=FALSE) PEcAn.utils::status.end() } From 6ee89f87e9d866d91a7e34a70883eb73b302e72a Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 13 Sep 2017 16:23:43 -0400 Subject: [PATCH 608/771] Add PEcAn.remote to description files --- base/utils/DESCRIPTION | 1 + base/utils/man/test.remote.Rd | 21 --------------------- models/biocro/DESCRIPTION | 1 + models/ed/DESCRIPTION | 1 + models/jules/DESCRIPTION | 1 + models/maat/DESCRIPTION | 1 + modules/assim.batch/DESCRIPTION | 1 + modules/assim.sequential/DESCRIPTION | 1 + modules/data.land/DESCRIPTION | 1 + 9 files changed, 8 insertions(+), 21 deletions(-) delete mode 100644 base/utils/man/test.remote.Rd diff --git a/base/utils/DESCRIPTION b/base/utils/DESCRIPTION index dd26232b044..4866536f945 100644 --- a/base/utils/DESCRIPTION +++ b/base/utils/DESCRIPTION @@ -22,6 +22,7 @@ Depends: RCurl Imports: PEcAn.logger, + PEcAn.remote, abind (>= 1.4.5), coda (>= 0.18), lubridate (>= 1.6.0), diff --git a/base/utils/man/test.remote.Rd b/base/utils/man/test.remote.Rd deleted file mode 100644 index 4ce69126d92..00000000000 --- a/base/utils/man/test.remote.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{test.remote} -\alias{test.remote} -\title{Test Remote} -\usage{ -test.remote(host) -} -\value{ -logical - TRUE if remote connection is available -} -\description{ -Test ssh access -} -\details{ -Test to determine if access to a remote server is available. -Can be used to exclude / include tests or to prevent / identify access errors -} -\author{ -Rob Kooper -} diff --git a/models/biocro/DESCRIPTION b/models/biocro/DESCRIPTION index 7d601e14e76..9981877312b 100644 --- a/models/biocro/DESCRIPTION +++ b/models/biocro/DESCRIPTION @@ -8,6 +8,7 @@ Maintainer: David LeBauer Description: This module provides functions to link BioCro to PEcAn. Imports: PEcAn.logger, + PEcAn.remote, PEcAn.utils, PEcAn.settings, PEcAn.data.atmosphere, diff --git a/models/ed/DESCRIPTION b/models/ed/DESCRIPTION index d30d936f1ee..417bc64232f 100644 --- a/models/ed/DESCRIPTION +++ b/models/ed/DESCRIPTION @@ -17,6 +17,7 @@ Depends: coda Imports: PEcAn.logger, + PEcAn.remote, abind (>= 1.4.5), ncdf4 (>= 1.15), stringr(>= 1.1.0), diff --git a/models/jules/DESCRIPTION b/models/jules/DESCRIPTION index d1d9f79e8f9..65ac1df0d3e 100644 --- a/models/jules/DESCRIPTION +++ b/models/jules/DESCRIPTION @@ -10,6 +10,7 @@ Depends: PEcAn.utils Imports: PEcAn.logger, + PEcAn.remote, lubridate (>= 1.6.0), ncdf4 (>= 1.15) Suggests: diff --git a/models/maat/DESCRIPTION b/models/maat/DESCRIPTION index bbd8da076bb..cffe6a494d1 100644 --- a/models/maat/DESCRIPTION +++ b/models/maat/DESCRIPTION @@ -8,6 +8,7 @@ Maintainer: Shawn Serbin Description: This module provides functions to link the MAAT to PEcAn. Imports: PEcAn.logger, + PEcAn.remote, PEcAn.utils, lubridate (>= 1.6.0), ncdf4 (>= 1.15), diff --git a/modules/assim.batch/DESCRIPTION b/modules/assim.batch/DESCRIPTION index 2b22dd9e9a4..d97d4e50581 100644 --- a/modules/assim.batch/DESCRIPTION +++ b/modules/assim.batch/DESCRIPTION @@ -12,6 +12,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific efficacy of scientific investigation. Depends: PEcAn.utils, + PEcAn.logger, PEcAn.DB, ellipse, dplyr, diff --git a/modules/assim.sequential/DESCRIPTION b/modules/assim.sequential/DESCRIPTION index fd4e5f5a4ac..09fe73b4c4d 100644 --- a/modules/assim.sequential/DESCRIPTION +++ b/modules/assim.sequential/DESCRIPTION @@ -12,6 +12,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific efficacy of scientific investigation. Imports: PEcAn.logger, + PEcAn.remote, plyr (>= 1.8.4), magic (>= 1.5.0), lubridate (>= 1.6.0), diff --git a/modules/data.land/DESCRIPTION b/modules/data.land/DESCRIPTION index f5cfd4023c4..eddfee45785 100644 --- a/modules/data.land/DESCRIPTION +++ b/modules/data.land/DESCRIPTION @@ -17,6 +17,7 @@ Depends: dbplyr Imports: PEcAn.logger, + PEcAn.remote, ncdf4 (>= 1.15), udunits2 (>= 0.11), traits, From 2ae89d6fbcd4257826ef0d8adb6388afe8bc756d Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 13 Sep 2017 17:16:32 -0400 Subject: [PATCH 609/771] remote: Revert to original remote.execute.R MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It works better, and doesn't break PEcAn. --- base/remote/R/remote.execute.R.R | 128 ++++++++++-------- base/remote/man/remote.execute.R.Rd | 51 +++---- base/remote/tests/testthat/test.remote.R | 21 --- .../tests/testthat/test.remote.execute.R.R | 16 +++ 4 files changed, 109 insertions(+), 107 deletions(-) create mode 100644 base/remote/tests/testthat/test.remote.execute.R.R diff --git a/base/remote/R/remote.execute.R.R b/base/remote/R/remote.execute.R.R index 976a4f19be6..12bb3b95e5e 100644 --- a/base/remote/R/remote.execute.R.R +++ b/base/remote/R/remote.execute.R.R @@ -1,63 +1,81 @@ -#' Remotely execute R code +#' Execute command remotely #' -#' Wrapped code should contain a `dput()` statement, or a warning will be thrown. -#' `dput()` is used to return outputs, so if it is absent, the output will be `NULL`. +#' Executes the given command on the remote host using ssh. If the user is set +#' the system will login as the given user. If the host given is the local +#' machine it will execute the command locally without ssh. #' -#' @author Alexey Shiklomanov -#' @param code R code to be run on remote, either as an unevaluated expression, -#' a single character string, or a vector of strings to be run in sequence. -#' @inheritParams remote.execute.cmd -#' @param ... Additional arguments passed to [remote.execute.cmd()]. -#' -#' @return Exactly the output of `code`, or `NULL` if no `dput()` statement can be found in the wrapped code. +#' @title Execute command remotely +#' @param script the script to be invoked, as a list of commands. +#' @param args a character vector of arguments to command. +#' @param host settings host list +#' @param user the username to use for remote login +#' @param verbose should the output be printed to the console +#' @return the captured output of the command (both stdout and stderr) +#' @author Rob Kooper #' @export -#' #' @examples -#' host <- list(name = "localhost") -#' code <- quote({ -#' x <- 5 -#' y <- 10 -#' out <- list(xx = seq_len(x), yy = seq_len(y) * 2) -#' dput(out) -#' }) -#' result <- remote.execute.R(code = code, host = host) -#' -#' code2 <- c("x <- 10", "y <- 7", "out <- list(x = seq(x), y = seq(y))", "dput(out)") -#' result <- remote.execute.R(code = code2, host = host) -#' -#' code3 <- " -#' n <- 10 -#' x <- rnorm(n) -#' y <- runif(n) -#' df <- data.frame(norm = x, unif = y) -#' dput(df) -#' " -#' result <- remote.execute.R(code = code3, host = host) -remote.execute.R <- function(code, host, stderr = TRUE, ...) { - if (is.character(code)) { - code_string <- code - } else if (typeof(code) == "language") { - code_string <- deparse(code) - } else { - PEcAn.logger::logger.severe("Code must be an R quoted expression or a character string.") - } - has_dput <- any(grepl("dput", code_string)) - if (!has_dput) { - PEcAn.logger::logger.error("No dput statement found in code string.", - "This means no values will be returned.") +#' \dontrun{ +#' remote.execute.R('list.files()', host='localhost', verbose=FALSE) +#' } +remote.execute.R <- function(script, host = "localhost", user = NA, verbose = FALSE, + R = "R", scratchdir = tempdir()) { + if (is.character(host)) { + host <- list(name = host) } - code_string_c <- gsub("\n", "; ", paste(code_string, collapse = '; ')) - code_string_c <- gsub("^; *", "", code_string_c) - cmd <- "Rscript" - args <- c("-e", shQuote(code_string_c)) - result <- remote.execute.cmd(host = host, cmd = cmd, args = args, stderr = stderr, ...) - if (!has_dput) { - PEcAn.logger::logger.debug("Command ran successfuly, but no values returned because `dput` was not found.", - "Returning NULL.") - return(NULL) + uuid <- paste0("pecan-", paste(sample(c(letters[1:6], 0:9), 30, replace = TRUE), + collapse = "")) + tmpfile <- file.path(scratchdir, uuid) + input <- c(paste0("remotefunc <- function() {", script, "}"), + "remoteout <- remotefunc()", + "print(remoteout)", + paste0("fp <- file('", tmpfile, "', 'w')"), + paste0("ign <- serialize(remoteout, fp)"), + "close(fp)") + verbose <- ifelse(as.logical(verbose), "", FALSE) + if ((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) { + if (R == "R") { + Rbinary <- file.path(Sys.getenv("R_HOME"), "bin", "R") + if (file.exists(Rbinary)) { + R <- Rbinary + } + } + result <- try(system2(R, "--no-save","--no-restore", stdout = verbose, stderr = verbose, + input = input)) + print(result) + if (!file.exists(tmpfile)) { + fp <- file(tmpfile, "w") + serialize(result, fp) + close(fp) + } + ## get result + fp <- file(tmpfile, "r") + result <- unserialize(fp) + close(fp) + file.remove(tmpfile) + return(invisible(result)) + } else { - parsed <- parse(text = result) - evalled <- eval(parsed) - return(evalled) + remote <- c(host$name) + if (!is.null(host$tunnel)) { + if (!file.exists(host$tunnel)) { + PEcAn.logger::logger.severe("Could not find tunnel", host$tunnel) + } + remote <- c("-o", paste0("ControlPath=\"", host$tunnel, "\""), remote) + } else if (!is.null(host$user)) { + remote <- c("-l", host$user, remote) + } + PEcAn.logger::logger.debug(paste(c("ssh", "-T", remote, R), collapse = " ")) + result <- system2("ssh", c("-T", remote, R, "--no-save","--no-restore"), stdout = verbose, + stderr = verbose, input = input) + remote.copy.from(host, tmpfile, uuid) + remote.execute.cmd(host, "rm", c("-f", tmpfile)) + # load result + fp <- file(uuid, "r") + result <- unserialize(fp) + close(fp) + file.remove(uuid) + return(invisible(result)) } + + } # remote.execute.R \ No newline at end of file diff --git a/base/remote/man/remote.execute.R.Rd b/base/remote/man/remote.execute.R.Rd index ee9d1501c57..ae8f76b7aab 100644 --- a/base/remote/man/remote.execute.R.Rd +++ b/base/remote/man/remote.execute.R.Rd @@ -2,49 +2,38 @@ % Please edit documentation in R/remote.execute.R.R \name{remote.execute.R} \alias{remote.execute.R} -\title{Remotely execute R code} +\title{Execute command remotely} \usage{ -remote.execute.R(code, host, stderr = TRUE, ...) +remote.execute.R(script, host = "localhost", user = NA, verbose = FALSE, + R = "R", scratchdir = tempdir()) } \arguments{ -\item{code}{R code to be run on remote, either as an unevaluated expression, -a single character string, or a vector of strings to be run in sequence.} +\item{script}{the script to be invoked, as a list of commands.} -\item{host}{host structure to execute command on} +\item{host}{settings host list} -\item{stderr}{should stderr be returned as well.} +\item{user}{the username to use for remote login} -\item{...}{Additional arguments passed to \code{\link[=remote.execute.cmd]{remote.execute.cmd()}}.} +\item{verbose}{should the output be printed to the console} + +\item{args}{a character vector of arguments to command.} } \value{ -Exactly the output of \code{code}, or \code{NULL} if no \code{dput()} statement can be found in the wrapped code. +the captured output of the command (both stdout and stderr) } \description{ -Wrapped code should contain a \code{dput()} statement, or a warning will be thrown. -\code{dput()} is used to return outputs, so if it is absent, the output will be \code{NULL}. +Execute command remotely +} +\details{ +Executes the given command on the remote host using ssh. If the user is set +the system will login as the given user. If the host given is the local +machine it will execute the command locally without ssh. } \examples{ -host <- list(name = "localhost") -code <- quote({ - x <- 5 - y <- 10 - out <- list(xx = seq_len(x), yy = seq_len(y) * 2) - dput(out) -}) -result <- remote.execute.R(code = code, host = host) - -code2 <- c("x <- 10", "y <- 7", "out <- list(x = seq(x), y = seq(y))", "dput(out)") -result <- remote.execute.R(code = code2, host = host) - -code3 <- " - n <- 10 - x <- rnorm(n) - y <- runif(n) - df <- data.frame(norm = x, unif = y) - dput(df) -" -result <- remote.execute.R(code = code3, host = host) +\dontrun{ + remote.execute.R('list.files()', host='localhost', verbose=FALSE) +} } \author{ -Alexey Shiklomanov +Rob Kooper } diff --git a/base/remote/tests/testthat/test.remote.R b/base/remote/tests/testthat/test.remote.R index 9dcca333ec8..abb7ea35372 100644 --- a/base/remote/tests/testthat/test.remote.R +++ b/base/remote/tests/testthat/test.remote.R @@ -16,24 +16,3 @@ out <- remote.execute.cmd(host = good_host, cmd = "echo", args = echo_string) test_that("Basic remote execution works as expected", { expect_identical(out, echo_string) }) - -host <- list(name = "localhost") -code <- quote({ - x <- 5 - y <- 10 - out <- list(xx = seq_len(x), yy = seq_len(y) * 2) - dput(out) -}) -result <- remote.execute.R(code = code, host = host) - -code2 <- c("x <- 10", "y <- 7", "out <- list(x = seq(x), y = seq(y))", "dput(out)") -result <- remote.execute.R(code = code2, host = host) - -code3 <- " - n <- 10 - x <- rnorm(n) - y <- runif(n) - df <- data.frame(norm = x, unif = y) - dput(df) -" -result <- remote.execute.R(code = code3, host = host) \ No newline at end of file diff --git a/base/remote/tests/testthat/test.remote.execute.R.R b/base/remote/tests/testthat/test.remote.execute.R.R new file mode 100644 index 00000000000..d75783b804e --- /dev/null +++ b/base/remote/tests/testthat/test.remote.execute.R.R @@ -0,0 +1,16 @@ +library(PEcAn.remote) +host <- list(name = "localhost") + +code <- " + n <- 10 + x <- seq(1, n) + y <- seq(n, 1) + df <- data.frame(x = x, y = y) + df +" + +result <- remote.execute.R(script = code, host = host) + +test_that("Remote execute R works as expected", { + expect_identical(result, eval(parse(text = code))) +}) \ No newline at end of file From 91ce3de0e12cbf8619942c508236bf58b6410da7 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 13 Sep 2017 17:25:14 -0400 Subject: [PATCH 610/771] make: utils depends on remote --- Makefile | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/Makefile b/Makefile index 21d1c5e8c4b..8ae001ab22f 100644 --- a/Makefile +++ b/Makefile @@ -52,20 +52,21 @@ test: $(ALL_PKGS_T) .test/base/all depends = .doc/$(1) .install/$(1) .check/$(1) .test/$(1) +$(call depends,base/remote): .install/base/logger +$(call depends,base/utils): .install/base/logger .install/base/remote $(call depends,base/db): .install/base/logger .install/base/utils $(call depends,base/settings): .install/base/logger .install/base/utils .install/base/db $(call depends,base/visualization): .install/base/logger .install/base/db $(call depends,base/qaqc): .install/base/logger -$(call depends,base/remote): .install/base/logger .install/base/utils -$(call depends,modules/data.atmosphere): .install/base/logger .install/base/utils -$(call depends,modules/data.land): .install/base/logger .install/base/db .install/base/utils -$(call depends,modules/meta.analysis): .install/base/logger .install/base/utils .install/base/db -$(call depends,modules/priors): .install/base/logger .install/base/utils -$(call depends,modules/assim.batch): .install/base/logger .install/base/utils .install/base/db .install/modules/meta.analysis -$(call depends,modules/rtm): .install/base/logger .install/modules/assim.batch -$(call depends,modules/uncertainty): .install/base/logger .install/base/utils .install/modules/priors -$(call depends,models/template): .install/base/logger .install/base/utils -$(call depends,models/biocro): .install/base/logger .install/base/utils .install/base/settings .install/base/db .install/modules/data.atmosphere .install/modules/data.land +$(call depends,modules/data.atmosphere): .install/base/logger .install/base/utils .install/base/remote +$(call depends,modules/data.land): .install/base/logger .install/base/db .install/base/utils .install/base/remote +$(call depends,modules/meta.analysis): .install/base/logger .install/base/utils .install/base/db .install/base/remote +$(call depends,modules/priors): .install/base/logger .install/base/utils .install/base/remote +$(call depends,modules/assim.batch): .install/base/logger .install/base/utils .install/base/db .install/modules/meta.analysis .install/base/remote +$(call depends,modules/rtm): .install/base/logger .install/modules/assim.batch .install/base/remote +$(call depends,modules/uncertainty): .install/base/logger .install/base/utils .install/modules/priors .install/base/remote +$(call depends,models/template): .install/base/logger .install/base/utils .install/base/remote +$(call depends,models/biocro): .install/base/logger .install/base/utils .install/base/settings .install/base/db .install/modules/data.atmosphere .install/modules/data.land .install/base/remote clean: rm -rf .install .check .test .doc From 4ab2ab30b1d61ca5035dda2ffb97ec6dd7bb3ab4 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Mon, 11 Sep 2017 16:34:02 -0500 Subject: [PATCH 611/771] Initial TDM updates: 1. Incorporate speed-ups from #1543 where we changed how we were saving & loading model information to only keep the essential bits. Additional changes from a83ad7a5b82875a59eec6f1052ed82b29660bba7 1. Use align.met to quickly pull data in uniform formats and consistent ways. This helps with naming and allows us to work with fewer things read into memory at once. 2. Support for backwards and forwards met filtering. (I *think* this should fix most lag/next confusion. 3. Pass random seed from a high level to help with reproducible results --- modules/data.atmosphere/R/align_met.R | 46 +- .../R/tdm_generate_subdaily_models.R | 159 +++--- .../data.atmosphere/R/tdm_lm_ensemble_sims.R | 251 +++++---- .../R/tdm_predict_subdaily_met.R | 509 +++++++++--------- modules/data.atmosphere/R/tdm_subdaily_pred.R | 18 +- .../R/tdm_temporal_downscale_functions.R | 194 ++++--- 6 files changed, 647 insertions(+), 530 deletions(-) diff --git a/modules/data.atmosphere/R/align_met.R b/modules/data.atmosphere/R/align_met.R index a57844d7071..da09d6ce4d1 100644 --- a/modules/data.atmosphere/R/align_met.R +++ b/modules/data.atmosphere/R/align_met.R @@ -40,6 +40,10 @@ ##' prevents needing to load the entire dataset. If NULL, all available years ##' will be loaded. If not null, should be a vector of numbers (so you can skip ##' problematic years) +##' @param yrs.source - (optional) specify a specific years to be loaded for the source data; +##' prevents needing to load the entire dataset. If NULL, all available years +##' will be loaded. If not null, should be a vector of numbers (so you can skip +##' problematic years) ##' @param n.ens - number of ensemble members to generate and save ##' @param pair.mems - logical stating whether ensemble members should be paired in ##' the case where ensembles are being read in in both the training and source data @@ -67,7 +71,7 @@ #---------------------------------------------------------------------- # Begin Function #---------------------------------------------------------------------- -align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair.mems = FALSE, seed=Sys.Date(), verbose = FALSE) { +align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, n.ens=NULL, pair.mems = FALSE, seed=Sys.Date(), verbose = FALSE) { # Load required libraries library(ncdf4) library(lubridate) @@ -110,7 +114,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. # Create a data frame with all the important time info # center the hour step - df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/step.day), Hour=rep(stamps.hr, ntime)) + df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/step.day), Hour=rep(stamps.hr, length.out=ntime)) df.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") met.out$dat.train[["time"]] <- rbind(met.out$dat.train$time, df.time) @@ -181,7 +185,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. # center the hour step # ** Only do this with the first ensemble member so we're not being redundant if(j==1){ - df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/step.day), Hour=rep(stamps.hr, ntime)) + df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/step.day), Hour=rep(stamps.hr, length.out=ntime)) df.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") met.out$dat.train[["time"]] <- rbind(met.out$dat.train$time, df.time) } @@ -223,9 +227,18 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) yrs.file <- as.numeric(yrs.file[,ncol(yrs.file)-1]) # Assumes year is always last thing before the file extension + # Subsetting to just the years we're interested in + if(!is.null(yrs.source)){ + files.source <- files.source[which(yrs.file %in% yrs.source)] + yrs.file <- yrs.file[which(yrs.file %in% yrs.source)] + } + + # Getting the day & hour timesteps from the training data - day.train <- round(365/length(unique(met.out$dat.train$time$DOY))) + yrs.train <- length(unique(met.out$dat.train$time$Year)) hr.train <- 24/length(unique(met.out$dat.train$time$Hour)) + day.train <- 1/length(unique(met.out$dat.train$time$Hour)) + # day.train <- 1/(nrow(met.out$dat.train$time)/yrs.train/365) # Loop through the .nc files putting everything into a list print("Processing Source Data") @@ -247,7 +260,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. # ----- # Making what the unique time stamps should be to match the training data stamps.hr <- seq(hr.train/2, by=hr.train, length.out=1/day.train) - stamps.src <- stamps.hr + stamps.src <- seq(step.hr/2, by=step.hr, length.out=1/step.day) if(step.hr < hr.train){ # Finer hour increment --> set it up to aggregate align = "aggregate" @@ -261,19 +274,19 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. # Create a data frame with all the important time info # center the hour step - df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/day.train), Hour=rep(stamps.hr, length.out=nday/day.train)) + df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/day.train), Hour=rep(stamps.hr, length.out=nday/(day.train))) df.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") met.out$dat.source[["time"]] <- rbind(met.out$dat.source$time, df.time) src.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/step.day), Hour=rep(stamps.src, length.out=ntime)) - src.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") + src.time$Date <- strptime(paste(src.time$Year, src.time$DOY, src.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") # Extract the met info, making matrices with the appropriate number of ensemble members for(v in names(ncT$var)){ dat.tem <- ncvar_get(ncT, v) if(align=="repeat"){ # if we need to coerce the time step to be repeated to match temporal resolution, do it here - dat.tem <- rep(dat.temp, each=stamps.hr) + dat.tem <- rep(dat.tem, each=length(stamps.hr)) } df.tem <- matrix(rep(dat.tem, n.src), ncol=n.src, byrow=F) @@ -336,6 +349,12 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) yrs.file <- as.numeric(yrs.file[,ncol(yrs.file)-1]) # Assumes year is always last thing before the file extension + # Subsetting to just the years we're interested in + if(!is.null(yrs.source)){ + files.source <- files.source[which(yrs.file %in% yrs.source)] + yrs.file <- yrs.file[which(yrs.file %in% yrs.source)] + } + # Getting the day & hour timesteps from the training data day.train <- round(365/length(unique(met.out$dat.train$time$DOY))) hr.train <- 24/length(unique(met.out$dat.train$time$Hour)) @@ -359,7 +378,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. # ----- # Making what the unique time stamps should be to match the training data stamps.hr <- seq(hr.train/2, by=hr.train, length.out=1/day.train) - stamps.src <- stamps.hr + stamps.src <- seq(step.hr/2, by=step.hr, length.out=1/step.day) if(step.hr < hr.train){ # Finer hour increment --> set it up to aggregate align = "aggregate" @@ -371,11 +390,12 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. } # ----- + # Create a data frame with all the important time info # center the hour step - df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/day.train), Hour=rep(stamps.hr, length.out=nday/day.train)) + df.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/day.train), Hour=rep(stamps.hr, length.out=nday/(day.train))) df.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") - + # Create a data frame with all the important time info # center the hour step # ** Only do this with the first ensemble member so we're not being redundant @@ -384,14 +404,14 @@ align.met <- function(train.path, source.path, yrs.train=NULL, n.ens=NULL, pair. } src.time <- data.frame(Year=yr.now, DOY=rep(1:nday, each=1/step.day), Hour=rep(stamps.src, length.out=ntime)) - src.time$Date <- strptime(paste(df.time$Year, df.time$DOY, df.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") + src.time$Date <- strptime(paste(src.time$Year, src.time$DOY, src.time$Hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") # Extract the met info, making matrices with the appropriate number of ensemble members for(v in names(ncT$var)){ dat.tem <- ncvar_get(ncT, v) if(align=="repeat"){ # if we need to coerce the time step to be repeated to match temporal resolution, do it here - dat.tem <- rep(dat.temp, each=stamps.hr) + dat.tem <- rep(dat.tem, each=stamps.hr) } df.tem <- matrix(rep(dat.tem, n.src), ncol=1, byrow=F) diff --git a/modules/data.atmosphere/R/tdm_generate_subdaily_models.R b/modules/data.atmosphere/R/tdm_generate_subdaily_models.R index 59d6256e2b8..145274993b4 100644 --- a/modules/data.atmosphere/R/tdm_generate_subdaily_models.R +++ b/modules/data.atmosphere/R/tdm_generate_subdaily_models.R @@ -18,16 +18,21 @@ # ----------------------------------- # Parameters # ----------------------------------- -##' @param outfolder - directory where models will be stored *** storage required varies by size of training dataset, but prepare for >100 GB -##' @param dat.train_file - train_data file +##' @param outfolder - directory where models will be stored *** storage required varies by size of training dataset, but prepare for >10 GB +##' @param path.train - path to CF/PEcAn style training data where each year is in a separate file. +##' @param yrs.train - which years of the training data should be used for to generate the model for +##' the subdaily cycle. If NULL, will default to all years +##' @param direction.filter - Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") +##' (PalEON will go backwards, anybody interested in the future will go forwards) ##' @param in.prefix ##' @param n.beta - number of betas to save from linear regression model -##' @param resids - logical stating whether to pass on residual data or not +##' @param resids - logical stating whether to pass on residual data or not (this increases both memory & storage requirements) ##' @param parallel - logical stating whether to run temporal_downscale_functions.R in parallel ##' @param n.cores - deals with parallelization ##' @param day.window - integer specifying number of days around the day being modeled you want to use data from for that ##' specific hours coefficients. Must be integer because we want statistics from the same time of day ##' for each day surrounding the model day +##' @param seed - seed for randomization to allow for reproducible results ##' @param overwrite ##' @param verbose ##' @export @@ -37,12 +42,12 @@ #---------------------------------------------------------------------- -gen.subdaily.models <- function(outfolder, dat.train_file, in.prefix, +gen.subdaily.models <- function(outfolder, path.train, yrs.train, direction.filter, in.prefix, n.beta, day.window, resids = FALSE, parallel = FALSE, n.cores = NULL, overwrite = TRUE, verbose = FALSE) { - pb.index <- 1 - pb <- txtProgressBar(min = 1, max = 8, style = 3) + # pb.index <- 1 + # pb <- txtProgressBar(min = 1, max = 8, style = 3) # ----- 1.0 Read data & Make time stamps ---------- Load the data @@ -50,53 +55,74 @@ gen.subdaily.models <- function(outfolder, dat.train_file, in.prefix, "air_temperature_min", "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", "air_pressure", "specific_humidity", "eastward_wind", "northward_wind", "wind_speed")) - dat.train <- list() - tem <- ncdf4::nc_open(dat.train_file) - dim <- tem$dim - for (j in seq_along(vars.info$CF.name)) { - if (exists(as.character(vars.info$CF.name[j]), tem$var)) { - dat.train[[j]] <- ncdf4::ncvar_get(tem, as.character(vars.info$CF.name[j])) - } else { - dat.train[[j]] = NA - } - } - names(dat.train) <- vars.info$CF.name - dat.train <- data.frame(dat.train) + # Getting a list of all the available files and then subsetting to just the ones we + # actually want to use + files.train <- dir(path.train) + yrs.file <- strsplit(files.train, "[.]") + yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) + yrs.file <- as.numeric(yrs.file[,ncol(yrs.file)-1]) # Assumes year is always last thing before the file extension - # create wind speed variable if we're only given component wind speeds - if (all(is.na(dat.train$wind_speed) == TRUE)){ - dat.train$wind_speed <- sqrt(dat.train$eastward_wind^2 + dat.train$northward_wind^2) + if(!is.null(yrs.train)){ + files.train <- files.train[which(yrs.file %in% yrs.train)] + yrs.file <- yrs.file[which(yrs.file %in% yrs.train)] } - # adding a temporary date variable for the model - if (dim$time$units == "sec"){ - sub_string<- substrRight(dat.train_file, 7) - start_year <- substr(sub_string, 1, 4) - dat.train$date <- as.Date((dim$time$vals/(dim$time$vals[2] - dim$time$vals[1])), - tz="GMT", origin = paste0(start_year - 1, "-12-31")) - } else { - start_year <- substr(dim$time$units,start = 12,stop = 15) - dat.train$date = as.POSIXct(udunits2::ud.convert((dim$time$vals - ((dim$time$vals[2] - dim$time$vals[1])/2)),"days", "seconds"), - tz="GMT", origin = paste0(start_year, "-01-01 00:00:00")) - } - # Getting additional time stamps - dat.train$year <- lubridate::year(dat.train$date) - dat.train$doy <- lubridate::yday(dat.train$date) - dat.train$hour <- lubridate::hour(dat.train$date) + dat.train <- data.frame() + for(i in 1:length(files.train)){ + yr.now <- yrs.file[i] + + ncT <- ncdf4::nc_open(file.path(path.train, files.train[i])) + + # Set up the time data frame to help index + nday <- ifelse(lubridate::leap_year(yr.now), 366, 365) + ntime <- length(ncT$dim$time$vals) + step.day <- nday/ntime + step.hr <- step.day*24 + stamps.hr <- seq(step.hr/2, by=step.hr, length.out=1/step.day) # Time stamps centered on period + + # Create a data frame with all the important time info + # center the hour step + df.tmp <- data.frame(year=yr.now, doy=rep(1:nday, each=1/step.day), hour=rep(stamps.hr, nday)) + df.tmp$date <- strptime(paste(df.tmp$year, df.tmp$doy, df.tmp$hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") + + # Extract the met info, making matrices with the appropriate number of ensemble members + for(v in names(ncT$var)){ + df.tmp[,v] <- ncdf4::ncvar_get(ncT, v) + } + + ncdf4::nc_close(ncT) + + dat.train <- rbind(dat.train, df.tmp) + + # setTxtProgressBar(pb, i) + } # End looping through training data files + if(!"wind_speed" %in% names(dat.train)){ + dat.train$wind_speed <- sqrt(dat.train$eastward_wind^2 + dat.train$northward_wind^2) + } + + # # adding a temporary date variable for the model + # if (dim$time$units == "sec"){ + # sub_string<- substrRight(dat.train_file, 7) + # start_year <- substr(sub_string, 1, 4) + # dat.train$date <- as.Date((dim$time$vals/(dim$time$vals[2] - dim$time$vals[1])), + # tz="GMT", origin = paste0(start_year - 1, "-12-31")) + # } else { + # start_year <- substr(dim$time$units,start = 12,stop = 15) + # dat.train$date = as.POSIXct(udunits2::ud.convert((dim$time$vals - ((dim$time$vals[2] - dim$time$vals[1])/2)),"days", "seconds"), + # tz="GMT", origin = paste0(start_year, "-01-01 00:00:00")) + # } + # these non-standard variables help us organize our modeling approach - dat.train$date <- strptime(paste(dat.train$year, dat.train$doy + 1, - dat.train$hour, sep = "-"), "%Y-%j-%H", tz = "GMT") - dat.train$time.hr <- as.numeric(difftime(dat.train$date, paste0((min(dat.train$year) - - 1), "-12-31 ", max(unique(dat.train$hour)),":00:00"), tz = "GMT", units = "hour")) - dat.train$time.day <- as.numeric(difftime(dat.train$date, paste0((min(dat.train$year) - - 1), "-12-31 ", max(unique(dat.train$hour)),":00:00"), tz = "GMT", units = "day")) - 1/24 - dat.train$time.day2 <- as.integer(dat.train$time.day + 1/(48 * 2)) + - 1 # Offset by half a time step to get time stamps to line up + # Reference everything off of the earliest date; avoiding 0s because that makes life difficult + dat.train$sim.hr <- trunc(as.numeric(difftime(dat.train$date, min(dat.train$date), tz = "GMT", units = "hour")))+1 + dat.train$sim.day <- trunc(as.numeric(difftime(dat.train$date, min(dat.train$date), tz = "GMT", units = "day")))+1 + # dat.train$time.day2 <- as.integer(dat.train$time.day + 1/(48 * 2)) + 1 # Offset by half a time step to get time stamps to line up # ----- 1.1 Coming up with the daily means that are what we can # use as predictors ---------- + vars.use <- vars.info$CF.name[vars.info$CF.name %in% names(dat.train)] train.day <- aggregate(dat.train[, c("air_temperature", "precipitation_flux", "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", @@ -122,26 +148,31 @@ gen.subdaily.models <- function(outfolder, dat.train_file, in.prefix, vars.lag <- c("lag.air_temperature", "lag.precipitation_flux", "lag.surface_downwelling_shortwave_flux_in_air", "lag.surface_downwelling_longwave_flux_in_air", "lag.air_pressure", "lag.specific_humidity", "lag.wind_speed") - lag.day <- dat.train[dat.train$hour == max(unique(dat.train$hour)), c("year", "doy", "time.day2", - vars.hour)] - names(lag.day)[4:10] <- vars.lag - lag.day <- aggregate(lag.day[, vars.lag], by = lag.day[, c("year", - "doy", "time.day2")], FUN = mean) + # Specifying what hour we want to lag + # Note: For forward filtering, we want to associate today with tomorrow (+1 day) using the last observation of the day + # For backwards filtering, we want to associate today with yesterday (-1 day) using the first obs of the day + met.lag <- ifelse(direction.filter=="backwards", -1, +1) + lag.time <- ifelse(direction.filter=="backwards", min(dat.train$hour), max(dat.train$hour)) + + # Pull out just the time we're interested in + lag.day <- dat.train[dat.train$hour == lag.time, c("year", "doy", "sim.day", vars.hour)] + names(lag.day)[4:ncol(lag.day)] <- vars.lag + lag.day$lag.air_temperature_min <- aggregate(dat.train[, c("air_temperature")], - by = dat.train[, c("year", "doy", "time.day2")], FUN = min)[, "x"] # Add in a lag for the next day's min temp + by = dat.train[, c("year", "doy", "sim.day")], FUN = min)[, "x"] # Add in a lag for the next day's min temp lag.day$lag.air_temperature_max <- aggregate(dat.train[, c("air_temperature")], - by = dat.train[, c("year", "doy", "time.day2")], FUN = max)[, "x"] # Add in a lag for the next day's min temp - lag.day$time.day2 <- lag.day$time.day2 + 1 # +1 for forward filtering downscale + by = dat.train[, c("year", "doy", "sim.day")], FUN = max)[, "x"] # Add in a lag for the next day's min temp + lag.day$sim.day <- lag.day$sim.day + met.lag # - dat.train <- merge(dat.train, lag.day[, c("time.day2", vars.lag, "lag.air_temperature_min", + dat.train <- merge(dat.train, lag.day[, c("sim.day", vars.lag, "lag.air_temperature_min", "lag.air_temperature_max")], all.x = T) # ----- 1.3 Setting up a variable to 'preview' the next day's mean - # to help get smoother transitions NOTE: because we're filtering from - # the present back through the past, +1 will associate the mean for the - # next day we're going to model with the one we're currently working on + # to help get smoother transitions + # NOTE: If we're filtering forward in time, -1 will associate tomorrow with our downscaling + # for today # ---------- vars.day <- c("air_temperature_mean.day", "air_temperature_max.day", "air_temperature_mean.day", "precipitation_flux.day", "surface_downwelling_shortwave_flux_in_air.day", @@ -152,20 +183,19 @@ gen.subdaily.models <- function(outfolder, dat.train_file, in.prefix, "next.surface_downwelling_longwave_flux_in_air", "next.air_pressure", "next.specific_humidity", "next.wind_speed") - next.day <- dat.train[c("year", "doy", "time.day2", vars.day)] - names(next.day)[4:12] <- vars.next - next.day <- aggregate(next.day[, vars.next], by = next.day[, c("year", - "doy", "time.day2")], FUN = mean) - next.day$time.day2 <- next.day$time.day2 - 1 + next.day <- dat.train[c("year", "doy", "sim.day", vars.day)] + names(next.day)[4:ncol(next.day)] <- vars.next + next.day <- aggregate(next.day[, vars.next], by = next.day[, c("year", "doy", "sim.day")], FUN = mean) + next.day$sim.day <- next.day$sim.day - met.lag - dat.train <- merge(dat.train, next.day[, c("time.day2", vars.next)], - all.x = T) + dat.train <- merge(dat.train, next.day[, c("sim.day", vars.next)], all.x = T) # ----- 1.4 calculate air_temperature_min & air_temperature_max as # departure from mean; order data ---------- Lookign at max & min as # departure from mean dat.train$max.dep <- dat.train$air_temperature_max.day - dat.train$air_temperature_mean.day dat.train$min.dep <- dat.train$air_temperature_min.day - dat.train$air_temperature_mean.day + # ----- 2.1 Generating all the daily models, save the output as # .Rdata files, then clear memory Note: Could save Betas as .nc files # that we pull from as needed to save memory; but for now just leaving @@ -178,8 +208,7 @@ gen.subdaily.models <- function(outfolder, dat.train_file, in.prefix, temporal.downscale.functions(dat.train = dat.train, n.beta = n.beta, day.window = day.window, resids = resids, n.cores = n.cores, - seed = format(Sys.time(), "%m%d"), outfolder = outfolder, - in.prefix = in.prefix) + seed = seed, outfolder = outfolder) } # Helper function diff --git a/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R b/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R index e369d67e106..7591954bce7 100644 --- a/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R +++ b/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R @@ -17,21 +17,50 @@ ##' @param dat.mod - dataframe to be predicted at the time step of the training data ##' @param n.ens - number of hourly ensemble members to generate ##' @param path.model - path to where the training model & betas is stored +##' @param direction.filter - Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") +##' (PalEON will go backwards, anybody interested in the future will go forwards) ##' @param lags.init - a data frame of initialization parameters to match the data in dat.mod ##' @param dat.train - the training data used to fit the model; needed for night/day in ##' surface_downwelling_shortwave_flux_in_air +##' @param seed - (optional) set the seed manually to allow reproducible results ##' @export # ----------------------------------- #---------------------------------------------------------------------- # Begin Function #---------------------------------------------------------------------- -lm_ensemble_sims <- function(dat.mod, n.ens, path.model, lags.list = NULL, - lags.init = NULL, dat.train) { +lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags.list = NULL, + lags.init = NULL, dat.train, seed=Sys.time()) { + + # Set our random seed + set.seed(seed) + + # Setting our our time indexes + if(direction.filter=="backwards"){ + days.sim <- max(dat.mod$sim.day):min(dat.mod$sim.day) + } else { + days.sim <- min(dat.mod$sim.day):max(dat.mod$sim.day) + } + + # Declare the variables of interest that will be called in the + # overarching loop + vars.list <- c("surface_downwelling_shortwave_flux_in_air", "air_temperature", + "precipitation_flux", "surface_downwelling_longwave_flux_in_air", + "air_pressure", "specific_humidity", "wind_speed") + + # Data info that will be used to help organize dataframe for + # downscaling + dat.info <- c("sim.day", "year", "doy", "hour", "air_temperature_max.day", + "air_temperature_min.day", "precipitation_flux.day", "surface_downwelling_shortwave_flux_in_air.day", + "surface_downwelling_longwave_flux_in_air.day", "air_pressure.day", + "specific_humidity.day", "wind_speed.day", "next.air_temperature_max", + "next.air_temperature_min", "next.precipitation_flux", "next.surface_downwelling_shortwave_flux_in_air", + "next.surface_downwelling_longwave_flux_in_air", "next.air_pressure", + "next.specific_humidity", "next.wind_speed") # Set progress bar pb.index <- 1 - pb <- txtProgressBar(min = 1, max = 8, style = 3) + pb <- txtProgressBar(min = 1, max = length(vars.list)*length(days.sim), style = 3) setTxtProgressBar(pb, pb.index) # Figure out if we need to extract the approrpiate @@ -47,144 +76,143 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, lags.list = NULL, # propogated dat.sim <- list() - # Declare the variables of interest that will be called in the - # overarching loop - vars.list <- list("surface_downwelling_shortwave_flux_in_air", "air_temperature", - "precipitation_flux", "surface_downwelling_longwave_flux_in_air", - "air_pressure", "specific_humidity", "wind_speed") - - # Data info that will be used to help organize dataframe for - # downscaling - dat.info <- c("time.day", "year", "doy", "hour", "air_temperature_max.day", - "air_temperature_min.day", "precipitation_flux.day", "surface_downwelling_shortwave_flux_in_air.day", - "surface_downwelling_longwave_flux_in_air.day", "air_pressure.day", - "specific_humidity.day", "wind_speed.day", "next.air_temperature_max", - "next.air_temperature_min", "next.precipitation_flux", "next.surface_downwelling_shortwave_flux_in_air", - "next.surface_downwelling_longwave_flux_in_air", "next.air_pressure", - "next.specific_humidity", "next.wind_speed") - # ------ Beginning of Downscaling For Loop + # ------ Beginning of Downscaling For Loop for (v in vars.list) { + # Initalize our ouroutput + dat.sim[[v]] <- array(dim=c(nrow(dat.mod), n.ens)) + # create column propagation list and betas progagation list - cols.list <- list() - rows.beta <- list() + cols.list <- array(dim=c(length(days.sim), n.ens)) # An array with number of days x number of ensembles + rows.beta <- vector(length=n.ens) # A vector that ends up being the length of the number of our days - for (c in seq_len(nrow(dat.mod))) { + # This gives us a + for (i in seq_len(length(days.sim))) { cols.tem <- sample(1:n.ens, n.ens, replace = TRUE) - cols.list[(c * n.ens - n.ens + 1):(c * n.ens)] <- cols.tem + cols.list[i,] <- cols.tem } - cols.list <- as.numeric(cols.list) - + # Read in the first linear regression model - first_model <- ncdf4::nc_open(paste0(path.model, "/", v, "/betas_", - v, "_1.nc")) - first_beta <- assign(paste0("betas.", v, "_1"), first_model) - n.beta <- nrow(ncdf4::ncvar_get(first_beta, "1")) + first_model <- ncdf4::nc_open(paste0(path.model, "/", v, "/betas_", v, "_1.nc")) + # first_beta <- assign(paste0("betas.", v, "_1"), first_model) # does below need to be first_beta? + n.beta <- first_model$var[[1]]$dim[[1]]$len # Number of rows; should be same for all ncdf4::nc_close(first_model) # Create beta list so each ensemble for each variable pulls the same # betas - for (c in seq_len(nrow(dat.mod))) { - betas.tem <- sample(1:n.beta, n.ens, replace = TRUE) - rows.beta[(c * n.ens - n.ens + 1):(c * n.ens)] <- betas.tem + for (i in seq_len(length(days.sim))) { + betas.tem <- sample(1:(n.beta-n.ens), 1, replace = TRUE) + rows.beta[i] <- betas.tem } rows.beta <- as.numeric(rows.beta) # fill our dat.sim list dat.sim[[v]] <- data.frame(array(dim = c(nrow(dat.mod), n.ens))) - for (i in min(dat.mod$time.day):max(dat.mod$time.day)) { - day.now <- unique(dat.mod[dat.mod$time.day == i, "doy"]) - rows.now <- which(dat.mod$time.day == i) + # -------------------------------- + # Looping through time + # -------------------------------- + # Setting our our time indexes + if(direction.filter=="backwards"){ + days.sim <- max(dat.mod$sim.day):min(dat.mod$sim.day) + } else { + days.sim <- min(dat.mod$sim.day):max(dat.mod$sim.day) + } + + for (i in 1:length(days.sim)) { + day.now <- unique(dat.mod[dat.mod$sim.day == days.sim[i], "doy"]) + rows.now <- which(dat.mod$sim.day == days.sim[i]) # shortwave is different because we only want to model daylight if (v == "surface_downwelling_shortwave_flux_in_air") { - hrs.day <- unique(dat.train[dat.train$doy == day.now & - dat.train$surface_downwelling_shortwave_flux_in_air > - quantile(dat.train[dat.train$surface_downwelling_shortwave_flux_in_air > - 0, "surface_downwelling_shortwave_flux_in_air"], - 0.05), "hour"]) + # Finding which days have measurable light + thresh.swdown <- quantile(dat.train$surface_downwelling_shortwave_flux_in_air[dat.train$surface_downwelling_shortwave_flux_in_air > 0], 0.05) + - rows.now <- which(dat.mod$time.day == i) - rows.mod <- which(dat.mod$time.day == i & dat.mod$hour %in% - hrs.day) + hrs.day <- unique(dat.train$time[dat.train$time$DOY == day.now & + dat.train$surface_downwelling_shortwave_flux_in_air > thresh.swdown, + "Hour"]) + + rows.mod <- which(dat.mod$sim.day == days.sim[i] & dat.mod$hour %in% hrs.day) dat.temp <- dat.mod[rows.mod, dat.info] } else if (v == "air_temperature") { - rows.now <- which(dat.mod$time.day == i) dat.temp <- dat.mod[rows.now, dat.info] + # Set up the lags - if (i == min(dat.mod$time.day)) { + if (i == 1) { # First time through, so pull from our inital lags sim.lag <- stack(lags.init$air_temperature) names(sim.lag) <- c("lag.air_temperature", "ens") - sim.lag$lag.air_temperature_min <- stack(lags.init$air_temperature_min)[, - 1] - sim.lag$lag.air_temperature_max <- stack(lags.init$air_temperature_max)[, - 1] + sim.lag$lag.air_temperature_min <- stack(lags.init$air_temperature_min)[,1] + sim.lag$lag.air_temperature_max <- stack(lags.init$air_temperature_max)[,1] } else { - sim.lag <- stack(data.frame(array(dat.sim[["air_temperature"]][dat.mod$time.day == - (i - 1) & dat.mod$hour == max(unique(dat.mod$hour)), - ], dim = c(1, ncol(dat.sim$air_temperature))))) + sim.lag <- stack(data.frame(array(dat.sim[["air_temperature"]][dat.mod$sim.day == (days.sim[i - 1]) & + dat.mod$hour == max(unique(dat.mod$hour)), ], + dim = c(1, ncol(dat.sim$air_temperature))))) names(sim.lag) <- c("lag.air_temperature", "ens") - sim.lag$lag.air_temperature_min <- stack(apply(dat.sim[["air_temperature"]][dat.mod$time.day == - (i - 1), ], 2, min))[, 1] - sim.lag$lag.air_temperature_max <- stack(apply(dat.sim[["air_temperature"]][dat.mod$time.day == - (i - 1), ], 2, max))[, 1] + sim.lag$lag.air_temperature_min <- stack(apply(dat.sim[["air_temperature"]][dat.mod$sim.day == days.sim[i-1], ], 2, min))[, 1] + sim.lag$lag.air_temperature_max <- stack(apply(dat.sim[["air_temperature"]][dat.mod$sim.day == days.sim[i-1], ], 2, max))[, 1] } dat.temp <- merge(dat.temp, sim.lag, all.x = TRUE) } else if (v == "precipitation_flux") { - rows.now <- which(dat.mod$time.day == i) dat.temp <- dat.mod[rows.now, dat.info] - dat.temp[[v]] <- 99999 + dat.temp[,v] <- 99999 dat.temp$rain.prop <- 99999 day.now <- unique(dat.temp$doy) # Set up the lags This is repeated differently because Precipitation # dat.temp is merged - if (i == min(dat.mod$time.day)) { + if (i == 1) { sim.lag <- stack(lags.init[[v]]) names(sim.lag) <- c(paste0("lag.", v), "ens") } else { - sim.lag <- stack(data.frame(array(dat.sim[[v]][dat.mod$time.day == - (i - 1) & dat.mod$hour == max(unique(dat.mod$hour)), - ], dim = c(1, ncol(dat.sim[[v]]))))) + sim.lag <- stack(data.frame(array(dat.sim[[v]][dat.mod$sim.day == days.sim[i-1] & + dat.mod$hour == max(unique(dat.mod$hour)), ], + dim = c(1, ncol(dat.sim[[v]]))))) names(sim.lag) <- c(paste0("lag.", v), "ens") } dat.temp <- merge(dat.temp, sim.lag, all.x = TRUE) # End Precipitation Flux specifics } else { + dat.temp <- dat.mod[rows.now, dat.info] - if (i == min(dat.mod$time.day)) { + if (i == 1) { sim.lag <- stack(lags.init[[v]]) names(sim.lag) <- c(paste0("lag.", v), "ens") } else { - sim.lag <- stack(data.frame(array(dat.sim[[v]][dat.mod$time.day == - (i - 1) & dat.mod$hour == max(unique(dat.mod$hour)), - ], dim = c(1, ncol(dat.sim[[v]]))))) + sim.lag <- stack(data.frame(array(dat.sim[[v]][dat.mod$sim.day == days.sim[i-1] & + dat.mod$hour == max(unique(dat.mod$hour)), ], + dim = c(1, ncol(dat.sim[[v]]))))) names(sim.lag) <- c(paste0("lag.", v), "ens") } - dat.temp <- dat.mod[rows.now, dat.info] dat.temp <- merge(dat.temp, sim.lag, all.x = TRUE) - } + } # End special formatting # Create dummy value - dat.temp[[v]] <- 99999 + dat.temp[,v] <- 99999 + # Creating some necessary dummy variable names + vars.sqrt <- c("surface_downwelling_longwave_flux_in_air", "wind_speed") + vars.log <- c("specific_humidity") + if (v %in% vars.sqrt) { + dat.temp[,paste0("sqrt(",v,")")] <- sqrt(dat.temp[,v]) + } else if (v %in% vars.log) { + dat.temp[,paste0("log(",v,")")] <- log(dat.temp[,v]) + } + # Load the saved model load(file.path(path.model, v, paste0("model_", v, "_", day.now, ".Rdata"))) # Pull coefficients (betas) from our saved matrix - betas_nc <- ncdf4::nc_open(file.path(path.model, v, paste0("betas_", - v, "_", day.now, ".nc"))) - Rbeta <- as.matrix(ncdf4::ncvar_get(betas_nc, paste(day.now))[as.integer(rows.beta[(i * - n.ens - n.ens + 1):(i * n.ens)]), ], nrow = length(rows.beta), - ncol = ncol(betas_nc)) + betas_nc <- ncdf4::nc_open(file.path(path.model, v, paste0("betas_", v, "_", day.now, ".nc"))) + col.beta <- betas_nc$var[[1]]$dim[[2]]$len # number of coefficients + Rbeta <- as.matrix(ncdf4::ncvar_get(betas_nc, paste(day.now), c(rows.beta[i],1), c(n.ens,col.beta)), ncol = col.beta) ncdf4::nc_close(betas_nc) dat.pred <- subdaily_pred(newdata = dat.temp, model.predict = mod.save, Rbeta = Rbeta, resid.err = FALSE, model.resid = NULL, Rbeta.resid = NULL, @@ -204,91 +232,92 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, lags.list = NULL, if (max(dat.pred) > 0) { tmp <- 1:nrow(dat.pred) # A dummy vector of the for (j in 1:ncol(dat.pred)) { - if (min(dat.pred[, j]) >= 0) - next + if (min(dat.pred[, j]) >= 0) next # skip if no negative rain to redistribute rows.neg <- which(dat.pred[, j] < 0) rows.add <- sample(tmp[!tmp %in% rows.neg], length(rows.neg), replace = TRUE) + # Redistribute days with negative rain for (z in 1:length(rows.neg)) { - dat.pred[rows.add[z], j] <- dat.pred[rows.add[z], - j] - dat.pred[rows.neg[z], j] + dat.pred[rows.add[z], j] <- dat.pred[rows.add[z], j] - dat.pred[rows.neg[z], j] dat.pred[rows.neg[z], j] <- 0 } } - dat.pred <- dat.pred/rowSums(dat.pred) + + # Make sure each day sums to 1 + dat.pred <- dat.pred/rowSums(dat.pred, na.rm=T) dat.pred[is.na(dat.pred)] <- 0 } - # Convert precip into real units - dat.pred <- dat.pred * as.vector((dat.temp$precipitation_flux.day)) + + # Convert precip proportions into real units + dat.pred <- dat.pred * as.vector((dat.temp$precipitation_flux.day))*length(unique(dat.temp$hour)) } + # un-transforming our variables + if (v %in% vars.sqrt) { + dat.pred <- dat.pred^2 + } else if (v %in% vars.log) { + dat.pred <- exp(dat.pred) + } + + # Longwave needs some sanity bounds if (v == "surface_downwelling_longwave_flux_in_air") { - dat.pred <- dat.pred^2 # because squared to prevent negative numbers dat.pred[dat.pred < 100] <- 100 dat.pred[dat.pred > 600] <- 600 } # Specific Humidity sometimes ends up with high or infinite values if (v == "specific_humidity") { - dat.pred <- exp(dat.pred) # because log-transformed if (max(dat.pred) > 0.03) { specific_humidity.fix <- ifelse(quantile(dat.pred, 0.99) < 0.03, quantile(dat.pred, 0.99), 0.03) dat.pred[dat.pred > specific_humidity.fix] <- specific_humidity.fix } } - - # Wind speed quality control - if (v == "wind_speed") { - dat.pred <- dat.pred^2 # because square-rooted to prevent negative - } # ---------- End Quality Control - # ---------- Begin propogating values and saving values Shortwave - # Radiaiton + # ---------- + # Begin propogating values and saving values Shortwave Radiaiton + # ---------- if (v == "surface_downwelling_shortwave_flux_in_air") { # Randomly pick which values to save & propogate - cols.prop <- as.integer(cols.list[(i * n.ens - n.ens + - 1):(i * n.ens)]) + cols.prop <- as.integer(cols.list[i,]) for (j in 1:ncol(dat.sim[[v]])) { dat.sim[[v]][rows.mod, j] <- dat.pred[, cols.prop[j]] } dat.sim[[v]][rows.now[!rows.now %in% rows.mod], ] <- 0 } else if (v == "air_temperature") { - for (j in 1:ncol(dat.sim$air_temperature)) { - cols.prop <- as.integer(cols.list[(i * n.ens - n.ens + - 1):(i * n.ens)]) + cols.prop <- as.integer(cols.list[i,]) + for (j in 1:ncol(dat.sim[[v]])) { - dat.prop <- dat.pred[dat.temp$ens == paste0("X", j), - cols.prop[j]] - air_temperature_max.ens <- max(dat.temp[dat.temp$ens == - paste0("X", j), "air_temperature_max.day"]) - air_temperature_min.ens <- min(dat.temp[dat.temp$ens == - paste0("X", j), "air_temperature_min.day"]) + dat.prop <- dat.pred[dat.temp$ens == paste0("X", j), cols.prop[j]] + air_temperature_max.ens <- max(dat.temp[dat.temp$ens == paste0("X", j), "air_temperature_max.day"]) + air_temperature_min.ens <- min(dat.temp[dat.temp$ens == paste0("X", j), "air_temperature_min.day"]) - dat.prop[dat.prop > air_temperature_max.ens + 2] <- air_temperature_max.ens + - 2 - dat.prop[dat.prop < air_temperature_min.ens - 2] <- air_temperature_min.ens - - 2 + # Setting some sanity bounds on our temperatures + dat.prop[dat.prop > air_temperature_max.ens + 2] <- air_temperature_max.ens + 2 + dat.prop[dat.prop < air_temperature_min.ens - 2] <- air_temperature_min.ens - 2 dat.sim[["air_temperature"]][rows.now, j] <- dat.prop } } else { + cols.prop <- as.integer(cols.list[i,]) - cols.prop <- as.integer(cols.list[(i * n.ens - n.ens + - 1):(i * n.ens)]) for (j in 1:ncol(dat.sim[[v]])) { dat.sim[[v]][rows.now, j] <- dat.pred[dat.temp$ens == paste0("X", j), cols.prop[j]] } } rm(mod.save) # Clear out the model to save memory - } - pb.index <- pb.index + 1 - setTxtProgressBar(pb, pb.index) - } # ---------- End of downscaling for loop + + pb.index <- pb.index + 1 + setTxtProgressBar(pb, pb.index) + } # end day loop + # -------------------------------- + + } + # ---------- End of downscaling for loop return(dat.sim) } diff --git a/modules/data.atmosphere/R/tdm_predict_subdaily_met.R b/modules/data.atmosphere/R/tdm_predict_subdaily_met.R index 35cdfd801ff..ceeab2d0710 100644 --- a/modules/data.atmosphere/R/tdm_predict_subdaily_met.R +++ b/modules/data.atmosphere/R/tdm_predict_subdaily_met.R @@ -20,17 +20,20 @@ ##' @param outfolder - directory where output file will be stored ##' @param in.path - path to model dataset you wish to temporally downscale ##' @param in.prefix - prefix of model dataset, i.e. if file is GFDL.CM3.rcp45.r1i1p1.2006 the prefix is 'GFDL.CM3.rcp45.r1i1p1' -##' @param dat.train_file - location of train_data file -##' @param lm.models.base - path to linear regression model folder from 3_gen_subdaily -##' @param start_date - yyyy-mm-dd -##' @param end_date - yyyy-mm-dd -##' @param n.ens - integer selecting number of hourly ensemble members -##' @param cores.max - 12 +##' @param path.train - path to CF/PEcAn style training data where each year is in a separate file. +##' @param direction.filter - Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") +##' (PalEON will go backwards, anybody interested in the future will go forwards) +##' @param lm.models.base - path to linear regression model folders generated using gen.subdaily.models +##' @param yrs.predict - years for which you want to generate met. if NULL, all years in in.path will be done +##' @param ens.labs - vector containing the labels (suffixes) for each ensemble member; this allows you to add to your +##' ensemble rather than overwriting with a default naming scheme ##' @param resids - logical stating whether to pass on residual data or not ##' @param parallel - logical stating whether to run temporal_downscale_functions.R in parallel +##' @param cores.max - 12 ##' @param n.cores - deals with parallelization ##' @param overwrite ##' @param verbose +##' @param seed - manually set seed for results to be reproducible ##' @export ##' @examples ##' \dontrun{ @@ -46,275 +49,251 @@ ##' n.ens = 3} # ----------------------------------- #---------------------------------------------------------------------- -# Begin Fcript +# Begin Script #---------------------------------------------------------------------- -predict_subdaily_met <- function(outfolder, in.path, in.prefix, lm.models.base, - dat.train_file, start_date, end_date, cores.max = 12, - n.ens = 3, resids = FALSE, parallel = FALSE, n.cores = NULL, - overwrite = FALSE, verbose = FALSE) { - - years <- seq(lubridate::year(start_date), lubridate::year(end_date)) - - # Load the training dataset and make sure to pull in dimensions and - # save as dim - vars.info <- data.frame(CF.name = c("air_temperature", "precipitation_flux", - "air_temperature_max", "air_temperature_min", "surface_downwelling_shortwave_flux_in_air", - "surface_downwelling_longwave_flux_in_air", "air_pressure", "specific_humidity", - "eastward_wind", "northward_wind", "wind_speed")) - dat.train <- list() - tem <- ncdf4::nc_open(dat.train_file) - dim <- tem$dim - lat.in <- dim$latitude$vals - lon.in <- dim$longitude$vals - for (j in seq_along(vars.info$CF.name)) { - if (exists(as.character(vars.info$CF.name[j]), tem$var)) { - dat.train[[j]] <- ncdf4::ncvar_get(tem, as.character(vars.info$CF.name[j])) - } else { - dat.train[[j]] <- NA - } - } - names(dat.train) <- vars.info$CF.name - dat.train <- data.frame(dat.train) - +predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, direction.filter, lm.models.base, + yrs.predict, ens.labs = 1:3, resids = FALSE, + parallel = FALSE, cores.max = 12, n.cores = NULL, + overwrite = FALSE, verbose = FALSE, seed=format(Sys.time(), "%m%d"), ...) { + + vars.hour <- c("air_temperature", "precipitation_flux", "surface_downwelling_shortwave_flux_in_air", + "surface_downwelling_longwave_flux_in_air", "air_pressure", "specific_humidity", + "wind_speed") + vars.lag <- c("lag.air_temperature", "lag.precipitation_flux", "lag.surface_downwelling_shortwave_flux_in_air", + "lag.surface_downwelling_longwave_flux_in_air", "lag.air_pressure", + "lag.specific_humidity", "lag.wind_speed") + + n.ens <- length(ens.labs) + + # Getting a list of all files/years we want to downscale + files.tdm <- dir(in.path, ".nc") + + yrs.tdm <- strsplit(files.tdm, "[.]") + yrs.tdm <- matrix(unlist(yrs.tdm), ncol=length(yrs.tdm[[1]]), byrow=T) + yrs.tdm <- as.numeric(yrs.tdm[,ncol(yrs.tdm)-1]) # Assumes year is always last thing before the file extension + + if(!is.null(yrs.predict)){ + yrs.tdm <- files.tdm[which(yrs.tdm %in% yrs.predict)] + yrs.tdm <- yrs.tdm[which(yrs.tdm %in% yrs.predict)] + } + + # make sure files and years are ordered in the direction we want to go + if(direction.filter=="backwards"){ + yrs.tdm <- yrs.tdm[order(yrs.tdm, decreasing = T)] + files.tdm <- files.tdm[order(files.tdm, decreasing = T)] + } + + met.lag <- ifelse(direction.filter=="backwards", -1, +1) + + # Create wind speed variable if it doesn't exist + if (all(is.na(dat.train$wind_speed) == TRUE)) { + dat.train$wind_speed <- sqrt(dat.train$eastward_wind^2 + dat.train$northward_wind^2) + } + + + # Defining variable names, longname & units + nc.info <- data.frame(CF.name = c("air_temperature", "precipitation_flux", + "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", + "air_pressure", "specific_humidity", "wind_speed"), longname = c("2 meter mean air temperature", + "cumulative precipitation (water equivalent)", "incident (downwelling) showtwave radiation", + "incident (downwelling) longwave radiation", "air_pressureure at the surface", + "Specific humidity measured at the lowest level of the atmosphere", + "Wind speed"), units = c("K", "kg m-2 s-1", "W m-2", "W m-2", "Pa", + "kg kg-1", "m s-1")) + + # ---------------------------------- + for (y in 1:length(yrs.tdm)) { + + # Read in the data and dupe it into the temporal resolution we want to end up with (based on our training data) + files.train <- dir(train.path, ".nc") + + yrs.file <- strsplit(files.train, "[.]") + yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) + yrs.file <- as.numeric(yrs.file[,ncol(yrs.file)-1]) # Assumes year is always last thing before the file extension + yrs.file <- yrs.file[length(yrs.file)/2] + + met.out <- align.met(train.path=path.train, source.path=in.path, yrs.train=NULL, yrs.source=yrs.tdm[y], n.ens=1, seed=201708, pair.mems = FALSE) + + # Package the raw data into the dataframe that will get passed into the function + dat.ens <- data.frame(year = met.out$dat.source$time$Year, + doy = met.out$dat.source$time$DOY, + date = met.out$dat.source$time$Date, + hour = met.out$dat.source$time$Hour, + air_temperature_max.day = met.out$dat.source$air_temperature_maximum, + air_temperature_min.day = met.out$dat.source$air_temperature_minimum, + precipitation_flux.day = met.out$dat.source$precipitation_flux, + surface_downwelling_shortwave_flux_in_air.day = met.out$dat.source$surface_downwelling_shortwave_flux_in_air, + surface_downwelling_longwave_flux_in_air.day = met.out$dat.source$surface_downwelling_longwave_flux_in_air, + air_pressure.day = met.out$dat.source$air_pressure, + specific_humidity.day = met.out$dat.source$specific_humidity, + wind_speed.day = met.out$dat.source$wind_speed) + # Create wind speed variable if it doesn't exist - if (all(is.na(dat.train$wind_speed) == TRUE)) { - dat.train$wind_speed <- sqrt(dat.train$eastward_wind^2 + dat.train$northward_wind^2) + # if (all(is.na(dat.train$wind_speed) == TRUE)) { + # dat.train$wind_speed <- sqrt(dat.train$eastward_wind^2 + dat.train$northward_wind^2) + # } + + # Set up our simulation time variables; it *should* be okay that this resets each year since it's really only doy that matters + dat.ens$sim.hr <- trunc(as.numeric(difftime(dat.ens$date, min(dat.ens$date), tz = "GMT", units = "hour")))+1 + dat.ens$sim.day <- trunc(as.numeric(difftime(dat.ens$date, min(dat.ens$date), tz = "GMT", units = "day")))+1 + # lag.time <- ifelse(direction.filter=="backwards", min(dat.train$hour), max(dat.train$hour)) + + # ------------------------------ + # If this is our first time through, we need to initalize our lags; + # we can do so with the data we extracted with met.out + # ------------------------------ + # Figure out whether we want to use the first or last value to initalize our lags + # Note: Data should be ordered Jan 1 -> Dec 31; If we're moving backwards, we start with + # Dec 31 and we'll want to pull Jan 1. If we're going forward, we want the opposite + lag.use <- ifelse(direction.filter=="backwards", 1, nrow(met.out$dat.source$time)) + if(y == 1){ + lags.init <- list() + + lags.init[["air_temperature"]] <- data.frame(array(mean(met.out$dat.source$air_temperature_maximum[lag.use], met.out$dat.source$air_temperature_minimum[lag.use]), dim=c(1, n.ens))) + lags.init[["air_temperature_min"]] <- data.frame(array(met.out$dat.source$air_temperature_minimum[lag.use], dim=c(1, n.ens))) + lags.init[["air_temperature_max"]] <- data.frame(array(met.out$dat.source$air_temperature_minimum[lag.use], dim=c(1, n.ens))) + for(v in vars.hour[2:length(vars.hour)]){ + lags.init[[v]] <- data.frame(array(met.out$dat.source[[v]][lag.use], dim=c(1,n.ens))) + } } - - # Create a date variable that will help us organize our workflow - if (dim$time$units == "sec") { - sub_string <- substrRight(dat.train_file, 7) - start_year <- substr(sub_string, 1, 4) - dat.train$date <- as.POSIXct(dim$time$vals, tz = "GMT", origin = paste0(start_year, - "-01-01 ", udunits2::ud.convert(dim$time$vals[1], "seconds", - "hour"), ":00:00")) + # ------------------------------ + + # ------------------------------ + # Set up the "next" values + # Unless this is our last year one of the values should be pulled from the next year to process + # Using align.met because it's making life a bit easier + # ------------------------------ + # As long as we're not at the end, we can use align.met to pull the appropriate files; temporal resolution doesn't really matter here + # Note: This gets us everything at the native daily resolution + if(y < length(yrs.tdm)){ + met.nxt <- align.met(train.path=in.path, source.path=in.path, yrs.train=yrs.tdm[y], yrs.source=yrs.tdm[y+1], n.ens=1, seed=201708, pair.mems = FALSE) } else { - start_year <- substr(dim$time$units, start = 12, stop = 15) - dat.train$date <- as.POSIXct(udunits2::ud.convert((dim$time$vals - - ((dim$time$vals[2] - dim$time$vals[1])/2)), "days", "seconds"), - tz = "GMT", origin = paste0(start_year, "-01-01 ", udunits2::ud.convert(dim$time$vals[1], - "days", "hours"), ":00:00")) + # Yes, this is redundant, but it works and helps keep me sane + met.nxt <- align.met(train.path=in.path, source.path=in.path, yrs.train=yrs.tdm[y], yrs.source=yrs.tdm[y], n.ens=1, seed=201708, pair.mems = FALSE) } - - dat.train$year <- lubridate::year(dat.train$date) - dat.train$doy <- lubridate::yday(dat.train$date) - dat.train$hour <- lubridate::hour(dat.train$date) - - df.hour <- data.frame(hour = unique(dat.train$hour)) # match this to whatever your 'hourly' timestep is - - # Set up the appropriate seed - set.seed(format(Sys.time(), "%m%d")) - seed.vec <- sample.int(1e+06, size = 500, replace = F) - - # Defining variable names, longname & units - nc.info <- data.frame(CF.name = c("air_temperature", "precipitation_flux", - "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", - "air_pressure", "specific_humidity", "wind_speed"), longname = c("2 meter mean air temperature", - "cumulative precipitation (water equivalent)", "incident (downwelling) showtwave radiation", - "incident (downwelling) longwave radiation", "air_pressureure at the surface", - "Specific humidity measured at the lowest level of the atmosphere", - "Wind speed"), units = c("K", "kg m-2 s-1", "W m-2", "W m-2", "Pa", - "kg kg-1", "m s-1")) - # ---------------------------------- - for (y in years) { - - path.gcm <- file.path(in.path, paste0(in.prefix, ".", y, ".nc")) - - # ----------------------------------- 1. Format output so all ensemble - # members can be run at once NOTE: Need to start with the last and work - # to the first ----------------------------------- - - # Read the lags - nc.now <- ncdf4::nc_open(path.gcm) - nc.time <- ncdf4::ncvar_get(nc.now, "time") - - for (j in seq_along(vars.info$CF.name)) { - if (exists(as.character(vars.info$CF.name[j]), tem$var)) { - lags.list[[j]] <- ncdf4::ncvar_get(nc.now, as.character(vars.info$CF.name[j])) - } else { - lags.list[[j]] <- NA - } - } - names(lags.list) <- vars.info$CF.name - lags.list <- data.frame(lags.list) - - # Define the lags.init list, the values that will initialize the entire - # downscaling procedure - lags.init <- list() - for (v in vars.info$CF.name) { - if (all(is.na(lags.list$air_temperature))) { - lags.init[[v]] <- data.frame(array((dat.yr$air_temperature_max + - dat.yr$air_temperature_min)/2), dim = c(1, n.ens)) - } - if (all(is.na(lags.list$wind_speed))) { - lags.init[[v]] <- data.frame(array(sqrt((lags.list$eastward_wind^2) + - (lags.list$northward_wind^2)), dim = c(1, n.ens))) - } else { - lags.init[[v]] <- data.frame(array(lags.list[[v]], dim = c(1, - n.ens))) - } - } - - - # Now we read in the data we wish to downscale and leave it as is - dat.ens <- list() # a new list for each ensemble member as a new layer - ens.sims <- list() # this will propogate that spread through each year, so instead of - # restarting every January 1, it will propogate those lag values - - # Create a list layer for each ensemble member - dat.yr <- list() - nc.now <- ncdf4::nc_open(path.gcm) - dim <- nc.now$dim - for (j in seq_along(vars.info$CF.name)) { - if (exists(as.character(vars.info$CF.name[j]), tem$var)) { - dat.yr[[j]] <- ncdf4::ncvar_get(nc.now, as.character(vars.info$CF.name[j])) - } else { - dat.yr[[j]] <- NA - } - } - names(dat.yr) <- vars.info$CF.name - dat.yr <- data.frame(dat.yr) - - # We need to fill these variables if they aren't available - if (all(is.na(dat.yr$air_temperature))) { - dat.yr$air_temperature <- ((dat.yr$air_temperature_max + dat.yr$air_temperature_min)/2) - } - if (all(is.na(dat.yr$wind_speed))) { - dat.yr$wind_speed <- sqrt(dat.yr$eastward_wind^2 + dat.yr$northward_wind^2) - } - ncdf4::nc_close(nc.now) - - # We need to create a date variable to help us organize everything - dat.yr$year <- y - if (dim$time$units == "sec") { - dat.yr$date <- as.Date((dim$time$vals/(dim$time$vals[2] - dim$time$vals[1])), - tz = "GMT", origin = paste0(y - 1, "-12-31")) - } - if (dim$time$units == paste0("days since ", y, "-01-01T00:00:00Z")) { - dat.train$date <- as.POSIXct(udunits2::ud.convert((dim$time$vals - - ((dim$time$vals[2] - dim$time$vals[1])/2)), "days", "seconds"), - tz = "GMT", origin = paste0(y, "-01-01 00:00:00")) + + dat.nxt <- data.frame(year = met.nxt$dat.train$time$Year, + doy = met.nxt$dat.train$time$DOY-met.lag, + next.air_temperature_max = met.nxt$dat.train$air_temperature_maximum, + next.air_temperature_min = met.nxt$dat.train$air_temperature_minimum, + next.precipitation_flux = met.nxt$dat.train$precipitation_flux, + next.surface_downwelling_shortwave_flux_in_air = met.nxt$dat.train$surface_downwelling_shortwave_flux_in_air, + next.surface_downwelling_longwave_flux_in_air = met.nxt$dat.train$surface_downwelling_longwave_flux_in_air, + next.air_pressure = met.nxt$dat.train$air_pressure, + next.specific_humidity = met.nxt$dat.train$specific_humidity, + next.wind_speed = met.nxt$dat.train$wind_speed) + + if(direction.filter=="backwards"){ + # If we're filtering BACKWARDS, and starting with Dec. 31 of yrs.tdm[1] the first "next" is Dec. 30 (doy - 1) + # Jan 1 then needs the "next" pulled from the LAST row of yrs.tdm[2] + row.last <- nrow(met.nxt$dat.source$time) + dat.nxt2 <- data.frame(year = met.nxt$dat.train$time$Year[1], + doy = met.nxt$dat.train$time$DOY[1], + next.air_temperature_max = met.nxt$dat.source$air_temperature_maximum[row.last], + next.air_temperature_min = met.nxt$dat.source$air_temperature_minimum[row.last], + next.precipitation_flux = met.nxt$dat.source$precipitation_flux[row.last], + next.surface_downwelling_shortwave_flux_in_air = met.nxt$dat.source$surface_downwelling_shortwave_flux_in_air[row.last], + next.surface_downwelling_longwave_flux_in_air = met.nxt$dat.source$surface_downwelling_longwave_flux_in_air[row.last], + next.air_pressure = met.nxt$dat.source$air_pressure[row.last], + next.specific_humidity = met.nxt$dat.source$specific_humidity[row.last], + next.wind_speed = met.nxt$dat.source$wind_speed[row.last]) + dat.nxt <- rbind(dat.nxt2, dat.nxt[1:(nrow(dat.nxt)-1),]) + } else { + # If we're filtering FORWRDS, and starting with Jan 1 of yrs.tdm[1] the first "next" is Jan 2 (doy + 1) + # Dec. 31 then needs the "next" pulled from the FIRST row of yrs.tdm[2] + row.last <- nrow(met.nxt$dat.train$time) + dat.nxt2 <- data.frame(year = met.nxt$dat.train$time$Year[row.last], + doy = met.nxt$dat.train$time$DOY[row.last], + next.air_temperature_max = met.nxt$dat.source$air_temperature_maximum[1], + next.air_temperature_min = met.nxt$dat.source$air_temperature_minimum[1], + next.precipitation_flux = met.nxt$dat.source$precipitation_flux[1], + next.surface_downwelling_shortwave_flux_in_air = met.nxt$dat.source$surface_downwelling_shortwave_flux_in_air[1], + next.surface_downwelling_longwave_flux_in_air = met.nxt$dat.source$surface_downwelling_longwave_flux_in_air[1], + next.air_pressure = met.nxt$dat.source$air_pressure[1], + next.specific_humidity = met.nxt$dat.source$specific_humidity[1], + next.wind_speed = met.nxt$dat.source$wind_speed[1]) + dat.nxt <- rbind(dat.nxt[2:nrow(dat.nxt),], dat.nxt2) + } + + # Merging the next into our ensemble data + dat.ens <- merge(dat.ens, dat.nxt, all.x=T) + # ------------------------------ + + + # ----------------------------------- + # 2. Predict met vars for each ensemble member + # Note: Right now this is only set up to do members sequentially, but there is + # potential to parallelize + # ----------------------------------- + + ens.sims <- lm_ensemble_sims(dat.mod = dat.ens, n.ens = n.ens, + path.model = file.path(lm.models.base), lags.list = NULL, + lags.init = lags.init, + direction.filter=direction.filter, + dat.train = met.out$dat.train, seed=seed) + + # ----------------------------------- + + + + for(v in names(ens.sims)) { + lags.init[[v]] <- data.frame(ens.sims[[v]][length(ens.sims[[v]]),]) + } + + # Set up the time dimension for this year + hrs.now <- as.numeric(difftime(dat.ens$date, paste0(yrs.tdm[y], "-01-01"), + tz = "GMT", units = "hour")) + + # Write each year for each ensemble member into its own .nc file + lat <- ncdf4::ncdim_def(name = "latitude", units = "degree_north", + vals = lat.in, create_dimvar = TRUE) + lon <- ncdf4::ncdim_def(name = "longitude", units = "degree_east", + vals = lon.in, create_dimvar = TRUE) + + ntime <- nrow(dat.ens) + # diy <- PEcAn.utils::days_in_year(yrs.tdm[y]) + diy <- ifelse(lubridate::leap_year(yrs.tdm[y]), 366, 365) + days_elapsed <- (seq_len(ntime) * diy / ntime) - (0.5 * diy / ntime) + time <- ncdf4::ncdim_def(name = "time", units = paste0("days since ", + yrs.tdm[y], "-01-01T00:00:00Z"), vals = as.array(days_elapsed), create_dimvar = TRUE, + unlim = TRUE) + + dim <- list(lat, lon, time) + + var.list <- list() + for (j in seq_along(nc.info$CF.name)) { + var.list[[j]] <- ncdf4::ncvar_def(name = as.character(nc.info$CF.name[j]), + units = as.character(nc.info$units[j]), dim = dim, missval = -9999, + verbose = verbose) + } # End j loop + + for (i in seq_len(n.ens)) { + df <- data.frame(matrix(ncol = length(nc.info$name), nrow = nrow(dat.ens))) + colnames(df) <- nc.info$name + for (j in nc.info$CF.name) { + ens.sims[[j]][["X1"]] + e <- paste0("X", i) + df[[j]] <- ens.sims[[j]][[e]] } - dat.yr$doy <- lubridate::yday(dat.yr$date) - # Create the data frame for the 'next' values - dat.nxt <- dat.yr - # Shift everyting up by a day to get the preview of the next day - dat.nxt[2:(nrow(dat.nxt)), c("air_temperature_max", "air_temperature_min", - "precipitation_flux", "surface_downwelling_shortwave_flux_in_air", + df <- df[, c("air_temperature", "precipitation_flux", "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", "air_pressure", - "specific_humidity", "wind_speed")] <- dat.nxt[1:(nrow(dat.nxt) - - 1), c("air_temperature_max", "air_temperature_min", "precipitation_flux", - "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", - "air_pressure", "specific_humidity", "wind_speed")] - - # Need to add in the 'next' value Note: if we're past the end of our - # daily data, the best we can do is leave things as is (copy the last - # day's value) - if (y < max(years)) { + "specific_humidity", "wind_speed")] + colnames(df) <- nc.info$CF.name - path.gcm <- file.path(in.path, paste0(in.prefix, ".", y + 1, - ".nc")) - nc.nxt <- ncdf4::nc_open(path.gcm) + dir.create(outfolder, showWarnings = FALSE, recursive = TRUE) + loc.file <- file.path(outfolder, paste0(in.prefix, "_ens", + ens.labs[i], "_", yrs.tdm[y], ".nc")) + loc <- ncdf4::nc_create(filename = loc.file, vars = var.list, + verbose = verbose) - dat.nxt$time <- ncdf4::ncvar_get(nc.nxt, "time") - for (j in vars.info$CF.name) { - dat.nxt[dat.nxt$time == max(dat.nxt$time), j] <- ncdf4::ncvar_get(nc.nxt, - j)[length(nxt.time)] - } - ncdf4::nc_close(nc.nxt) + for (j in nc.info$CF.name) { + ncdf4::ncvar_put(nc = loc, varid = as.character(j), vals = df[[j]][seq_len(nrow(df))]) } + ncdf4::nc_close(loc) + } # End writing ensemble members + print(paste0("finished year ", yrs.tdm[y])) - # Now we put everything into 1 main data.frame - dat.ens <- data.frame(year = dat.yr$year, doy = dat.yr$doy, date = dat.yr$date, - air_temperature_max.day = dat.yr$air_temperature_max, air_temperature_min.day = dat.yr$air_temperature_min, - precipitation_flux.day = dat.yr$precipitation_flux, surface_downwelling_shortwave_flux_in_air.day = dat.yr$surface_downwelling_shortwave_flux_in_air, - surface_downwelling_longwave_flux_in_air.day = dat.yr$surface_downwelling_longwave_flux_in_air, - air_pressure.day = dat.yr$air_pressure, specific_humidity.day = dat.yr$specific_humidity, - wind_speed.day = dat.yr$wind_speed, next.air_temperature_max = dat.nxt$air_temperature_max, - next.air_temperature_min = dat.nxt$air_temperature_min, next.precipitation_flux = dat.nxt$precipitation_flux, - next.surface_downwelling_shortwave_flux_in_air = dat.nxt$surface_downwelling_shortwave_flux_in_air, - next.surface_downwelling_longwave_flux_in_air = dat.nxt$surface_downwelling_longwave_flux_in_air, - next.air_pressure = dat.nxt$air_pressure, next.specific_humidity = dat.nxt$specific_humidity, - next.wind_speed = dat.nxt$wind_speed) - - dat.ens$time.day <- as.numeric(difftime(dat.ens$date, paste0(y - - 1, "-12-31"), tz = "GMT", units = "day")) - dat.ens <- merge(dat.ens, df.hour, all = T) - - dat.ens$date <- strptime(paste(dat.ens$year, dat.ens$doy, dat.ens$hour, - sep = "-"), "%Y-%j-%H", tz = "GMT") - dat.ens$time.hr <- as.numeric(difftime(dat.ens$date, paste0(y - - 1, "-12-31"), tz = "GMT", units = "hour")) #+ minute(dat.train$date)/60 - dat.ens <- dat.ens[order(dat.ens$time.hr), ] - - # ----------------------------------- 2. Predict met vars for each - # ensemble member Note: Using a loop for each ensemble member for now, - # but this will get parallelized to speed it up soon, but we'll - # prototype in parallel ----------------------------------- - - ens.sims <- lm_ensemble_sims(dat.ens, n.ens = n.ens, - path.model = file.path(lm.models.base), lags.list = NULL, lags.init = lags.init, - dat.train = dat.train) - - # Set up the time dimension for this year - hrs.now <- as.numeric(difftime(dat.ens$date, paste0(y, "-01-01"), - tz = "GMT", units = "hour")) - - for (v in names(ens.sims)) { - lags.init[[v]] <- data.frame(ens.sims[[v]][length(ens.sims[[v]]), - ]) - } - - # Write each year for each ensemble member into its own .nc file - lat <- ncdf4::ncdim_def(name = "latitude", units = "degree_north", - vals = lat.in, create_dimvar = TRUE) - lon <- ncdf4::ncdim_def(name = "longitude", units = "degree_east", - vals = lon.in, create_dimvar = TRUE) - - ntime <- nrow(dat.ens) - diy <- PEcAn.utils::days_in_year(y) - days_elapsed <- (seq_len(ntime) * diy / ntime) - (0.5 * diy / ntime) - time <- ncdf4::ncdim_def(name = "time", units = paste0("days since ", - y, "-01-01T00:00:00Z"), vals = as.array(days_elapsed), create_dimvar = TRUE, - unlim = TRUE) - - dim <- list(lat, lon, time) - - var.list <- list() - for (j in seq_along(nc.info$CF.name)) { - var.list[[j]] <- ncdf4::ncvar_def(name = as.character(nc.info$CF.name[j]), - units = as.character(nc.info$units[j]), dim = dim, missval = -9999, - verbose = verbose) - } - - for (i in seq_len(n.ens)) { - df <- data.frame(matrix(ncol = length(nc.info$name), nrow = nrow(dat.ens))) - colnames(df) <- nc.info$name - for (j in nc.info$CF.name) { - ens.sims[[j]][["X1"]] - e <- paste0("X", i) - df[[j]] <- ens.sims[[j]][[e]] - } - - df <- df[, c("air_temperature", "precipitation_flux", "surface_downwelling_shortwave_flux_in_air", - "surface_downwelling_longwave_flux_in_air", "air_pressure", - "specific_humidity", "wind_speed")] - colnames(df) <- nc.info$CF.name - - dir.create(outfolder, showWarnings = FALSE, recursive = TRUE) - loc.file <- file.path(outfolder, paste0(in.prefix, "_ens", - i, "_", y, ".nc")) - loc <- ncdf4::nc_create(filename = loc.file, vars = var.list, - verbose = verbose) - - for (j in nc.info$CF.name) { - ncdf4::ncvar_put(nc = loc, varid = as.character(j), vals = df[[j]][seq_len(nrow(df))]) - } - ncdf4::nc_close(loc) - } - print(paste0("finished year ", y)) - - } -} + } # End year loop +} # End function diff --git a/modules/data.atmosphere/R/tdm_subdaily_pred.R b/modules/data.atmosphere/R/tdm_subdaily_pred.R index 934f02ae6ae..a5b4e291d08 100644 --- a/modules/data.atmosphere/R/tdm_subdaily_pred.R +++ b/modules/data.atmosphere/R/tdm_subdaily_pred.R @@ -41,17 +41,15 @@ subdaily_pred <- function(newdata, model.predict, Rbeta, resid.err = FALSE, mode if (resid.err == TRUE) { newdata$resid <- 99999 - resid.terms <- terms(model.resid) - resid.coef <- coef(model.resid) - resid.cov <- vcov(model.resid) - resid.resid <- resid(model.resid) - resid.piv <- as.numeric(which(!is.na(resid.coef))) - - m2 <- model.frame(resid.terms, newdata, xlev = model.resid$xlevels) - Xp.res <- model.matrix(resid.terms, m2, contrasts.arg = model.resid$contrasts) - + resid.piv <- as.numeric(which(!is.na(model.resid$coef))) + + model.resid$factors[model.resid$factors=="as.ordered(hour)"] <- "hour" + resid.m <- newdata[,model.resid$factors] + resid.m[,"as.ordered(hour)"] <- resid.m$hour + if(length(df.hr$hour)!= length(resid.m$hour)) resid.m <- merge(resid.m, df.hr, all=T) + Xp.res <- model.matrix(eval(model.resid$formula), resid.m, contrasts.arg=model.resid$contr) err.resid <- Xp.res[, resid.piv] %*% t(Rbeta.resid) - } + } # End residual error dat.sim <- Xp[, piv] %*% t(Rbeta) + err.resid diff --git a/modules/data.atmosphere/R/tdm_temporal_downscale_functions.R b/modules/data.atmosphere/R/tdm_temporal_downscale_functions.R index db02d205dad..8c18bb9bd84 100644 --- a/modules/data.atmosphere/R/tdm_temporal_downscale_functions.R +++ b/modules/data.atmosphere/R/tdm_temporal_downscale_functions.R @@ -27,14 +27,14 @@ ##' @param day.window - number of days surrounding current day we want to pull ##' statistics from ##' @param seed - allows this to be reproducible +##' @param outfoulder = where the output should be stored ##' @export # ----------------------------------- #---------------------------------------------------------------------- # Begin Function #---------------------------------------------------------------------- temporal.downscale.functions <- function(dat.train, n.beta, day.window, - resids = FALSE, parallel = FALSE, n.cores = NULL, seed = format(Sys.time(), - "%m%d"), outfolder, in.prefix, ...) { + resids = FALSE, parallel = FALSE, n.cores = NULL, seed = format(Sys.time(), "%m%d"), outfolder, ...) { pb.index <- 1 pb <- txtProgressBar(min = 1, max = 8, style = 3) @@ -42,7 +42,7 @@ temporal.downscale.functions <- function(dat.train, n.beta, day.window, # Declare the variables of interest that will be called in the # overarching loop - vars.list <- list("surface_downwelling_shortwave_flux_in_air", "air_temperature", + vars.list <- c("surface_downwelling_shortwave_flux_in_air", "air_temperature", "precipitation_flux", "surface_downwelling_longwave_flux_in_air", "air_pressure", "specific_humidity", "wind_speed") @@ -61,7 +61,7 @@ temporal.downscale.functions <- function(dat.train, n.beta, day.window, for (v in vars.list) { # Define the path - path.out <- paste0(outfolder, "/",in.prefix, "/", v) + path.out <- file.path(outfolder, v) # Set our seed set.seed(seed) @@ -90,75 +90,137 @@ temporal.downscale.functions <- function(dat.train, n.beta, day.window, # ----- generate the mod.out file if (parallel) { - warning("Running model calculation in parallel. This WILL crash if you do not have access to a LOT of memory!") + warning("Running model calculation in parallel. This will probably crash if you do not have access to a LOT of memory!") + + if (v == "surface_downwelling_shortwave_flux_in_air") { + mod.out <- parallel::mclapply(dat.list, model.train, mc.cores = n.cores, + n.beta = n.beta, resids = resids, threshold = quantile(dat.train[dat.train$surface_downwelling_shortwave_flux_in_air > + 0, "surface_downwelling_shortwave_flux_in_air"], 0.05)) + } else { + mod.out <- parallel::mclapply(dat.list, model.train, mc.cores = n.cores, + n.beta = n.beta, resids = resids) + } + + - if (v == "surface_downwelling_shortwave_flux_in_air") { - mod.out <- parallel::mclapply(dat.list, model.train, mc.cores = n.cores, - n.beta = n.beta, resids = resids, threshold = quantile(dat.train[dat.train$surface_downwelling_shortwave_flux_in_air > - 0, "surface_downwelling_shortwave_flux_in_air"], 0.05)) - } else { - mod.out <- parallel::mclapply(dat.list, model.train, mc.cores = n.cores, - n.beta = n.beta, resids = resids) - } - - - - # Use a loop to sace each day of year independently - for (i in names(mod.out)) { - # Save the betas as .nc - outfile <- file.path(path.out, paste0("betas_", v, "_", - i, ".nc")) - dimY <- ncdf4::ncdim_def(paste0("coeffs_", i), units = "unitless", - longname = "model.out coefficients", vals = 1:ncol(mod.out[[i]][["betas"]])) - dimX <- ncdf4::ncdim_def("random", units = "unitless", - longname = "random betas", vals = 1:nrow(mod.out[[i]][["betas"]])) - var.list <- ncdf4::ncvar_def(i, units = "coefficients", - dim = list(dimX, dimY), longname = paste0("day ", i, - " model.out coefficients")) - nc <- ncdf4::nc_create(outfile, var.list) - ncdf4::ncvar_put(nc, var.list, mod.out[[i]][["betas"]]) - ncdf4::nc_close(nc) + # Use a loop to save each day of year independently + for (i in names(mod.out)) { + # Save the betas as .nc + outfile <- file.path(path.out, paste0("betas_", v, "_", + i, ".nc")) + dimY <- ncdf4::ncdim_def(paste0("coeffs_", i), units = "unitless", + longname = "model.out coefficients", vals = 1:ncol(mod.out[[i]][["betas"]])) + dimX <- ncdf4::ncdim_def("random", units = "unitless", + longname = "random betas", vals = 1:nrow(mod.out[[i]][["betas"]])) + var.list <- ncdf4::ncvar_def(i, units = "coefficients", + dim = list(dimX, dimY), longname = paste0("day ", i, + " model.out coefficients")) + nc <- ncdf4::nc_create(outfile, var.list) + ncdf4::ncvar_put(nc, var.list, mod.out[[i]][["betas"]]) + ncdf4::nc_close(nc) + + # Save the model as a .Rdata + mod.save <- list() + mod.save$call <- mod.out[[i]]$model$call + mod.save$coef <- coef(mod.out[[i]]$model) + mod.save$formula <- parse(text=mod.out[[i]]$model$call[[2]][c(1,3)]) + mod.save$factors <- rownames(attr(mod.out[[i]]$model$terms, "factors")) + mod.save$xlev <- mod.out[[i]]$model$xlevels + mod.save$contr <- mod.out[[i]]$model$contrasts + save(mod.save, file = file.path(path.out, paste0("model_", + v, "_", i, ".Rdata"))) - # Save the model as a .Rdata - mod.save <- mod.out[[i]][["model"]] - save(mod.save, file = file.path(path.out, paste0("model_", - v, "_", i, ".Rdata"))) - } - - } else { + if(resids) { + # Save the betas as .nc + outfile <- file.path(path.out, paste0("resids_betas_", v, "_", + i, ".nc")) + dimY <- ncdf4::ncdim_def(paste0("coeffs_", i), units = "unitless", + longname = "model.out coefficients", vals = 1:ncol(mod.out[[i]][["betas.resid"]])) + dimX <- ncdf4::ncdim_def("random", units = "unitless", + longname = "random betas", vals = 1:nrow(mod.out[[i]][["betas.resid"]])) + var.list <- ncdf4::ncvar_def(i, units = "coefficients", + dim = list(dimX, dimY), longname = paste0("day ", i, + "resid model.out coefficients")) + nc <- ncdf4::nc_create(outfile, var.list) + ncdf4::ncvar_put(nc, var.list, mod.out[[i]][["betas.resid"]]) + ncdf4::nc_close(nc) + + # Save the model as a .Rdata + mod.save <- list() + mod.save$call <- mod.out[[i]]$model.resid$call + mod.save$coef <- coef(mod.out[[i]]$model.resid) + mod.save$formula <- parse(text=mod.out[[i]]$model.resid$call[[2]][c(1,3)]) + mod.save$factors <- rownames(attr(mod.out[[i]]$model.resid$terms, "factors")) + mod.save$xlev <- mod.out[[i]]$model.resid$xlevels + mod.save$contr <- mod.out[[i]]$model.resid$contrasts + save(mod.save, file = file.path(path.out, paste0("resids_model_", + v, "_", i, ".Rdata"))) + } # End resids case + } # End save loop + + } else { # Doing this is series for (i in names(dat.list)) { - if (v == "surface_downwelling_shortwave_flux_in_air") { - mod.out <- model.train(dat.subset = dat.list[[i]], n.beta = n.beta, v = v, threshold = quantile(dat.train[dat.train$surface_downwelling_shortwave_flux_in_air > - 0, "surface_downwelling_shortwave_flux_in_air"], 0.05), - n.beta, resids = resids) - } else { - mod.out <- model.train(dat.subset = dat.list[[i]], n.beta = n.beta, v = v, - resids = resids) - } + if (v == "surface_downwelling_shortwave_flux_in_air") { + mod.out <- model.train(dat.subset = dat.list[[i]], n.beta = n.beta, v = v, + threshold = quantile(dat.train[dat.train$surface_downwelling_shortwave_flux_in_air > 0, "surface_downwelling_shortwave_flux_in_air"], 0.05), + n.beta, resids = resids) + } else { + mod.out <- model.train(dat.subset = dat.list[[i]], n.beta = n.beta, v = v, + resids = resids) + } - # Save the betas as .nc - outfile <- file.path(path.out, paste0("betas_", v, "_", - i, ".nc")) - dimY <- ncdf4::ncdim_def(paste0("coeffs_", i), units = "unitless", - longname = "model.out coefficients", vals = 1:ncol(mod.out[["betas"]])) - dimX <- ncdf4::ncdim_def("random", units = "unitless", - longname = "random betas", vals = 1:nrow(mod.out[["betas"]])) - var.list <- ncdf4::ncvar_def(i, units = "coefficients", - dim = list(dimX, dimY), longname = paste0("day ", i, - " model.out coefficients")) - nc <- ncdf4::nc_create(outfile, var.list) - ncdf4::ncvar_put(nc, var.list, mod.out[["betas"]]) - ncdf4::nc_close(nc) + # Save the betas as .nc + outfile <- file.path(path.out, paste0("betas_", v, "_", i, ".nc")) + dimY <- ncdf4::ncdim_def(paste0("coeffs_", i), units = "unitless", + longname = "model.out coefficients", vals = 1:ncol(mod.out[["betas"]])) + dimX <- ncdf4::ncdim_def("random", units = "unitless", + longname = "random betas", vals = 1:nrow(mod.out[["betas"]])) + var.list <- ncdf4::ncvar_def(paste(i), units = "coefficients", dim = list(dimX, dimY), + longname = paste0("day ", i, " model.out coefficients")) + nc <- ncdf4::nc_create(outfile, var.list) + ncdf4::ncvar_put(nc, var.list, mod.out[["betas"]]) + ncdf4::nc_close(nc) + + # Save the model as a .Rdata with only the info we need to recreate it + # (saves a lot of space & memory) + mod.save <- list() + mod.save$call <- mod.out$model$call + mod.save$coef <- coef(mod.out$model) + mod.save$formula <- parse(text=mod.out$model$call[[2]][c(1,3)]) + mod.save$factors <- rownames(attr(mod.out$model$terms, "factors")) + mod.save$xlev <- mod.out$model$xlevels + mod.save$contr <- mod.out$model$contrasts + save(mod.save, file = file.path(path.out, paste0("model_", v, "_", i, ".Rdata"))) - # Save the model as a .Rdata - mod.save <- mod.out$mode - save(mod.save, file = file.path(path.out, paste0("model_", - v, "_", i, ".Rdata"))) - } - } - + if(resids) { + # Save the betas as .nc + outfile <- file.path(path.out, paste0("resids_betas_", v, "_", i, ".nc")) + dimY <- ncdf4::ncdim_def(paste0("coeffs_", i), units = "unitless", + longname = "model.out coefficients", vals = 1:ncol(mod.out[["betas.resid"]])) + dimX <- ncdf4::ncdim_def("random", units = "unitless", + longname = "random betas", vals = 1:nrow(mod.out[["betas.resid"]])) + var.list <- ncdf4::ncvar_def(i, units = "coefficients", dim = list(dimX, dimY), + longname = paste0("day ", i, "resid model.out coefficients")) + nc <- ncdf4::nc_create(outfile, var.list) + ncdf4::ncvar_put(nc, var.list, mod.out[["betas.resid"]]) + ncdf4::nc_close(nc) + + # Save the model as a .Rdata + mod.save <- list() + mod.save$call <- mod.out$model.resid$call + mod.save$coef <- coef(mod.out$model.resid) + mod.save$formula <- parse(text=mod.out$model.resid$call[[2]][c(1,3)]) + mod.save$factors <- rownames(attr(mod.out$model.resid$terms, "factors")) + mod.save$xlev <- mod.out$model.resid$xlevels + mod.save$contr <- mod.out$model.resid$contrasts + save(mod.save, file = file.path(path.out, paste0("resids_model_", v, "_", i, ".Rdata"))) + } # End resids case + + } # End day loop + } # End if else case + pb.index <- pb.index + 1 setTxtProgressBar(pb, pb.index) } # end of the variable for loop From 08da0531875b5c5901c9a312961219dddc7be940 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 12 Sep 2017 09:46:24 -0500 Subject: [PATCH 612/771] Control printing of progress bars + bug fixes 1. A few tiny bug fixes such as inconsistent path names, need to extract site lat/lon 2. Control which progress bars you want to show (if any) --- modules/data.atmosphere/R/align_met.R | 59 +++++++++++-------- .../data.atmosphere/R/tdm_lm_ensemble_sims.R | 19 +++--- .../R/tdm_predict_subdaily_met.R | 57 ++++++++++++------ 3 files changed, 88 insertions(+), 47 deletions(-) diff --git a/modules/data.atmosphere/R/align_met.R b/modules/data.atmosphere/R/align_met.R index da09d6ce4d1..d8c30d5b905 100644 --- a/modules/data.atmosphere/R/align_met.R +++ b/modules/data.atmosphere/R/align_met.R @@ -48,7 +48,7 @@ ##' @param pair.mems - logical stating whether ensemble members should be paired in ##' the case where ensembles are being read in in both the training and source data ##' @param seed - specify seed so that random draws can be reproduced -##' @param verbose +##' @param print.progress - if TRUE, prints progress bar ##' @export # ----------------------------------- # Workflow @@ -71,7 +71,7 @@ #---------------------------------------------------------------------- # Begin Function #---------------------------------------------------------------------- -align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, n.ens=NULL, pair.mems = FALSE, seed=Sys.Date(), verbose = FALSE) { +align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, n.ens=NULL, pair.mems = FALSE, seed=Sys.Date(), print.progress = FALSE) { # Load required libraries library(ncdf4) library(lubridate) @@ -98,8 +98,10 @@ align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, } # Loop through the .nc files putting everything into a list - print("Processing Training Data") - pb <- txtProgressBar(min=0, max=length(files.train), style=3) + if(print.progress==TRUE){ + print("Processing Training Data") + pb <- txtProgressBar(min=0, max=length(files.train), style=3) + } for(i in 1:length(files.train)){ yr.now <- yrs.file[i] @@ -126,8 +128,8 @@ align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, } ncdf4::nc_close(ncT) - - setTxtProgressBar(pb, i) + + if(print.progress==TRUE) setTxtProgressBar(pb, i) } # End looping through training data files } else { # we have an ensemble we need to deal with # Figure out how many ensemble members we're working with @@ -150,10 +152,12 @@ align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, n.files <- length(dir(file.path(train.path, ens.train[1]))) } + if(print.progress==TRUE){ + print("Processing Training Data") + pb <- txtProgressBar(min=0, max=length(ens.train)*n.files, style=3) + pb.ind=1 + } - print("Processing Training Data") - pb <- txtProgressBar(min=0, max=length(ens.train)*n.files, style=3) - pb.ind=1 for(j in 1:length(ens.train)){ files.train <- dir(file.path(train.path, ens.train[j]), ".nc") @@ -195,9 +199,11 @@ align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, dat.ens[[v]] <- append(dat.ens[[v]], ncdf4::ncvar_get(ncT, v)) } ncdf4::nc_close(ncT) - - setTxtProgressBar(pb, pb.ind) - pb.ind <- pb.ind+1 + + if(print.progress==TRUE){ + setTxtProgressBar(pb, pb.ind) + pb.ind <- pb.ind+1 + } } # End looping through training data files # Storing the ensemble member data in our output list @@ -209,7 +215,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, dimnames(met.out$dat.train[[v]])[[2]] <- ens.train } } # End loading & formatting training data - print(" ") + if(print.progress==TRUE) print(" ") # --------------- # --------------- @@ -241,8 +247,11 @@ align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, # day.train <- 1/(nrow(met.out$dat.train$time)/yrs.train/365) # Loop through the .nc files putting everything into a list - print("Processing Source Data") - pb <- txtProgressBar(min=0, max=length(files.source), style=3) + if(print.progress==TRUE){ + print("Processing Source Data") + pb <- txtProgressBar(min=0, max=length(files.source), style=3) + } + for(i in 1:length(files.source)){ yr.now <- yrs.file[i] @@ -311,9 +320,9 @@ align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, } ncdf4::nc_close(ncT) - setTxtProgressBar(pb, i) + if(print.progress==TRUE) setTxtProgressBar(pb, i) } # End looping through source met files - print("") + if(print.progress==TRUE) print("") } else { # we have an ensemble we need to deal with ens.source <- dir(source.path) @@ -337,9 +346,11 @@ align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, # getting an estimate of how many files we need to process n.files <- length(dir(file.path(source.path, ens.source[1]))) - print("Processing Source Data") - pb <- txtProgressBar(min=0, max=length(ens.source)*n.files, style=3) - pb.ind=1 + if(print.progress==TRUE){ + print("Processing Source Data") + pb <- txtProgressBar(min=0, max=length(ens.source)*n.files, style=3) + pb.ind=1 + } for(j in 1:length(ens.source)){ # Get a list of the files we'll be downscaling files.source <- dir(file.path(source.path, ens.source[j]), ".nc") @@ -436,8 +447,10 @@ align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, } #End variable loop nc_close(ncT) - setTxtProgressBar(pb, pb.ind) - pb.ind <- pb.ind+1 + if(print.progress==TRUE){ + setTxtProgressBar(pb, pb.ind) + pb.ind <- pb.ind+1 + } } # End looping through source met files # Storing the ensemble member data in our output list @@ -452,7 +465,7 @@ align.met <- function(train.path, source.path, yrs.train=NULL, yrs.source=NULL, } } # End loading & formatting source data - print("") + if(print.progress==TRUE) print("") # --------------- diff --git a/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R b/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R index 7591954bce7..86ff98154b5 100644 --- a/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R +++ b/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R @@ -23,6 +23,7 @@ ##' @param dat.train - the training data used to fit the model; needed for night/day in ##' surface_downwelling_shortwave_flux_in_air ##' @param seed - (optional) set the seed manually to allow reproducible results +##' @param print.progress - if TRUE will print progress bar ##' @export # ----------------------------------- #---------------------------------------------------------------------- @@ -30,7 +31,7 @@ #---------------------------------------------------------------------- lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags.list = NULL, - lags.init = NULL, dat.train, seed=Sys.time()) { + lags.init = NULL, dat.train, seed=Sys.time(), print.progress=FALSE) { # Set our random seed set.seed(seed) @@ -58,10 +59,12 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags. "next.surface_downwelling_longwave_flux_in_air", "next.air_pressure", "next.specific_humidity", "next.wind_speed") - # Set progress bar - pb.index <- 1 - pb <- txtProgressBar(min = 1, max = length(vars.list)*length(days.sim), style = 3) - setTxtProgressBar(pb, pb.index) + # # Set progress bar + if(print.progress==TRUE){ + pb.index <- 1 + pb <- txtProgressBar(min = 1, max = length(vars.list)*length(days.sim), style = 3) + setTxtProgressBar(pb, pb.index) + } # Figure out if we need to extract the approrpiate if (is.null(lags.list) & is.null(lags.init)) { @@ -312,8 +315,10 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags. } rm(mod.save) # Clear out the model to save memory - pb.index <- pb.index + 1 - setTxtProgressBar(pb, pb.index) + if(print.progress==TRUE){ + setTxtProgressBar(pb, pb.index) + pb.index <- pb.index + 1 + } } # end day loop # -------------------------------- diff --git a/modules/data.atmosphere/R/tdm_predict_subdaily_met.R b/modules/data.atmosphere/R/tdm_predict_subdaily_met.R index ceeab2d0710..024ace30aa9 100644 --- a/modules/data.atmosphere/R/tdm_predict_subdaily_met.R +++ b/modules/data.atmosphere/R/tdm_predict_subdaily_met.R @@ -33,6 +33,7 @@ ##' @param n.cores - deals with parallelization ##' @param overwrite ##' @param verbose +##' @param print.progress - print the progress bar? ##' @param seed - manually set seed for results to be reproducible ##' @export ##' @examples @@ -55,7 +56,7 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, direction.filter, lm.models.base, yrs.predict, ens.labs = 1:3, resids = FALSE, parallel = FALSE, cores.max = 12, n.cores = NULL, - overwrite = FALSE, verbose = FALSE, seed=format(Sys.time(), "%m%d"), ...) { + overwrite = FALSE, verbose = FALSE, seed=format(Sys.time(), "%m%d"), print.progress=FALSE, ...) { vars.hour <- c("air_temperature", "precipitation_flux", "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", "air_pressure", "specific_humidity", @@ -65,7 +66,14 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire "lag.specific_humidity", "lag.wind_speed") n.ens <- length(ens.labs) - + + # Extract the lat/lon info from the first of the source files + fnow <- dir(in.path, ".nc")[1] + ncT <- ncdf4::nc_open(file.path(in.path, fnow)) + lat.in <- ncdf4::ncvar_get(ncT, "latitude") + lon.in <- ncdf4::ncvar_get(ncT, "longitude") + ncdf4::nc_close(ncT) + # Getting a list of all files/years we want to downscale files.tdm <- dir(in.path, ".nc") @@ -87,9 +95,9 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire met.lag <- ifelse(direction.filter=="backwards", -1, +1) # Create wind speed variable if it doesn't exist - if (all(is.na(dat.train$wind_speed) == TRUE)) { - dat.train$wind_speed <- sqrt(dat.train$eastward_wind^2 + dat.train$northward_wind^2) - } + # if (all(is.na(dat.train$wind_speed) == TRUE)) { + # dat.train$wind_speed <- sqrt(dat.train$eastward_wind^2 + dat.train$northward_wind^2) + # } # Defining variable names, longname & units @@ -103,17 +111,24 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire "kg kg-1", "m s-1")) # ---------------------------------- + # Set progress bar + # pb.index <- 1 + if(print.progress==TRUE) pb <- txtProgressBar(min = 1, max = length(yrs.tdm), style = 3) + # setTxtProgressBar(pb, pb.index) + for (y in 1:length(yrs.tdm)) { # Read in the data and dupe it into the temporal resolution we want to end up with (based on our training data) - files.train <- dir(train.path, ".nc") + files.train <- dir(path.train, ".nc") yrs.file <- strsplit(files.train, "[.]") yrs.file <- matrix(unlist(yrs.file), ncol=length(yrs.file[[1]]), byrow=T) yrs.file <- as.numeric(yrs.file[,ncol(yrs.file)-1]) # Assumes year is always last thing before the file extension yrs.file <- yrs.file[length(yrs.file)/2] - met.out <- align.met(train.path=path.train, source.path=in.path, yrs.train=NULL, yrs.source=yrs.tdm[y], n.ens=1, seed=201708, pair.mems = FALSE) + met.out <- align.met(train.path=path.train, source.path=in.path, + yrs.train=NULL, yrs.source=yrs.tdm[y], + n.ens=1, seed=201708, pair.mems = FALSE) # Package the raw data into the dataframe that will get passed into the function dat.ens <- data.frame(year = met.out$dat.source$time$Year, @@ -231,16 +246,21 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire path.model = file.path(lm.models.base), lags.list = NULL, lags.init = lags.init, direction.filter=direction.filter, - dat.train = met.out$dat.train, seed=seed) + dat.train = met.out$dat.train, seed=seed, print.progress=F) # ----------------------------------- - - + # ----------------------------------- + # Set up the lags for the next year + # ----------------------------------- for(v in names(ens.sims)) { lags.init[[v]] <- data.frame(ens.sims[[v]][length(ens.sims[[v]]),]) } + # ----------------------------------- + # ----------------------------------- + # Save as netcdf file + # ----------------------------------- # Set up the time dimension for this year hrs.now <- as.numeric(difftime(dat.ens$date, paste0(yrs.tdm[y], "-01-01"), tz = "GMT", units = "hour")) @@ -282,18 +302,21 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire "specific_humidity", "wind_speed")] colnames(df) <- nc.info$CF.name - dir.create(outfolder, showWarnings = FALSE, recursive = TRUE) - loc.file <- file.path(outfolder, paste0(in.prefix, "_ens", - ens.labs[i], "_", yrs.tdm[y], ".nc")) - loc <- ncdf4::nc_create(filename = loc.file, vars = var.list, - verbose = verbose) + # Set up the home folder + out.ens <- file.path(outfolder, paste(in.prefix, ens.labs[i], sep=".")) + dir.create(out.ens, showWarnings = FALSE, recursive = TRUE) + + loc.file <- file.path(out.ens, paste(in.prefix, ens.labs[i], yrs.tdm[y], "nc", sep=".")) + loc <- ncdf4::nc_create(filename = loc.file, vars = var.list, verbose = verbose) for (j in nc.info$CF.name) { ncdf4::ncvar_put(nc = loc, varid = as.character(j), vals = df[[j]][seq_len(nrow(df))]) } ncdf4::nc_close(loc) } # End writing ensemble members - print(paste0("finished year ", yrs.tdm[y])) - + if(print.progress==TRUE) setTxtProgressBar(pb, y) + # print(paste0("finished year ", yrs.tdm[y])) + # ----------------------------------- + } # End year loop } # End function From 9ae0a5ad3cf640fa10249a41492b008b8d28384d Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 12 Sep 2017 15:53:44 -0500 Subject: [PATCH 613/771] CRITICAL BUG FIX: order data properly MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit In the construction of the model frame, things become ordered differently than we see in the data we feed into this function & reference to pull our appropriate rows. This requires some tweaking, but it looks like it’s working in the end. --- modules/data.atmosphere/R/tdm_subdaily_pred.R | 31 ++++++++++++++----- 1 file changed, 24 insertions(+), 7 deletions(-) diff --git a/modules/data.atmosphere/R/tdm_subdaily_pred.R b/modules/data.atmosphere/R/tdm_subdaily_pred.R index a5b4e291d08..5c782eeaea6 100644 --- a/modules/data.atmosphere/R/tdm_subdaily_pred.R +++ b/modules/data.atmosphere/R/tdm_subdaily_pred.R @@ -29,16 +29,32 @@ subdaily_pred <- function(newdata, model.predict, Rbeta, resid.err = FALSE, mode Rbeta.resid = NULL, n.ens) { err.resid <- 0 # dummy residual error term; if we want to add residual error, we're modeling it by hour + + df.hr <- data.frame(hour = model.predict$xlev[[1]]) + df.hr[,"as.ordered(hour)"] <- as.ordered(df.hr$hour) + + piv <- as.numeric(which(!is.na(model.predict$coef))) + + model.predict$factors[model.predict$factors=="as.ordered(hour)"] <- "hour" + m <- newdata[,model.predict$factors] + m[,"as.ordered(hour)"] <- as.ordered(m$hour) + m$hour <- as.numeric(m$hour) - mod.terms <- terms(model.predict) - mod.coef <- coef(model.predict) - mod.cov <- vcov(model.predict) - mod.resid <- resid(model.predict) - piv <- as.numeric(which(!is.na(mod.coef))) + # Ordering the newdata in the same way as m (by hour) + newdata <- newdata[order(newdata$hour),] + + # Fixing the ordering so that it comes back looking like newdata + m$ens <- newdata$ens + # dat.sim <- dat.sim[order(dat.sim$ens, dat.sim$hour),] + newdata <- newdata[order(newdata$ens, newdata$hour),] + + # Adding hours to make sure prediction works okay + if(length(df.hr$hour)!= length(m$hour)) m <- merge(m, df.hr, all=T) - m <- model.frame(mod.terms, newdata, xlev = model.predict$xlevels) - Xp <- model.matrix(mod.terms, m, contrasts.arg = model.predict$contrasts) + + Xp <- model.matrix(eval(model.predict$formula), m, contrasts.arg=model.predict$contr) + if (resid.err == TRUE) { newdata$resid <- 99999 resid.piv <- as.numeric(which(!is.na(model.resid$coef))) @@ -53,6 +69,7 @@ subdaily_pred <- function(newdata, model.predict, Rbeta, resid.err = FALSE, mode dat.sim <- Xp[, piv] %*% t(Rbeta) + err.resid + return(dat.sim) } \ No newline at end of file From adea67fe4d73041a72dac9efb73ba32af68a6783 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 12 Sep 2017 15:54:08 -0500 Subject: [PATCH 614/771] Lag & minor bug fixes --- .../R/tdm_generate_subdaily_models.R | 85 +++++++------------ .../data.atmosphere/R/tdm_lm_ensemble_sims.R | 33 ++++--- .../R/tdm_predict_subdaily_met.R | 19 +++-- .../R/tdm_temporal_downscale_functions.R | 25 +++--- 4 files changed, 79 insertions(+), 83 deletions(-) diff --git a/modules/data.atmosphere/R/tdm_generate_subdaily_models.R b/modules/data.atmosphere/R/tdm_generate_subdaily_models.R index 145274993b4..38f8ed23fdf 100644 --- a/modules/data.atmosphere/R/tdm_generate_subdaily_models.R +++ b/modules/data.atmosphere/R/tdm_generate_subdaily_models.R @@ -35,6 +35,7 @@ ##' @param seed - seed for randomization to allow for reproducible results ##' @param overwrite ##' @param verbose +##' @param print.progress - print progress bar? (gets passed through) ##' @export # ----------------------------------- #---------------------------------------------------------------------- @@ -43,8 +44,8 @@ gen.subdaily.models <- function(outfolder, path.train, yrs.train, direction.filter, in.prefix, - n.beta, day.window, resids = FALSE, parallel = FALSE, n.cores = NULL, overwrite = TRUE, - verbose = FALSE) { + n.beta, day.window, seed=Sys.time(), resids = FALSE, parallel = FALSE, n.cores = NULL, overwrite = TRUE, + verbose = FALSE, print.progress=FALSE) { # pb.index <- 1 # pb <- txtProgressBar(min = 1, max = 8, style = 3) @@ -55,6 +56,9 @@ gen.subdaily.models <- function(outfolder, path.train, yrs.train, direction.filt "air_temperature_min", "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", "air_pressure", "specific_humidity", "eastward_wind", "northward_wind", "wind_speed")) + + + # Getting a list of all the available files and then subsetting to just the ones we # actually want to use files.train <- dir(path.train) @@ -67,53 +71,28 @@ gen.subdaily.models <- function(outfolder, path.train, yrs.train, direction.filt yrs.file <- yrs.file[which(yrs.file %in% yrs.train)] } - - dat.train <- data.frame() - for(i in 1:length(files.train)){ - yr.now <- yrs.file[i] - - ncT <- ncdf4::nc_open(file.path(path.train, files.train[i])) - - # Set up the time data frame to help index - nday <- ifelse(lubridate::leap_year(yr.now), 366, 365) - ntime <- length(ncT$dim$time$vals) - step.day <- nday/ntime - step.hr <- step.day*24 - stamps.hr <- seq(step.hr/2, by=step.hr, length.out=1/step.day) # Time stamps centered on period - - # Create a data frame with all the important time info - # center the hour step - df.tmp <- data.frame(year=yr.now, doy=rep(1:nday, each=1/step.day), hour=rep(stamps.hr, nday)) - df.tmp$date <- strptime(paste(df.tmp$year, df.tmp$doy, df.tmp$hour, sep="-"), format=("%Y-%j-%H"), tz="UTC") - - # Extract the met info, making matrices with the appropriate number of ensemble members - for(v in names(ncT$var)){ - df.tmp[,v] <- ncdf4::ncvar_get(ncT, v) - } - - ncdf4::nc_close(ncT) - - dat.train <- rbind(dat.train, df.tmp) - - # setTxtProgressBar(pb, i) - } # End looping through training data files - - if(!"wind_speed" %in% names(dat.train)){ - dat.train$wind_speed <- sqrt(dat.train$eastward_wind^2 + dat.train$northward_wind^2) + met.out <- align.met(train.path=path.train, source.path=path.train, + yrs.train=yrs.file, yrs.source=yrs.file[1], + n.ens=1, seed=seed, pair.mems = FALSE) + + dat.train <- data.frame(year = met.out$dat.train$time$Year, + doy = met.out$dat.train$time$DOY, + date = met.out$dat.train$time$Date, + hour = met.out$dat.train$time$Hour, + air_temperature = met.out$dat.train$air_temperature, + precipitation_flux = met.out$dat.train$precipitation_flux, + surface_downwelling_shortwave_flux_in_air = met.out$dat.train$surface_downwelling_shortwave_flux_in_air, + surface_downwelling_longwave_flux_in_air = met.out$dat.train$surface_downwelling_longwave_flux_in_air, + air_pressure = met.out$dat.train$air_pressure, + specific_humidity = met.out$dat.train$specific_humidity + ) + + if(!"wind_speed" %in% names(met.out$dat.train)){ + dat.train$wind_speed <- sqrt(met.out$dat.train$eastward_wind^2 + met.out$dat.train$northward_wind^2) + } else { + dat.train$wind_speed <- met.out$dat.train$wind_speed } - - # # adding a temporary date variable for the model - # if (dim$time$units == "sec"){ - # sub_string<- substrRight(dat.train_file, 7) - # start_year <- substr(sub_string, 1, 4) - # dat.train$date <- as.Date((dim$time$vals/(dim$time$vals[2] - dim$time$vals[1])), - # tz="GMT", origin = paste0(start_year - 1, "-12-31")) - # } else { - # start_year <- substr(dim$time$units,start = 12,stop = 15) - # dat.train$date = as.POSIXct(udunits2::ud.convert((dim$time$vals - ((dim$time$vals[2] - dim$time$vals[1])/2)),"days", "seconds"), - # tz="GMT", origin = paste0(start_year, "-01-01 00:00:00")) - # } - + # these non-standard variables help us organize our modeling approach # Reference everything off of the earliest date; avoiding 0s because that makes life difficult dat.train$sim.hr <- trunc(as.numeric(difftime(dat.train$date, min(dat.train$date), tz = "GMT", units = "hour")))+1 @@ -150,12 +129,11 @@ gen.subdaily.models <- function(outfolder, path.train, yrs.train, direction.filt "lag.specific_humidity", "lag.wind_speed") # Specifying what hour we want to lag - # Note: For forward filtering, we want to associate today with tomorrow (+1 day) using the last observation of the day - # For backwards filtering, we want to associate today with yesterday (-1 day) using the first obs of the day + # Note: For forward filtering, we want to associate today with tomorrow (+1 day) using the last observation of today + # For backwards filtering, we want to associate today with yesterday (-1 day) using the first obs of today met.lag <- ifelse(direction.filter=="backwards", -1, +1) lag.time <- ifelse(direction.filter=="backwards", min(dat.train$hour), max(dat.train$hour)) - # Pull out just the time we're interested in lag.day <- dat.train[dat.train$hour == lag.time, c("year", "doy", "sim.day", vars.hour)] names(lag.day)[4:ncol(lag.day)] <- vars.lag @@ -190,6 +168,9 @@ gen.subdaily.models <- function(outfolder, path.train, yrs.train, direction.filt dat.train <- merge(dat.train, next.day[, c("sim.day", vars.next)], all.x = T) + # Order the data just to make life easier + dat.train <- dat.train[order(dat.train$date),] + # ----- 1.4 calculate air_temperature_min & air_temperature_max as # departure from mean; order data ---------- Lookign at max & min as # departure from mean @@ -208,7 +189,7 @@ gen.subdaily.models <- function(outfolder, path.train, yrs.train, direction.filt temporal.downscale.functions(dat.train = dat.train, n.beta = n.beta, day.window = day.window, resids = resids, n.cores = n.cores, - seed = seed, outfolder = outfolder) + seed = seed, outfolder = outfolder, print.progress=print.progress) } # Helper function diff --git a/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R b/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R index 86ff98154b5..ac1e7a8a5ac 100644 --- a/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R +++ b/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R @@ -39,8 +39,10 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags. # Setting our our time indexes if(direction.filter=="backwards"){ days.sim <- max(dat.mod$sim.day):min(dat.mod$sim.day) + lag.time <- min(dat.mod$hour) } else { days.sim <- min(dat.mod$sim.day):max(dat.mod$sim.day) + lag.time <- max(dat.mod$hour) } # Declare the variables of interest that will be called in the @@ -116,12 +118,6 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags. # Looping through time # -------------------------------- # Setting our our time indexes - if(direction.filter=="backwards"){ - days.sim <- max(dat.mod$sim.day):min(dat.mod$sim.day) - } else { - days.sim <- min(dat.mod$sim.day):max(dat.mod$sim.day) - } - for (i in 1:length(days.sim)) { day.now <- unique(dat.mod[dat.mod$sim.day == days.sim[i], "doy"]) rows.now <- which(dat.mod$sim.day == days.sim[i]) @@ -138,6 +134,18 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags. rows.mod <- which(dat.mod$sim.day == days.sim[i] & dat.mod$hour %in% hrs.day) dat.temp <- dat.mod[rows.mod, dat.info] + + # dat.temp <- merge(dat.temp, data.frame(ens=paste0("X", 1:n.ens))) + if (i == 1) { + sim.lag <- stack(lags.init[[v]]) + names(sim.lag) <- c(paste0("lag.", v), "ens") + + } else { + sim.lag <- stack(data.frame(array(0,dim = c(1, ncol(dat.sim[[v]]))))) + names(sim.lag) <- c(paste0("lag.", v), "ens") + } + dat.temp <- merge(dat.temp, sim.lag, all.x = TRUE) + } else if (v == "air_temperature") { dat.temp <- dat.mod[rows.now, dat.info] @@ -149,8 +157,8 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags. sim.lag$lag.air_temperature_min <- stack(lags.init$air_temperature_min)[,1] sim.lag$lag.air_temperature_max <- stack(lags.init$air_temperature_max)[,1] } else { - sim.lag <- stack(data.frame(array(dat.sim[["air_temperature"]][dat.mod$sim.day == (days.sim[i - 1]) & - dat.mod$hour == max(unique(dat.mod$hour)), ], + sim.lag <- stack(data.frame(array(dat.sim[["air_temperature"]][dat.mod$sim.day == (days.sim[i-1]) & + dat.mod$hour == lag.time, ], dim = c(1, ncol(dat.sim$air_temperature))))) names(sim.lag) <- c("lag.air_temperature", "ens") sim.lag$lag.air_temperature_min <- stack(apply(dat.sim[["air_temperature"]][dat.mod$sim.day == days.sim[i-1], ], 2, min))[, 1] @@ -173,7 +181,7 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags. } else { sim.lag <- stack(data.frame(array(dat.sim[[v]][dat.mod$sim.day == days.sim[i-1] & - dat.mod$hour == max(unique(dat.mod$hour)), ], + dat.mod$hour == lag.time, ], dim = c(1, ncol(dat.sim[[v]]))))) names(sim.lag) <- c(paste0("lag.", v), "ens") } @@ -189,7 +197,7 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags. } else { sim.lag <- stack(data.frame(array(dat.sim[[v]][dat.mod$sim.day == days.sim[i-1] & - dat.mod$hour == max(unique(dat.mod$hour)), ], + dat.mod$hour == lag.time, ], dim = c(1, ncol(dat.sim[[v]]))))) names(sim.lag) <- c(paste0("lag.", v), "ens") } @@ -287,7 +295,7 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags. # Randomly pick which values to save & propogate cols.prop <- as.integer(cols.list[i,]) for (j in 1:ncol(dat.sim[[v]])) { - dat.sim[[v]][rows.mod, j] <- dat.pred[, cols.prop[j]] + dat.sim[[v]][rows.mod, j] <- dat.pred[dat.temp$ens == paste0("X", j), cols.prop[j]] } dat.sim[[v]][rows.now[!rows.now %in% rows.mod], ] <- 0 @@ -309,8 +317,7 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags. cols.prop <- as.integer(cols.list[i,]) for (j in 1:ncol(dat.sim[[v]])) { - dat.sim[[v]][rows.now, j] <- dat.pred[dat.temp$ens == - paste0("X", j), cols.prop[j]] + dat.sim[[v]][rows.now, j] <- dat.pred[dat.temp$ens == paste0("X", j), cols.prop[j]] } } rm(mod.save) # Clear out the model to save memory diff --git a/modules/data.atmosphere/R/tdm_predict_subdaily_met.R b/modules/data.atmosphere/R/tdm_predict_subdaily_met.R index 024ace30aa9..51741f68631 100644 --- a/modules/data.atmosphere/R/tdm_predict_subdaily_met.R +++ b/modules/data.atmosphere/R/tdm_predict_subdaily_met.R @@ -54,7 +54,7 @@ #---------------------------------------------------------------------- predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, direction.filter, lm.models.base, - yrs.predict, ens.labs = 1:3, resids = FALSE, + yrs.predict=NULL, ens.labs = 1:3, resids = FALSE, parallel = FALSE, cores.max = 12, n.cores = NULL, overwrite = FALSE, verbose = FALSE, seed=format(Sys.time(), "%m%d"), print.progress=FALSE, ...) { @@ -82,7 +82,7 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire yrs.tdm <- as.numeric(yrs.tdm[,ncol(yrs.tdm)-1]) # Assumes year is always last thing before the file extension if(!is.null(yrs.predict)){ - yrs.tdm <- files.tdm[which(yrs.tdm %in% yrs.predict)] + files.tdm <- files.tdm[which(yrs.tdm %in% yrs.predict)] yrs.tdm <- yrs.tdm[which(yrs.tdm %in% yrs.predict)] } @@ -145,9 +145,11 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire wind_speed.day = met.out$dat.source$wind_speed) # Create wind speed variable if it doesn't exist - # if (all(is.na(dat.train$wind_speed) == TRUE)) { - # dat.train$wind_speed <- sqrt(dat.train$eastward_wind^2 + dat.train$northward_wind^2) - # } + if(!"wind_speed" %in% names(met.out$dat.source)){ + dat.ens$wind_speed <- sqrt(met.out$dat.source$eastward_wind^2 + met.out$dat.source$northward_wind^2) + } else { + dat.ens$wind_speed <- met.out$dat.source$wind_speed + } # Set up our simulation time variables; it *should* be okay that this resets each year since it's really only doy that matters dat.ens$sim.hr <- trunc(as.numeric(difftime(dat.ens$date, min(dat.ens$date), tz = "GMT", units = "hour")))+1 @@ -161,8 +163,8 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire # Figure out whether we want to use the first or last value to initalize our lags # Note: Data should be ordered Jan 1 -> Dec 31; If we're moving backwards, we start with # Dec 31 and we'll want to pull Jan 1. If we're going forward, we want the opposite - lag.use <- ifelse(direction.filter=="backwards", 1, nrow(met.out$dat.source$time)) if(y == 1){ + lag.use <- ifelse(direction.filter=="backwards", 1, nrow(met.out$dat.source$time)) lags.init <- list() lags.init[["air_temperature"]] <- data.frame(array(mean(met.out$dat.source$air_temperature_maximum[lag.use], met.out$dat.source$air_temperature_minimum[lag.use]), dim=c(1, n.ens))) @@ -233,6 +235,8 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire # Merging the next into our ensemble data dat.ens <- merge(dat.ens, dat.nxt, all.x=T) + + dat.ens <- dat.ens[order(dat.ens$date),] # ------------------------------ @@ -254,7 +258,8 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire # Set up the lags for the next year # ----------------------------------- for(v in names(ens.sims)) { - lags.init[[v]] <- data.frame(ens.sims[[v]][length(ens.sims[[v]]),]) + lag.use <- ifelse(direction.filter=="backwards", 1, nrow(ens.sims[[v]])) + lags.init[[v]] <- data.frame(ens.sims[[v]][lag.use,]) } # ----------------------------------- diff --git a/modules/data.atmosphere/R/tdm_temporal_downscale_functions.R b/modules/data.atmosphere/R/tdm_temporal_downscale_functions.R index 8c18bb9bd84..e12156a4f78 100644 --- a/modules/data.atmosphere/R/tdm_temporal_downscale_functions.R +++ b/modules/data.atmosphere/R/tdm_temporal_downscale_functions.R @@ -28,18 +28,20 @@ ##' statistics from ##' @param seed - allows this to be reproducible ##' @param outfoulder = where the output should be stored +##' @param print.progress - print progress of model generation? ##' @export # ----------------------------------- #---------------------------------------------------------------------- # Begin Function #---------------------------------------------------------------------- temporal.downscale.functions <- function(dat.train, n.beta, day.window, - resids = FALSE, parallel = FALSE, n.cores = NULL, seed = format(Sys.time(), "%m%d"), outfolder, ...) { - - pb.index <- 1 - pb <- txtProgressBar(min = 1, max = 8, style = 3) - setTxtProgressBar(pb, pb.index) + resids = FALSE, parallel = FALSE, n.cores = NULL, seed = format(Sys.time(), "%m%d"), outfolder, print.progress=FALSE, ...) { + if(print.progress==TRUE){ + pb.index <- 1 + pb <- txtProgressBar(min = 1, max = 8, style = 3) + setTxtProgressBar(pb, pb.index) + } # Declare the variables of interest that will be called in the # overarching loop vars.list <- c("surface_downwelling_shortwave_flux_in_air", "air_temperature", @@ -62,11 +64,10 @@ temporal.downscale.functions <- function(dat.train, n.beta, day.window, # Define the path path.out <- file.path(outfolder, v) + if (!dir.exists(path.out)) dir.create(path.out, recursive = T) # Set our seed set.seed(seed) - if (!dir.exists(path.out)) - dir.create(path.out, recursive = T) # Create empty lists dat.list <- list() @@ -164,7 +165,7 @@ temporal.downscale.functions <- function(dat.train, n.beta, day.window, if (v == "surface_downwelling_shortwave_flux_in_air") { mod.out <- model.train(dat.subset = dat.list[[i]], n.beta = n.beta, v = v, threshold = quantile(dat.train[dat.train$surface_downwelling_shortwave_flux_in_air > 0, "surface_downwelling_shortwave_flux_in_air"], 0.05), - n.beta, resids = resids) + resids = resids) } else { mod.out <- model.train(dat.subset = dat.list[[i]], n.beta = n.beta, v = v, resids = resids) @@ -220,9 +221,11 @@ temporal.downscale.functions <- function(dat.train, n.beta, day.window, } # End day loop } # End if else case - - pb.index <- pb.index + 1 - setTxtProgressBar(pb, pb.index) + + if(print.progress==TRUE){ + pb.index <- pb.index + 1 + setTxtProgressBar(pb, pb.index) + } } # end of the variable for loop } # end of the function From 5d1277a3ff80df6bef0b30b75f4987758a27244d Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Wed, 13 Sep 2017 10:57:10 -0500 Subject: [PATCH 615/771] CRITICAL BUG FIX, Part II: ordering data MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit In I’d fixed a bug with how the data was ordered. Changing the order of operations then caused a problem with the swdown case because it was looking at total dimensions rather than just the hours. This should fix both ordering & level issues. --- modules/data.atmosphere/R/tdm_subdaily_pred.R | 23 ++++++++++++------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/modules/data.atmosphere/R/tdm_subdaily_pred.R b/modules/data.atmosphere/R/tdm_subdaily_pred.R index 5c782eeaea6..150a281e7d2 100644 --- a/modules/data.atmosphere/R/tdm_subdaily_pred.R +++ b/modules/data.atmosphere/R/tdm_subdaily_pred.R @@ -40,16 +40,23 @@ subdaily_pred <- function(newdata, model.predict, Rbeta, resid.err = FALSE, mode m[,"as.ordered(hour)"] <- as.ordered(m$hour) m$hour <- as.numeric(m$hour) - # Ordering the newdata in the same way as m (by hour) - newdata <- newdata[order(newdata$hour),] + # Adding hours to make sure prediction works okay + # Note: This really messes with the order of things! + if(length(unique(df.hr$hour))!= length(unique(m$hour))){ + m$ens <- newdata$ens + + m <- merge(m, df.hr, all=T) + + # Ordering the newdata in the same way as m (by hour) + m <- m[order(m$ens, m$hour),] + # newdata <- newdata[order(newdata$hour),] + + # # Fixing the ordering so that it comes back looking like newdata + # dat.sim <- dat.sim[order(dat.sim$ens, dat.sim$hour),] + # newdata <- newdata[order(newdata$ens, newdata$hour),] + } - # Fixing the ordering so that it comes back looking like newdata - m$ens <- newdata$ens - # dat.sim <- dat.sim[order(dat.sim$ens, dat.sim$hour),] - newdata <- newdata[order(newdata$ens, newdata$hour),] - # Adding hours to make sure prediction works okay - if(length(df.hr$hour)!= length(m$hour)) m <- merge(m, df.hr, all=T) From bbd17cb6851f55ddae7379e6335cfab95a045cf5 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Wed, 13 Sep 2017 16:37:39 -0500 Subject: [PATCH 616/771] Update Documentation (I always forget to do the commands to update the documentation, so here it is at the end.) --- modules/data.atmosphere/man/align.met.Rd | 12 ++++++-- .../man/gen.subdaily.models.Rd | 23 +++++++++++---- .../data.atmosphere/man/lm_ensemble_sims.Rd | 12 ++++++-- .../man/predict_subdaily_met.Rd | 29 ++++++++++++------- .../man/temporal.downscale.functions.Rd | 6 +++- 5 files changed, 60 insertions(+), 22 deletions(-) diff --git a/modules/data.atmosphere/man/align.met.Rd b/modules/data.atmosphere/man/align.met.Rd index 6251e69a1e5..d8fd83319d7 100644 --- a/modules/data.atmosphere/man/align.met.Rd +++ b/modules/data.atmosphere/man/align.met.Rd @@ -4,8 +4,9 @@ \alias{align.met} \title{align.met} \usage{ -align.met(train.path, source.path, yrs.train = NULL, n.ens = NULL, - pair.mems = FALSE, seed = Sys.Date(), verbose = FALSE) +align.met(train.path, source.path, yrs.train = NULL, yrs.source = NULL, + n.ens = NULL, pair.mems = FALSE, seed = Sys.Date(), + print.progress = FALSE) } \arguments{ \item{train.path}{- path to the dataset to be used to downscale the data} @@ -17,12 +18,19 @@ prevents needing to load the entire dataset. If NULL, all available years will be loaded. If not null, should be a vector of numbers (so you can skip problematic years)} +\item{yrs.source}{- (optional) specify a specific years to be loaded for the source data; +prevents needing to load the entire dataset. If NULL, all available years +will be loaded. If not null, should be a vector of numbers (so you can skip +problematic years)} + \item{n.ens}{- number of ensemble members to generate and save} \item{pair.mems}{- logical stating whether ensemble members should be paired in the case where ensembles are being read in in both the training and source data} \item{seed}{- specify seed so that random draws can be reproduced} + +\item{print.progress}{- if TRUE, prints progress bar} } \value{ 2-layered list (stored in memory) containing the training and source data that are now matched diff --git a/modules/data.atmosphere/man/gen.subdaily.models.Rd b/modules/data.atmosphere/man/gen.subdaily.models.Rd index 4b2fb3b0460..6683b42616f 100644 --- a/modules/data.atmosphere/man/gen.subdaily.models.Rd +++ b/modules/data.atmosphere/man/gen.subdaily.models.Rd @@ -4,14 +4,21 @@ \alias{gen.subdaily.models} \title{gen.subdaily.models} \usage{ -gen.subdaily.models(outfolder, dat.train_file, in.prefix, n.beta, day.window, - resids = FALSE, parallel = FALSE, n.cores = NULL, overwrite = TRUE, - verbose = FALSE) +gen.subdaily.models(outfolder, path.train, yrs.train, direction.filter, + in.prefix, n.beta, day.window, seed = Sys.time(), resids = FALSE, + parallel = FALSE, n.cores = NULL, overwrite = TRUE, verbose = FALSE, + print.progress = FALSE) } \arguments{ -\item{outfolder}{- directory where models will be stored *** storage required varies by size of training dataset, but prepare for >100 GB} +\item{outfolder}{- directory where models will be stored *** storage required varies by size of training dataset, but prepare for >10 GB} -\item{dat.train_file}{- train_data file} +\item{path.train}{- path to CF/PEcAn style training data where each year is in a separate file.} + +\item{yrs.train}{- which years of the training data should be used for to generate the model for +the subdaily cycle. If NULL, will default to all years} + +\item{direction.filter}{- Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") +(PalEON will go backwards, anybody interested in the future will go forwards)} \item{in.prefix}{} @@ -21,11 +28,15 @@ gen.subdaily.models(outfolder, dat.train_file, in.prefix, n.beta, day.window, specific hours coefficients. Must be integer because we want statistics from the same time of day for each day surrounding the model day} -\item{resids}{- logical stating whether to pass on residual data or not} +\item{seed}{- seed for randomization to allow for reproducible results} + +\item{resids}{- logical stating whether to pass on residual data or not (this increases both memory & storage requirements)} \item{parallel}{- logical stating whether to run temporal_downscale_functions.R in parallel} \item{n.cores}{- deals with parallelization} + +\item{print.progress}{- print progress bar? (gets passed through)} } \description{ This is the 2nd function in the tdm workflow that takes the dat.train_file that is created from the diff --git a/modules/data.atmosphere/man/lm_ensemble_sims.Rd b/modules/data.atmosphere/man/lm_ensemble_sims.Rd index 340fe5ad6b0..369dfa161d5 100644 --- a/modules/data.atmosphere/man/lm_ensemble_sims.Rd +++ b/modules/data.atmosphere/man/lm_ensemble_sims.Rd @@ -4,8 +4,9 @@ \alias{lm_ensemble_sims} \title{lm_ensemble_sims} \usage{ -lm_ensemble_sims(dat.mod, n.ens, path.model, lags.list = NULL, - lags.init = NULL, dat.train) +lm_ensemble_sims(dat.mod, n.ens, path.model, direction.filter, + lags.list = NULL, lags.init = NULL, dat.train, seed = Sys.time(), + print.progress = FALSE) } \arguments{ \item{dat.mod}{- dataframe to be predicted at the time step of the training data} @@ -14,10 +15,17 @@ lm_ensemble_sims(dat.mod, n.ens, path.model, lags.list = NULL, \item{path.model}{- path to where the training model & betas is stored} +\item{direction.filter}{- Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") +(PalEON will go backwards, anybody interested in the future will go forwards)} + \item{lags.init}{- a data frame of initialization parameters to match the data in dat.mod} \item{dat.train}{- the training data used to fit the model; needed for night/day in surface_downwelling_shortwave_flux_in_air} + +\item{seed}{- (optional) set the seed manually to allow reproducible results} + +\item{print.progress}{- if TRUE will print progress bar} } \description{ This function does the heavy lifting in the final diff --git a/modules/data.atmosphere/man/predict_subdaily_met.Rd b/modules/data.atmosphere/man/predict_subdaily_met.Rd index b6defafc64a..1dab917388b 100644 --- a/modules/data.atmosphere/man/predict_subdaily_met.Rd +++ b/modules/data.atmosphere/man/predict_subdaily_met.Rd @@ -4,10 +4,11 @@ \alias{predict_subdaily_met} \title{predict_subdaily_met} \usage{ -predict_subdaily_met(outfolder, in.path, in.prefix, lm.models.base, - dat.train_file, start_date, end_date, cores.max = 12, n.ens = 3, - resids = FALSE, parallel = FALSE, n.cores = NULL, overwrite = FALSE, - verbose = FALSE) +predict_subdaily_met(outfolder, in.path, in.prefix, path.train, + direction.filter, lm.models.base, yrs.predict = NULL, ens.labs = 1:3, + resids = FALSE, parallel = FALSE, cores.max = 12, n.cores = NULL, + overwrite = FALSE, verbose = FALSE, seed = format(Sys.time(), "\%m\%d"), + print.progress = FALSE, ...) } \arguments{ \item{outfolder}{- directory where output file will be stored} @@ -16,23 +17,29 @@ predict_subdaily_met(outfolder, in.path, in.prefix, lm.models.base, \item{in.prefix}{- prefix of model dataset, i.e. if file is GFDL.CM3.rcp45.r1i1p1.2006 the prefix is 'GFDL.CM3.rcp45.r1i1p1'} -\item{lm.models.base}{- path to linear regression model folder from 3_gen_subdaily} +\item{path.train}{- path to CF/PEcAn style training data where each year is in a separate file.} -\item{dat.train_file}{- location of train_data file} +\item{direction.filter}{- Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") +(PalEON will go backwards, anybody interested in the future will go forwards)} -\item{start_date}{- yyyy-mm-dd} +\item{lm.models.base}{- path to linear regression model folders generated using gen.subdaily.models} -\item{end_date}{- yyyy-mm-dd} +\item{yrs.predict}{- years for which you want to generate met. if NULL, all years in in.path will be done} -\item{cores.max}{- 12} - -\item{n.ens}{- integer selecting number of hourly ensemble members} +\item{ens.labs}{- vector containing the labels (suffixes) for each ensemble member; this allows you to add to your +ensemble rather than overwriting with a default naming scheme} \item{resids}{- logical stating whether to pass on residual data or not} \item{parallel}{- logical stating whether to run temporal_downscale_functions.R in parallel} +\item{cores.max}{- 12} + \item{n.cores}{- deals with parallelization} + +\item{seed}{- manually set seed for results to be reproducible} + +\item{print.progress}{- print the progress bar?} } \description{ This is the main function of the tdm family workflow. This function predicts subdaily meteorology diff --git a/modules/data.atmosphere/man/temporal.downscale.functions.Rd b/modules/data.atmosphere/man/temporal.downscale.functions.Rd index 01b503a1504..6d47d4ebfe5 100644 --- a/modules/data.atmosphere/man/temporal.downscale.functions.Rd +++ b/modules/data.atmosphere/man/temporal.downscale.functions.Rd @@ -6,7 +6,7 @@ \usage{ temporal.downscale.functions(dat.train, n.beta, day.window, resids = FALSE, parallel = FALSE, n.cores = NULL, seed = format(Sys.time(), "\%m\%d"), - outfolder, in.prefix, ...) + outfolder, print.progress = FALSE, ...) } \arguments{ \item{dat.train}{- training data generated by tdm_nc2dat.train.R} @@ -25,7 +25,11 @@ still being worked on, set to FALSE} \item{seed}{- allows this to be reproducible} +\item{print.progress}{- print progress of model generation?} + \item{path.out}{- path to where the training models & betas will be stored} + +\item{outfoulder}{= where the output should be stored} } \description{ This function contains the functions that do the heavy lifting in gen.subdaily.models() From 0faa7ee890912e0a09b130e8ce51bfda72d4cb7f Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Wed, 13 Sep 2017 16:53:09 -0500 Subject: [PATCH 617/771] More missing PEcAn.remote references --- base/settings/R/check.all.settings.R | 2 +- base/utils/R/do_conversions.R | 2 +- base/utils/inst/LBNL_remote_test.R | 2 +- modules/data.land/inst/LoadPalEONsites.R | 4 ++-- web/workflow.R | 4 ++-- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/base/settings/R/check.all.settings.R b/base/settings/R/check.all.settings.R index 41a93e91a05..937fd2ec754 100644 --- a/base/settings/R/check.all.settings.R +++ b/base/settings/R/check.all.settings.R @@ -389,7 +389,7 @@ check.settings <- function(settings, force=FALSE) { } # make sure remote folders are specified if need be - if (!is.localhost(settings$host)) { + if (!PEcAn.remote::is.localhost(settings$host)) { if (is.null(settings$host$folder)) { settings$host$folder <- paste0(remote.execute.cmd("pwd", host=settings$host), "/pecan_remote") PEcAn.logger::logger.info("Using ", settings$host$folder, "to store output on remote machine") diff --git a/base/utils/R/do_conversions.R b/base/utils/R/do_conversions.R index 25e25d11561..1e3075b5a52 100644 --- a/base/utils/R/do_conversions.R +++ b/base/utils/R/do_conversions.R @@ -15,7 +15,7 @@ do_conversions <- function(settings, overwrite.met = FALSE, overwrite.fia = FALS } dbfiles.local <- settings$database$dbfiles - dbfiles <- ifelse(!PEcAn.utils::is.localhost(settings$host) & !is.null(settings$host$folder), settings$host$folder, dbfiles.local) + dbfiles <- ifelse(!PEcAn.remote::is.localhost(settings$host) & !is.null(settings$host$folder), settings$host$folder, dbfiles.local) PEcAn.logger::logger.debug("do.conversion outdir",dbfiles) for (i in seq_along(settings$run$inputs)) { diff --git a/base/utils/inst/LBNL_remote_test.R b/base/utils/inst/LBNL_remote_test.R index 2e07f2e8158..941b6d48bfe 100644 --- a/base/utils/inst/LBNL_remote_test.R +++ b/base/utils/inst/LBNL_remote_test.R @@ -53,4 +53,4 @@ d <- PEcAn.remote::remote.execute.R(script = "return(.libPaths())",host = host,R ## kill tunnels -PEcAn.utils::kill.tunnel(settings) +PEcAn.remote::kill.tunnel(settings) diff --git a/modules/data.land/inst/LoadPalEONsites.R b/modules/data.land/inst/LoadPalEONsites.R index b5b0b50c347..9cb07162aab 100644 --- a/modules/data.land/inst/LoadPalEONsites.R +++ b/modules/data.land/inst/LoadPalEONsites.R @@ -183,7 +183,7 @@ for(i in seq_along(paleon.sitegroups)){ ## establish remote tunnel library(getPass) host <- list(name="geo.bu.edu",tunnel="~/.pecan/tunnel/") -is.open <- open_tunnel(host$name,host$tunnel) +is.open <- PEcAn.remote::open_tunnel(host$name,host$tunnel) if(!is.open){ print("Could not open remote tunnel") } else { @@ -262,7 +262,7 @@ for(i in c(1:5,7)){ } -PEcAn.utils::kill.tunnel(list(host=host)) +PEcAn.remote::kill.tunnel(list(host=host)) ################################## ### merge in CO2 into met data diff --git a/web/workflow.R b/web/workflow.R index be300da9450..3f6cc7346db 100755 --- a/web/workflow.R +++ b/web/workflow.R @@ -19,7 +19,7 @@ library(RCurl) options(warn=1) options(error=quote({ PEcAn.utils::status.end("ERROR") - PEcAn.utils::kill.tunnel(settings) + PEcAn.remote::kill.tunnel(settings) if (!interactive()) { q() } @@ -161,7 +161,7 @@ if("benchmarking" %in% names(settings)){ # Pecan workflow complete if (PEcAn.utils::status.check("FINISHED") == 0) { PEcAn.utils::status.start("FINISHED") - kill.tunnel(settings) + PEcAn.remote::kill.tunnel(settings) db.query(paste("UPDATE workflows SET finished_at=NOW() WHERE id=", settings$workflow$id, "AND finished_at IS NULL"), params=settings$database$bety) # Send email if configured From 35dfd2c6f5df8dc1de4d61270d7910f8b458f330 Mon Sep 17 00:00:00 2001 From: annethomas Date: Wed, 13 Sep 2017 18:50:31 -0400 Subject: [PATCH 618/771] update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index d787db0271e..b1683579c8b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -23,6 +23,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Cleanup of leap year logic, using new `PEcAn.utils::days_in_year(year)` function (#801). - Replace many hard-coded unit conversions with `udunits2::ud.convert` for consistency, readability, and clarity - Added a new retry.func() to base/utils to provide ability to re-try a function X times before stopping. Currently using this function in the download.CRUNCEP() function to handle slow responses from THREDDS. +-Reformatted call_MODIS netcdf output ### Added - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) From 22d222d7505b248cbd582b6321febaa38b039f28 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 14 Sep 2017 09:43:39 -0500 Subject: [PATCH 619/771] Bugfix cos_solar_zenith_angle function --- models/ed/R/met2model.ED2.R | 2 +- modules/data.atmosphere/R/metgapfill.R | 2 +- modules/data.atmosphere/R/solar_angle.R | 3 ++- modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R | 2 +- modules/data.atmosphere/man/cos_solar_zenith_angle.Rd | 4 +++- 5 files changed, 8 insertions(+), 5 deletions(-) diff --git a/models/ed/R/met2model.ED2.R b/models/ed/R/met2model.ED2.R index d5f20966fbe..a2aa65d016e 100644 --- a/models/ed/R/met2model.ED2.R +++ b/models/ed/R/met2model.ED2.R @@ -190,7 +190,7 @@ met2model.ED2 <- function(in.path, in.prefix, outfolder, start_date, end_date, l ## calculate potential radiation in order to estimate diffuse/direct - cosz <- PEcAn.data.atmosphere::cos_solar_zenith_angle(doy, lat, lon, dt) + cosz <- PEcAn.data.atmosphere::cos_solar_zenith_angle(doy, lat, lon, dt, hr) rpot <- 1366 * cosz rpot <- rpot[1:length(SW)] diff --git a/modules/data.atmosphere/R/metgapfill.R b/modules/data.atmosphere/R/metgapfill.R index 7d2ba0b6f82..2eb415563f5 100644 --- a/modules/data.atmosphere/R/metgapfill.R +++ b/modules/data.atmosphere/R/metgapfill.R @@ -166,7 +166,7 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst doy <- rep(seq_len(diy), each = 86400 / dt) hr <- rep(seq(0, length = 86400 / dt, by = 24 * dt / 86400), diy) - cosz <- PEcAn.data.atmosphere::cos_solar_zenith_angle(doy, lat, lon, dt) + cosz <- PEcAn.data.atmosphere::cos_solar_zenith_angle(doy, lat, lon, dt, hr) rpot <- 1366 * cosz #in UTC tz <- as.numeric(lst) diff --git a/modules/data.atmosphere/R/solar_angle.R b/modules/data.atmosphere/R/solar_angle.R index 4b64d393eec..30a9b0a024b 100644 --- a/modules/data.atmosphere/R/solar_angle.R +++ b/modules/data.atmosphere/R/solar_angle.R @@ -7,9 +7,10 @@ #' @param lat Latitude #' @param lon Longitude #' @param dt Timestep +#' @param hr Hours timestep #' @return `numeric(1)` of cosine of solar zenith angle #' @export -cos_solar_zenith_angle <- function(doy, lat, lon, dt) { +cos_solar_zenith_angle <- function(doy, lat, lon, dt, hr) { et <- equation_of_time(doy) merid <- floor(lon / 15) * 15 merid[merid < 0] <- merid[merid < 0] + 15 diff --git a/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R b/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R index 7ed9f0b9f5f..bde68b81d0a 100644 --- a/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R +++ b/modules/data.atmosphere/inst/scripts/ORNL_FACE_MET.v2.R @@ -52,7 +52,7 @@ dat <- read.table(fname,header=TRUE) ## calculate potential radiation ## in order to estimate diffuse/direct - cosz <- PEcAn.data.atmosphere::cos_solar_zenith_angle(doy, lat, lon, dt) + cosz <- PEcAn.data.atmosphere::cos_solar_zenith_angle(doy, lat, lon, dt, hr) rpot <- 1366*cosz rpot <- rpot[1:n] diff --git a/modules/data.atmosphere/man/cos_solar_zenith_angle.Rd b/modules/data.atmosphere/man/cos_solar_zenith_angle.Rd index e07ed88b670..faf57b64313 100644 --- a/modules/data.atmosphere/man/cos_solar_zenith_angle.Rd +++ b/modules/data.atmosphere/man/cos_solar_zenith_angle.Rd @@ -4,7 +4,7 @@ \alias{cos_solar_zenith_angle} \title{Cosine of solar zenith angle} \usage{ -cos_solar_zenith_angle(doy, lat, lon, dt) +cos_solar_zenith_angle(doy, lat, lon, dt, hr) } \arguments{ \item{doy}{Day of year} @@ -14,6 +14,8 @@ cos_solar_zenith_angle(doy, lat, lon, dt) \item{lon}{Longitude} \item{dt}{Timestep} + +\item{hr}{Hours timestep} } \value{ `numeric(1)` of cosine of solar zenith angle From 7fd6a4846e30f87f58733e96227e23152923bb1c Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 14 Sep 2017 11:08:00 -0400 Subject: [PATCH 620/771] write the filtered data, because it overwrites obs later --- modules/assim.batch/R/pda.load.data.R | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/modules/assim.batch/R/pda.load.data.R b/modules/assim.batch/R/pda.load.data.R index de89a450e5e..a4e59401fc1 100644 --- a/modules/assim.batch/R/pda.load.data.R +++ b/modules/assim.batch/R/pda.load.data.R @@ -60,10 +60,11 @@ load.pda.data <- function(settings, bety) { var.obs <- colnames(inputs[[i]]$data)[!colnames(inputs[[i]]$data) %in% c("UST", "posix", "year", format$vars[format$time.row,]$bety_name)] - AMFo <- inputs[[i]]$data[[var.obs]] - UST <- inputs[[i]]$data$UST - AMFo[AMFo == -9999] <- NA - AMFo[UST < ustar.thresh] <- NA + AMFo <- inputs[[i]]$data[[var.obs]] + UST <- inputs[[i]]$data$UST + AMFo[AMFo == -9999] <- NA + AMFo[UST < ustar.thresh] <- NA + inputs[[i]]$data[[var.obs]] <- AMFo # write filtered data # Have to just pretend like these quality control variables exist... AMFq <- rep(0, length(AMFo)) From e46d6f209d789f185e760f39fd6221c0e160d52b Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 14 Sep 2017 11:20:08 -0400 Subject: [PATCH 621/771] change default --- modules/assim.batch/R/pda.emulator.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/assim.batch/R/pda.emulator.R b/modules/assim.batch/R/pda.emulator.R index 2b91c15b49b..eaa5fcce4e0 100644 --- a/modules/assim.batch/R/pda.emulator.R +++ b/modules/assim.batch/R/pda.emulator.R @@ -177,10 +177,10 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, prior.round.fn <- lapply(prior.round.list, pda.define.prior.fn) - ## Propose a percentage (if not specified 50%) of the new parameter knots from the posterior of the previous run + ## Propose a percentage (if not specified 80%) of the new parameter knots from the posterior of the previous run knot.par <- ifelse(!is.null(settings$assim.batch$knot.par), as.numeric(settings$assim.batch$knot.par), - 0.5) + 0.8) n.post.knots <- floor(knot.par * settings$assim.batch$n.knot) From 00a75465c2d1f0ed474d639fe778f5660f0b3b36 Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 14 Sep 2017 11:26:20 -0400 Subject: [PATCH 622/771] writing heteroskedastic laplacian likelihood openly to use n_eff --- modules/assim.batch/R/pda.define.llik.R | 29 ++++++++++++++++--------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/modules/assim.batch/R/pda.define.llik.R b/modules/assim.batch/R/pda.define.llik.R index 1e3f9385327..b1211db8d5b 100644 --- a/modules/assim.batch/R/pda.define.llik.R +++ b/modules/assim.batch/R/pda.define.llik.R @@ -71,17 +71,26 @@ pda.calc.error <-function(settings, con, model_out, run.id, inputs, bias.terms){ resid <- abs(model_out[[k]] - inputs[[k]]$obs) pos <- (model_out[[k]] >= 0) - SS <- c(dexp(resid[pos], - 1 / (inputs[[k]]$par[1] + (inputs[[k]]$par[2] * - sqrt(inputs[[k]]$n_eff/inputs[[k]]$n) * - model_out[[k]][pos])), log = TRUE), - dexp(resid[!pos], - 1 / (inputs[[k]]$par[1] + (inputs[[k]]$par[3] * - sqrt(inputs[[k]]$n_eff/inputs[[k]]$n) * - model_out[[k]][!pos])), log = TRUE)) + # SS <- c(dexp(resid[pos], + # 1 / (inputs[[k]]$par[1] + (inputs[[k]]$par[2] * + # sqrt(inputs[[k]]$n_eff/inputs[[k]]$n) * + # model_out[[k]][pos])), log = TRUE), + # dexp(resid[!pos], + # 1 / (inputs[[k]]$par[1] + (inputs[[k]]$par[3] * + # sqrt(inputs[[k]]$n_eff/inputs[[k]]$n) * + # model_out[[k]][!pos])), log = TRUE)) + # + # pda.errors[[k]] <- sum(SS, na.rm = TRUE) + # SSdb[[k]] <- sum(SS, na.rm = TRUE) - pda.errors[[k]] <- sum(SS, na.rm = TRUE) - SSdb[[k]] <- sum(SS, na.rm = TRUE) + beta_p <- (inputs[[k]]$par[1] + inputs[[k]]$par[2] * model_out[[k]][pos]* sqrt(inputs[[k]]$n/inputs[[k]]$n_eff) ) + beta_n <- (inputs[[k]]$par[1] + inputs[[k]]$par[3] * model_out[[k]][!pos]* sqrt(inputs[[k]]$n/inputs[[k]]$n_eff)) + if(length(beta_n) == 0) beta_n <- 0 + SS_p <- - (inputs[[k]]$n_eff/inputs[[k]]$n) * log(beta_p) - resid[[1]][pos]/beta_p + SS_n <- - (inputs[[k]]$n_eff/inputs[[k]]$n) * log(beta_n) - resid[[1]][!pos]/beta_n + if(length(SS_n) == 0) SS_n <- 0 + pda.errors[[k]] <- sum(SS_p, SS_n, na.rm = TRUE) + SSdb[[k]] <- pda.errors[[k]] } else if (settings$assim.batch$inputs[[k]]$likelihood == "multipGauss") { # multiplicative Gaussian From b9ff1897b4e72c4b159cd2b878c6b7c97aa5663e Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 14 Sep 2017 11:27:43 -0400 Subject: [PATCH 623/771] suppress known warnings --- modules/assim.batch/R/pda.define.llik.R | 4 ++-- modules/assim.batch/R/pda.utils.R | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/assim.batch/R/pda.define.llik.R b/modules/assim.batch/R/pda.define.llik.R index b1211db8d5b..300a6804cdd 100644 --- a/modules/assim.batch/R/pda.define.llik.R +++ b/modules/assim.batch/R/pda.define.llik.R @@ -85,10 +85,10 @@ pda.calc.error <-function(settings, con, model_out, run.id, inputs, bias.terms){ beta_p <- (inputs[[k]]$par[1] + inputs[[k]]$par[2] * model_out[[k]][pos]* sqrt(inputs[[k]]$n/inputs[[k]]$n_eff) ) beta_n <- (inputs[[k]]$par[1] + inputs[[k]]$par[3] * model_out[[k]][!pos]* sqrt(inputs[[k]]$n/inputs[[k]]$n_eff)) - if(length(beta_n) == 0) beta_n <- 0 + suppressWarnings(if(length(beta_n) == 0) beta_n <- 0) SS_p <- - (inputs[[k]]$n_eff/inputs[[k]]$n) * log(beta_p) - resid[[1]][pos]/beta_p SS_n <- - (inputs[[k]]$n_eff/inputs[[k]]$n) * log(beta_n) - resid[[1]][!pos]/beta_n - if(length(SS_n) == 0) SS_n <- 0 + suppressWarnings(if(length(SS_n) == 0) SS_n <- 0) pda.errors[[k]] <- sum(SS_p, SS_n, na.rm = TRUE) SSdb[[k]] <- pda.errors[[k]] diff --git a/modules/assim.batch/R/pda.utils.R b/modules/assim.batch/R/pda.utils.R index c98433fd981..7e0dcaa58bc 100644 --- a/modules/assim.batch/R/pda.utils.R +++ b/modules/assim.batch/R/pda.utils.R @@ -295,7 +295,7 @@ pda.load.priors <- function(settings, con, extension.check = FALSE) { } # make sure there are no left over distributions in the environment - rm(post.distns, prior.distns) + suppressWarnings(rm(post.distns, prior.distns)) load(prior.paths[[i]]) if (!exists("post.distns")) { From 7d8f9532b3b08b255e2e9a7d23d982b947d55604 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 14 Sep 2017 11:32:14 -0500 Subject: [PATCH 624/771] Remote bugfixes, and some met2model.SIPNET cleanup --- base/remote/R/stamp.R | 6 +++--- base/remote/R/start.model.runs.R | 4 ++-- base/remote/R/start_serial.R | 4 ++-- base/remote/man/start_serial.Rd | 4 +++- models/sipnet/R/met2model.SIPNET.R | 34 +++++++++++++++--------------- 5 files changed, 27 insertions(+), 25 deletions(-) diff --git a/base/remote/R/stamp.R b/base/remote/R/stamp.R index b34c1047a94..0b56087b7a0 100644 --- a/base/remote/R/stamp.R +++ b/base/remote/R/stamp.R @@ -8,7 +8,7 @@ stamp_started <- function(con, run) { if (!is.null(con)) { run_id_string <- format(run, scientific = TRUE) - db.query(paste("UPDATE runs SET started_at = NOW() WHERE id = ", run_id_string)) + db.query(query = paste("UPDATE runs SET started_at = NOW() WHERE id = ", run_id_string), con = con) } else { PEcAn.logger::logger.debug("Connection is null. Not actually writing timestamps to database") } @@ -19,8 +19,8 @@ stamp_started <- function(con, run) { stamp_finished <- function(con, run) { if (!is.null(con)) { run_id_string <- format(run, scientific = TRUE) - db.query(paste("UPDATE runs SET finished_at = NOW() WHERE id = ", run_id_string)) + db.query(query = paste("UPDATE runs SET finished_at = NOW() WHERE id = ", run_id_string), con = con) } else { PEcAn.logger::logger.debug("Connection is null. Not actually writing timestamps to database") } -} \ No newline at end of file +} diff --git a/base/remote/R/start.model.runs.R b/base/remote/R/start.model.runs.R index be8a405bef2..e9328679b9a 100644 --- a/base/remote/R/start.model.runs.R +++ b/base/remote/R/start.model.runs.R @@ -95,7 +95,7 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error = TRUE) { } else { # if qsub option is not invoked. just start model runs in serial. - out <- start_serial(host = settings$host, rundir = settings$rundir, host_rundir = settings$host$rundir, job_script = "job.sh") + out <- start_serial(run = run, host = settings$host, rundir = settings$rundir, host_rundir = settings$host$rundir, job_script = "job.sh") # check output to see if an error occurred during the model run check_model_run(out = out, stop.on.error = stop.on.error) @@ -136,7 +136,7 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error = TRUE) { jobids[run] <- sub(settings$host$qsub.jobid, "\\1", out) } } else { - out <- start_serial(host = settings$host, rundir = settings$rundir, host_rundir = settings$host$rundir, + out <- start_serial(run = run, host = settings$host, rundir = settings$rundir, host_rundir = settings$host$rundir, job_script = "launcher.sh") # check output to see if an error occurred during the model run diff --git a/base/remote/R/start_serial.R b/base/remote/R/start_serial.R index a9ba42d1cc3..8e85e81650a 100644 --- a/base/remote/R/start_serial.R +++ b/base/remote/R/start_serial.R @@ -4,7 +4,7 @@ #' #' @return Output of execution command, as a character (see [remote.execute.cmd()]). #' @export -start_serial <- function(host, rundir, host_rundir, job_script) { +start_serial <- function(run, host, rundir, host_rundir, job_script) { run_id_string <- format(run, scientific = FALSE) if (is.localhost(host)) { out <- system2(file.path(rundir, run_id_string, job_script), stdout = TRUE, stderr = TRUE) @@ -12,4 +12,4 @@ start_serial <- function(host, rundir, host_rundir, job_script) { out <- remote.execute.cmd(host, file.path(host_rundir, run_id_string, job_script), stderr = TRUE) } return(out) -} \ No newline at end of file +} diff --git a/base/remote/man/start_serial.Rd b/base/remote/man/start_serial.Rd index bcf0b54d6ef..0d2853089d0 100644 --- a/base/remote/man/start_serial.Rd +++ b/base/remote/man/start_serial.Rd @@ -4,9 +4,11 @@ \alias{start_serial} \title{Start model execution in serial mode} \usage{ -start_serial(host, rundir, host_rundir, job_script) +start_serial(run, host, rundir, host_rundir, job_script) } \arguments{ +\item{run}{(numeric) run ID, as an integer} + \item{host}{Remote host, as a list or character. Usually from \code{settings$host}.} \item{rundir}{Local run directory. Usually from \code{settings$rundir}} diff --git a/models/sipnet/R/met2model.SIPNET.R b/models/sipnet/R/met2model.SIPNET.R index 534a636eee1..0510011ad51 100644 --- a/models/sipnet/R/met2model.SIPNET.R +++ b/models/sipnet/R/met2model.SIPNET.R @@ -24,7 +24,6 @@ ##' @param end_date the end date of the data to be downloaded (will only use the year part of the date) ##' @param overwrite should existing files be overwritten ##' @param verbose should the function be very verbose -##' @importFrom ncdf4 ncvar_get met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date, overwrite = FALSE, verbose = FALSE, ...) { PEcAn.logger::logger.info("START met2model.SIPNET") @@ -86,30 +85,30 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date dt <- 86400 / tstep ## extract variables - lat <- ncvar_get(nc, "latitude") - lon <- ncvar_get(nc, "longitude") - Tair <- ncvar_get(nc, "air_temperature") ## in Kelvin + lat <- ncdf4::ncvar_get(nc, "latitude") + lon <- ncdf4::ncvar_get(nc, "longitude") + Tair <-ncdf4::ncvar_get(nc, "air_temperature") ## in Kelvin Tair_C <- udunits2::ud.convert(Tair, "K", "degC") - Qair <- ncvar_get(nc, "specific_humidity") #humidity (kg/kg) - ws <- try(ncvar_get(nc, "wind_speed")) + Qair <-ncdf4::ncvar_get(nc, "specific_humidity") #humidity (kg/kg) + ws <- try(ncdf4::ncvar_get(nc, "wind_speed")) if (!is.numeric(ws)) { - U <- ncvar_get(nc, "eastward_wind") - V <- ncvar_get(nc, "northward_wind") + U <- ncdf4::ncvar_get(nc, "eastward_wind") + V <- ncdf4::ncvar_get(nc, "northward_wind") ws <- sqrt(U ^ 2 + V ^ 2) PEcAn.logger::logger.info("wind_speed absent; calculated from eastward_wind and northward_wind") } - Rain <- ncvar_get(nc, "precipitation_flux") - # pres <- ncvar_get(nc,'air_pressure') ## in pascal - SW <- ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") ## in W/m2 + Rain <- ncdf4::ncvar_get(nc, "precipitation_flux") + # pres <- ncdf4::ncvar_get(nc,'air_pressure') ## in pascal + SW <- ncdf4::ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") ## in W/m2 - PAR <- try(ncvar_get(nc, "surface_downwelling_photosynthetic_photon_flux_in_air")) ## in mol/m2/s + PAR <- try(ncdf4::ncvar_get(nc, "surface_downwelling_photosynthetic_photon_flux_in_air")) ## in mol/m2/s if (!is.numeric(PAR)) { PAR <- SW * 0.45 PEcAn.logger::logger.info("surface_downwelling_photosynthetic_photon_flux_in_air absent; PAR set to SW * 0.45") } - soilT <- try(ncvar_get(nc, "soil_temperature")) + soilT <- try(ncdf4::ncvar_get(nc, "soil_temperature")) if (!is.numeric(soilT)) { # approximation borrowed from SIPNET CRUNCEPpreprocessing's tsoil.py tau <- 15 * tstep @@ -122,14 +121,15 @@ met2model.SIPNET <- function(in.path, in.prefix, outfolder, start_date, end_date soilT <- udunits2::ud.convert(soilT, "K", "degC") } - SVP <- udunits2::ud.convert(get.es(Tair_C), "millibar", "Pa") ## Saturation vapor pressure - VPD <- try(ncvar_get(nc, "water_vapor_saturation_deficit")) ## in Pa + SVP <- udunits2::ud.convert(PEcAn.data.atmosphere::get.es(Tair_C), "millibar", "Pa") ## Saturation vapor pressure + VPD <- try(ncdf4::ncvar_get(nc, "water_vapor_saturation_deficit")) ## in Pa if (!is.numeric(VPD)) { - VPD <- SVP * (1 - qair2rh(Qair, Tair_C)) + VPD <- SVP * (1 - PEcAn.data.atmosphere::qair2rh(Qair, Tair_C)) PEcAn.logger::logger.info("water_vapor_saturation_deficit absent; VPD calculated from Qair, Tair, and SVP (saturation vapor pressure) ") } e_a <- SVP - VPD - VPDsoil <- udunits2::ud.convert(get.es(soilT), "millibar", "Pa") * (1 - qair2rh(Qair, soilT)) + VPDsoil <- udunits2::ud.convert(PEcAn.data.atmosphere::get.es(soilT), "millibar", "Pa") * + (1 - PEcAn.data.atmosphere::qair2rh(Qair, soilT)) ncdf4::nc_close(nc) } else { From 78d19b9baf46f79a9bc11561df5f45a251507864 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 14 Sep 2017 11:39:21 -0500 Subject: [PATCH 625/771] data.atmosphere: Bugfix metgapfill --- modules/data.atmosphere/R/metgapfill.R | 36 +++++++++++++------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/modules/data.atmosphere/R/metgapfill.R b/modules/data.atmosphere/R/metgapfill.R index 2eb415563f5..8f726323b16 100644 --- a/modules/data.atmosphere/R/metgapfill.R +++ b/modules/data.atmosphere/R/metgapfill.R @@ -328,31 +328,31 @@ metgapfill <- function(in.path, in.prefix, outfolder, start_date, end_date, lst ## make a data frame, convert -9999 to NA, convert to degrees C EddyData.F <- data.frame(Tair, Rg, rH, PAR, precip, sHum, Lw, Ts1, VPD, ws, co2, press, east_wind, north_wind) - EddyData.F["Tair"] <- udunits2::ud.convert(EddyData.F["Tair"], "K", "degC") - EddyData.F["Tair"] <- EddyData.F["Tair"] - EddyData.F["Ts1"] <- udunits2::ud.convert(EddyData.F["Ts1"], "K", "degC") - EddyData.F["VPD"] <- udunits2::ud.convert(EddyData.F["VPD"], "Pa", "kPa") + EddyData.F[["Tair"]] <- udunits2::ud.convert(EddyData.F[["Tair"]], "K", "degC") + EddyData.F[["Tair"]] <- EddyData.F[["Tair"]] + EddyData.F[["Ts1"]] <- udunits2::ud.convert(EddyData.F[["Ts1"]], "K", "degC") + EddyData.F[["VPD"]] <- udunits2::ud.convert(EddyData.F[["VPD"]], "Pa", "kPa") ## Optional need: ## Compute VPD EddyData.F <- cbind(EddyData.F,VPD=fCalcVPDfromRHandTair(EddyData.F$rH, EddyData.F$Tair)) ## Estimate number of good values, don't gap fill if no gaps or all gaps - n_Tair <- sum(is.na(EddyData.F["Tair"])) - n_Rg <- sum(is.na(EddyData.F["Rg"])) - n_rH <- sum(is.na(EddyData.F["rH"])) - n_PAR <- sum(is.na(EddyData.F["PAR"])) - n_precip <- sum(is.na(EddyData.F["precip"])) + n_Tair <- sum(is.na(EddyData.F[["Tair"]])) + n_Rg <- sum(is.na(EddyData.F[["Rg"]])) + n_rH <- sum(is.na(EddyData.F[["rH"]])) + n_PAR <- sum(is.na(EddyData.F[["PAR"]])) + n_precip <- sum(is.na(EddyData.F[["precip"]])) # n_Rn <- sum(is.na(EddyData.F['Rn'])) - n_sHum <- sum(is.na(EddyData.F["sHum"])) - n_Lw <- sum(is.na(EddyData.F["Lw"])) - n_Ts1 <- sum(is.na(EddyData.F["Ts1"])) + n_sHum <- sum(is.na(EddyData.F[["sHum"]])) + n_Lw <- sum(is.na(EddyData.F[["Lw"]])) + n_Ts1 <- sum(is.na(EddyData.F[["Ts1"]])) # n_Ts2 <- sum(is.na(EddyData.F['Ts2'])) - n_VPD <- sum(is.na(EddyData.F["VPD"])) - n_ws <- sum(is.na(EddyData.F["ws"])) - n_co2 <- sum(is.na(EddyData.F["co2"])) - n_press <- sum(is.na(EddyData.F["press"])) - n_east_wind <- sum(is.na(EddyData.F["east_wind"])) - n_north_wind <- sum(is.na(EddyData.F["north_wind"])) + n_VPD <- sum(is.na(EddyData.F[["VPD"]])) + n_ws <- sum(is.na(EddyData.F[["ws"]])) + n_co2 <- sum(is.na(EddyData.F[["co2"]])) + n_press <- sum(is.na(EddyData.F[["press"]])) + n_east_wind <- sum(is.na(EddyData.F[["east_wind"]])) + n_north_wind <- sum(is.na(EddyData.F[["north_wind"]])) # figure out datetime of nc file and convert to POSIX nelem <- length(time) From 725a68a351d02f028fd5f85c973c7d4c11440c3a Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 14 Sep 2017 12:52:12 -0400 Subject: [PATCH 626/771] add missing write_sf_posterior function --- modules/assim.batch/NAMESPACE | 2 ++ modules/assim.batch/R/pda.emulator.R | 7 ++++--- modules/assim.batch/R/pda.postprocess.R | 28 +++++++++++++++++++++++++ 3 files changed, 34 insertions(+), 3 deletions(-) diff --git a/modules/assim.batch/NAMESPACE b/modules/assim.batch/NAMESPACE index c3edb676e77..c7f10e5afe8 100644 --- a/modules/assim.batch/NAMESPACE +++ b/modules/assim.batch/NAMESPACE @@ -21,6 +21,7 @@ export(pda.create.ensemble) export(pda.define.llik.fn) export(pda.define.prior.fn) export(pda.emulator) +export(pda.emulator.ms) export(pda.generate.knots) export(pda.generate.sf) export(pda.get.model.output) @@ -37,5 +38,6 @@ export(pda.settings) export(pda.settings.bt) export(return.bias) export(runModule.assim.batch) +export(write_sf_posterior) import(IDPmisc) import(ellipse) diff --git a/modules/assim.batch/R/pda.emulator.R b/modules/assim.batch/R/pda.emulator.R index eaa5fcce4e0..f56bae14d80 100644 --- a/modules/assim.batch/R/pda.emulator.R +++ b/modules/assim.batch/R/pda.emulator.R @@ -531,7 +531,7 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, current.step <- "post-MCMC" save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) - mcmc.samp.list <- list() + mcmc.samp.list <- sf.samp.list <- list() for (c in seq_len(settings$assim.batch$chain)) { @@ -637,9 +637,10 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, # save sf posterior if(!is.null(sf)){ sf.filename <- file.path(settings$outdir, - paste0("post.distns.pda.sf", "_", settings$assim.batch$ensemble.id, ".Rdata")) + paste0("posteriors.pda.sf", "_", settings$assim.batch$ensemble.id, ".Rdata")) sf.prior <- prior.list[[sf.ind]] - write_sf_posterior(sf.samp.list, sf.prior, sf.filename) + sf.post.distns <- write_sf_posterior(sf.samp.list, sf.prior, sf.filename) + save(sf.post.distns, file = sf.filename) settings$assim.batch$sf.path <- sf.filename } diff --git a/modules/assim.batch/R/pda.postprocess.R b/modules/assim.batch/R/pda.postprocess.R index 64f36061fd7..0206a41aa82 100644 --- a/modules/assim.batch/R/pda.postprocess.R +++ b/modules/assim.batch/R/pda.postprocess.R @@ -224,3 +224,31 @@ pda.plot.params <- function(settings, mcmc.param.list, prior.ind, par.file.name } # pda.plot.params +##' Function to write posterior distributions of the scaling factors +##' @export +write_sf_posterior <- function(sf.samp.list, sf.prior, sf.filename){ + + sf.samp <- as.mcmc.list(lapply(sf.samp.list, mcmc)) + + burnin <- getBurnin(sf.samp, method = "gelman.plot") + + sf.samp <- window(sf.samp, start = max(burnin, na.rm = TRUE)) + + # convert mcmc.list to list of matrices + sf.subset.list <- list() + sf.subset.list[[1]] <- do.call("rbind", sf.samp) + + # reformat each sublist such that params have their own list and return + sf.subset <- lapply(seq_along(sf.subset.list), function(x) as.list(data.frame(sf.subset.list[[x]]))) + + filename.flag <- gsub(".*posteriors\\s*|.Rdata.*", "", basename(sf.filename)) + + sf.post.distns <- PEcAn.MA::approx.posterior(trait.mcmc = sf.subset[[1]], priors = sf.prior, + outdir = dirname(sf.filename), + filename.flag = filename.flag) + + save(sf.subset, file = file.path(dirname(sf.filename), paste0("samples", filename.flag, ".Rdata"))) + + return(sf.post.distns) + +} # write_sf_posterior From b8c8b792b23ff1c668737f146bc84ea2ed53ef52 Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 14 Sep 2017 12:55:30 -0400 Subject: [PATCH 627/771] take emulator.ms out from roxygen --- modules/assim.batch/NAMESPACE | 1 - modules/assim.batch/man/write_sf_posterior.Rd | 11 +++++++++++ 2 files changed, 11 insertions(+), 1 deletion(-) create mode 100644 modules/assim.batch/man/write_sf_posterior.Rd diff --git a/modules/assim.batch/NAMESPACE b/modules/assim.batch/NAMESPACE index c7f10e5afe8..908747a217c 100644 --- a/modules/assim.batch/NAMESPACE +++ b/modules/assim.batch/NAMESPACE @@ -21,7 +21,6 @@ export(pda.create.ensemble) export(pda.define.llik.fn) export(pda.define.prior.fn) export(pda.emulator) -export(pda.emulator.ms) export(pda.generate.knots) export(pda.generate.sf) export(pda.get.model.output) diff --git a/modules/assim.batch/man/write_sf_posterior.Rd b/modules/assim.batch/man/write_sf_posterior.Rd new file mode 100644 index 00000000000..727ca550e93 --- /dev/null +++ b/modules/assim.batch/man/write_sf_posterior.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pda.postprocess.R +\name{write_sf_posterior} +\alias{write_sf_posterior} +\title{Function to write posterior distributions of the scaling factors} +\usage{ +write_sf_posterior(sf.samp.list, sf.prior, sf.filename) +} +\description{ +Function to write posterior distributions of the scaling factors +} From 74dee46b2b8f5f33b839c4f8bfea7d099b87d5d2 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Thu, 14 Sep 2017 12:57:17 -0400 Subject: [PATCH 628/771] adding met --- .../Adding-an-Input-Converter.Rmd | 79 +++++++++++++++---- .../How-to-insert-new-Input-data.Rmd | 4 +- book_source/workflow/met_processing.RMD | 16 ++++ 3 files changed, 82 insertions(+), 17 deletions(-) create mode 100644 book_source/workflow/met_processing.RMD diff --git a/book_source/developers_guide/Adding-an-Input-Converter.Rmd b/book_source/developers_guide/Adding-an-Input-Converter.Rmd index 3471b4329c1..3e218029979 100755 --- a/book_source/developers_guide/Adding-an-Input-Converter.Rmd +++ b/book_source/developers_guide/Adding-an-Input-Converter.Rmd @@ -1,21 +1,19 @@ -General Note: dates in the database should be datatime (preferably with timezone), and datetime passed around in PEcAn should be of type POSIXlt. +# How to Add an Input Converter -# Met Data +## Meterological Data conversion -The standard met data inputs should be of the form: +In general, you will need to write a function to download the raw met data andone to convert it to the PEcAn standard. -Converters from a raw to standard format go in `/modules/data.atmosphere/R`; converters from standard to model-specific go in `models//R`. +Downloading raw data function are named `download..R`. Example functions can be found within the PEcAn directory [`/modules/data.atmosphere/R`](https://github.com/PecanProject/pecan/tree/develop/modules/data.atmosphere/R). -* For a number of common gridded products (NARR, CRUNCEP, ISIMIP), there are bash scripts for converting and rechunking in this repository: https://github.com/ebimodeling/model-drivers; these are not generalized, but may be merged into PEcAn at some point. +Conversion function from raw to standard are named `met2CF..R`. Example functions can be found within the PEcAn directory [`/modules/data.atmosphere/R`](https://github.com/PecanProject/pecan/tree/develop/modules/data.atmosphere/R). -Examples: -* NARR: -* CRUNCEP: -* ISIMIP: +Current Meteorological products that are coupled to PEcAn can be found in our [Available Meterological Drivers] page. -Names should be `met2CF.` and `met2model.`. +Note: You will not need to write a script to convert from PEcAn standard to PEcAn models. Those conversoin scripts are written when a model is added and can be found within each model's PEcAn directory. + +### Dimensions: -## Dimensions: |CF standard-name | units | |:------------------------------------------|:------| @@ -23,7 +21,10 @@ Names should be `met2CF.` and `met2model.`. | longitude | degrees_east| | latitude |degrees_north| -## The variable names should be `standard_name` +General Note: dates in the database should be date-time (preferably with timezone), and datetime passed around in PEcAn should be of type POSIXct. + + +### The variable names should be `standard_name` | CF standard-name | units | bety | isimip | cruncep | narr | ameriflux | |:------------------------------------------|:------|:-------------|:-------------|:--------|:------|:----------| @@ -48,14 +49,62 @@ Names should be `met2CF.` and `met2model.`. * preferred variables indicated in bold * wind_direction has no CF equivalent and should not be converted, instead the met2CF functions should convert wind_direction and wind_speed to eastward_wind and northward_wind -* variable names are from [MsTMIP](http://nacp.ornl.gov/MsTMIP_variables.shtml), but lowercase to be consistent with the MsTMIP drivers. * standard_name is CF-convention standard names * units can be converted by udunits, so these can vary (e.g. the time denominator may change with time frequency of inputs) * soil moisture for the full column, rather than a layer, is soil_moisture_content +* A full list of PEcAn standard variable names, units and dimensions can be found here: https://github.com/PecanProject/pecan/blob/develop/base/utils/data/standard_vars.csv -For the standardized files, we are using CF standard names as variable names. For example, in the [MsTMIP-CRUNCEP](https://www.betydb.org/inputs/280) data, the variable `rain` should be `precipitation_rate`. We want to standardize the units as well as part of the `met2CF.` step. I believe we want to use the CF "canonical" units but retain the MsTMIP units any time CF is ambiguous about the units. -The key is to process each type of met data (site, reanalysis, forecast, climate scenario, etc) to the exact same standard. This way every operation after that (extract, gap fill, downscale, convert to a model, etc) will always have the exact same inputs. This will make everything else much simpler to code and allow us to avoid a lot of unnecessary data checking, tests, etc being repeated in every downstream function. \ No newline at end of file +The key is to process each type of met data (site, reanalysis, forecast, climate scenario, etc) to the exact same standard. This way every operation after that (extract, gap fill, downscale, convert to a model, etc) will always have the exact same inputs. This will make everything else much simpler to code and allow us to avoid a lot of unnecessary data checking, tests, etc being repeated in every downstream function. + +### Adding Single-Site Specific Meteorological Data + +Perhaps you have meteorological data specific to one site, with a unique format that you would like to add to PEcAn. Your steps would be to: + 1. write a script or function to convert your files into the netcdf PEcAn standard + 2. insert that file as an input record for your site following these [instructions](How to Insert new Input Data) + +### Downloading Met data outside of the workflow + +Perhaps you would like to obtain data from one of the sources coupled to PEcAn on its own. To do so you can run PEcAn functions on their own. + +Example 1: + +Downloading Amerifluxlbl from Niwot Ridge for the year 2004: +``` +raw.file <-PEcAn.data.atmosphere::download.AmerifluxLBL(sitename = "US-NR1", + outfolder = ".", + start_date = "2004-01-01", + end_date = "2004-12-31") +``` + +If you wanted to convert it to PEcAn Standard you would subsequently execute the following: +``` +bety = list(user='bety', password='bety',host='localhost', dbname='bety', driver='PostgreSQL',write=TRUE) +con <- PEcAn.DB::db.open(bety) +bety$con <- con + +in.path <- '.' +in.prefix <- raw.file$dbfile.name +outfolder <- '.' +format.id <- 5000000002 +format <- PEcAn.DB::query.format.vars(format.id=format.id,bety = bety) +lon <- 105.54 +lat <- 40.03 +format$time_zone <- "America/Chicago" +PEcAn.data.atmosphere::met2CF.csv(in.path = in.path, + in.prefix ="US-NR1_CF", + outfolder = ".", + start_date ="2004-01-01", + end_date = "2004-01-01", + format = format) +``` +Note: The format.id is specific to the format type of the raw data. You can look up the format id in the Bety database. + + +## Cohort and Pool Data + +COMING SOON! + \ No newline at end of file diff --git a/book_source/developers_guide/How-to-insert-new-Input-data.Rmd b/book_source/developers_guide/How-to-insert-new-Input-data.Rmd index 50b5d7a89a1..1ccad7b99af 100755 --- a/book_source/developers_guide/How-to-insert-new-Input-data.Rmd +++ b/book_source/developers_guide/How-to-insert-new-Input-data.Rmd @@ -1,6 +1,6 @@ # How to Insert new Input Data -To upload model driver data [or any other model input data or data used for model calibration/validation]... +To upload model driver data or any other model input data or data used for model calibration/validation... From your BETY interface: @@ -15,7 +15,7 @@ From your BETY interface: + From the menu click RUNS then INPUTS + Click “New Input” + Select the SITE that this data is associated with the input data set - + Other required fields are a unique name for the input, the start and end dates of the data set, and the format of the data. If the data is not in a currently known format you will need to create a NEW FORMAT and possibly a [new Input Converter](Adding-an-Input-Converter.html) + + Other required fields are a unique name for the input, the start and end dates of the data set, and the format of the data. If the data is not in a currently known format you will need to create a NEW FORMAT and possibly a new input converter. Instructions on how to do that can be found here [How to Add an Input Converter] + Parent ID is an optional variable to indicated that one dataset was derived from another. + Click “Create” * Associate the DBFILE with the INPUT diff --git a/book_source/workflow/met_processing.RMD b/book_source/workflow/met_processing.RMD new file mode 100644 index 00000000000..d52a548d09d --- /dev/null +++ b/book_source/workflow/met_processing.RMD @@ -0,0 +1,16 @@ +## Meteorological Data + +The main script that handles Met Processing, is [`met.process`](https://github.com/PecanProject/pecan/blob/develop/modules/data.atmosphere/R/met.process.R). It acts as a wrapper function that calls individual modules to facilitate the processing of meteorological data from it's original form to a pecan standard, and then from that standard to model specific formats. It also handles recording these processes in the BETY database. + 1. Downloading raw data + - Currently supported products + - Example Code + 2. Converting raw data into a CF standard + - Example Code + 3. Downscaling and gapfilling + - Example Code + 4. Coverting to Model Specific format + - Example Code + + +## Downloading Raw data + PEcAn Automated downloading of raw meteorological data has simplified the often painful task of \ No newline at end of file From 2df3df0f30aeeb9092e441df9bd95dfebfad3234 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Mon, 24 Jul 2017 12:59:34 -0400 Subject: [PATCH 629/771] Show correct format for pecan.clowder.xml --- modules/data.atmosphere/R/download.Geostreams.R | 17 ++++++++++++++++- .../data.atmosphere/man/download.Geostreams.Rd | 17 ++++++++++++++++- 2 files changed, 32 insertions(+), 2 deletions(-) diff --git a/modules/data.atmosphere/R/download.Geostreams.R b/modules/data.atmosphere/R/download.Geostreams.R index 73a60279234..ff71798536b 100644 --- a/modules/data.atmosphere/R/download.Geostreams.R +++ b/modules/data.atmosphere/R/download.Geostreams.R @@ -1,7 +1,7 @@ #' Download Geostreams data from Clowder API #' #' @param outfolder directory in which to save json result. Will be created if necessary -#' @param sitename character. Should match a geostreams sensor_name +#' @param sitename character. Must match a Geostreams sensor_name #' @param start_date,end_date datetime #' @param url base url for Clowder host #' @param key,user,pass authentication info for Clowder host. @@ -13,6 +13,21 @@ #' `~/.pecan.clowder.xml`, and finally if no keys or passwords are found there it #' attempts to connect unauthenticated. #' +#' If using `~/.pecan.clowder.xml`, it must be a valid PEcAn-formatted XML settings +#' file and must contain a \code{} key that specifies hostname, user, and +#' password for your Clowder server: +#' +#' \code{\preformatted{ +#' +#' +#' +#' terraref.ncsa.illinois.edu +#' yourname +#' superSecretPassw0rd +#' +#' +#' }} +#' #' @export #' @author Harsh Agrawal, Chris Black #' @examples \dontrun{ diff --git a/modules/data.atmosphere/man/download.Geostreams.Rd b/modules/data.atmosphere/man/download.Geostreams.Rd index d450f354908..aa105db6df0 100644 --- a/modules/data.atmosphere/man/download.Geostreams.Rd +++ b/modules/data.atmosphere/man/download.Geostreams.Rd @@ -11,7 +11,7 @@ download.Geostreams(outfolder, sitename, start_date, end_date, \arguments{ \item{outfolder}{directory in which to save json result. Will be created if necessary} -\item{sitename}{character. Should match a geostreams sensor_name} +\item{sitename}{character. Must match a Geostreams sensor_name} \item{start_date, end_date}{datetime} @@ -31,6 +31,21 @@ Depending on the setup of your Clowder host, authentication may be by then if these are NULL it looks in the user's home directory for a file named `~/.pecan.clowder.xml`, and finally if no keys or passwords are found there it attempts to connect unauthenticated. + +If using `~/.pecan.clowder.xml`, it must be a valid PEcAn-formatted XML settings + file and must contain a \code{} key that specifies hostname, user, and + password for your Clowder server: + +\code{\preformatted{ + + + + terraref.ncsa.illinois.edu + yourname + superSecretPassw0rd + + +}} } \examples{ \dontrun{ From fde9706453ff316d64267d527002935f19eed54f Mon Sep 17 00:00:00 2001 From: Chris Black Date: Mon, 24 Jul 2017 14:06:37 -0400 Subject: [PATCH 630/771] typo --- modules/data.atmosphere/R/download.Geostreams.R | 2 +- modules/data.atmosphere/man/download.Geostreams.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.atmosphere/R/download.Geostreams.R b/modules/data.atmosphere/R/download.Geostreams.R index ff71798536b..8b1e9ca9108 100644 --- a/modules/data.atmosphere/R/download.Geostreams.R +++ b/modules/data.atmosphere/R/download.Geostreams.R @@ -18,7 +18,7 @@ #' password for your Clowder server: #' #' \code{\preformatted{ -#' +#' #' #' #' terraref.ncsa.illinois.edu diff --git a/modules/data.atmosphere/man/download.Geostreams.Rd b/modules/data.atmosphere/man/download.Geostreams.Rd index aa105db6df0..4854cce420f 100644 --- a/modules/data.atmosphere/man/download.Geostreams.Rd +++ b/modules/data.atmosphere/man/download.Geostreams.Rd @@ -37,7 +37,7 @@ If using `~/.pecan.clowder.xml`, it must be a valid PEcAn-formatted XML settings password for your Clowder server: \code{\preformatted{ - + terraref.ncsa.illinois.edu From c076abfe1f670d1b56b77ef51a1e4046372ad541 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 14 Sep 2017 13:06:05 -0500 Subject: [PATCH 631/771] Update SIPNET NAMESPACE --- models/sipnet/NAMESPACE | 1 - 1 file changed, 1 deletion(-) diff --git a/models/sipnet/NAMESPACE b/models/sipnet/NAMESPACE index 8b2a9b38ae8..f987f3ab4aa 100644 --- a/models/sipnet/NAMESPACE +++ b/models/sipnet/NAMESPACE @@ -10,4 +10,3 @@ export(split_inputs.SIPNET) export(write.config.SIPNET) export(write_restart.SIPNET) import(PEcAn.utils) -importFrom(ncdf4,ncvar_get) From d2aa22b655fd6d98275e5a4d560d20f1495a7443 Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 14 Sep 2017 14:14:14 -0400 Subject: [PATCH 632/771] rename file --- modules/assim.batch/R/pda.emulator.R | 2 +- modules/assim.batch/R/pda.postprocess.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/assim.batch/R/pda.emulator.R b/modules/assim.batch/R/pda.emulator.R index f56bae14d80..5b6dae55c25 100644 --- a/modules/assim.batch/R/pda.emulator.R +++ b/modules/assim.batch/R/pda.emulator.R @@ -637,7 +637,7 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, # save sf posterior if(!is.null(sf)){ sf.filename <- file.path(settings$outdir, - paste0("posteriors.pda.sf", "_", settings$assim.batch$ensemble.id, ".Rdata")) + paste0("post.distns.pda.sf", "_", settings$assim.batch$ensemble.id, ".Rdata")) sf.prior <- prior.list[[sf.ind]] sf.post.distns <- write_sf_posterior(sf.samp.list, sf.prior, sf.filename) save(sf.post.distns, file = sf.filename) diff --git a/modules/assim.batch/R/pda.postprocess.R b/modules/assim.batch/R/pda.postprocess.R index 0206a41aa82..30978c3f9e5 100644 --- a/modules/assim.batch/R/pda.postprocess.R +++ b/modules/assim.batch/R/pda.postprocess.R @@ -241,7 +241,7 @@ write_sf_posterior <- function(sf.samp.list, sf.prior, sf.filename){ # reformat each sublist such that params have their own list and return sf.subset <- lapply(seq_along(sf.subset.list), function(x) as.list(data.frame(sf.subset.list[[x]]))) - filename.flag <- gsub(".*posteriors\\s*|.Rdata.*", "", basename(sf.filename)) + filename.flag <- gsub(".*post.distns\\s*|.Rdata.*", "", basename(sf.filename)) sf.post.distns <- PEcAn.MA::approx.posterior(trait.mcmc = sf.subset[[1]], priors = sf.prior, outdir = dirname(sf.filename), From 2aeb34472d1932d549a0692d32c79ec9cd8165e8 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 14 Sep 2017 14:16:13 -0400 Subject: [PATCH 633/771] Changed limit from 1MB to 1GB and made sure that roxygen will not run example --- modules/data.land/R/dataone_download.R | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index 0abd987b98f..eda35acd9e8 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -12,9 +12,18 @@ #' @export #' -#' @examples doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", filepath = "/fs/data1/pecan.data/dbfiles/") +#' @examples +#' /dontrun{ +#' doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", filepath = "/fs/data1/pecan.data/dbfiles/") +#' } dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNode = "PROD", lazyLoad = FALSE, quiet = F){ + ### Check for wget functionality + test <- try(system2("wget", "--version", stderr = TRUE)) + if (class(test) == "try-error") { + PEcAn.logger::logger.severe("wget system utility is not available on this system. Please install it to use this functionality.") + } + ### automatically retrieve mnId cn <- dataone::CNode(CNode) locations <- dataone::resolve(cn, pid = id) @@ -22,7 +31,7 @@ dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNod ### begin D1 download process d1c <- dataone::D1Client("PROD", mnId) - pkg <- dataone::getDataPackage(d1c, id = id, lazyLoad = lazyLoad, quiet = quiet, limit = "1MB") + pkg <- dataone::getDataPackage(d1c, id = id, lazyLoad = lazyLoad, quiet = quiet, limit = "1GB") files <- datapack::getValue(pkg, name="sysmeta@formatId") n <- length(files) # number of files From c7352979e62ecfb527706ec323b43dc64ccd332a Mon Sep 17 00:00:00 2001 From: istfer Date: Thu, 14 Sep 2017 14:19:50 -0400 Subject: [PATCH 634/771] reduce code --- modules/assim.batch/R/pda.postprocess.R | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/modules/assim.batch/R/pda.postprocess.R b/modules/assim.batch/R/pda.postprocess.R index 30978c3f9e5..f42af58cade 100644 --- a/modules/assim.batch/R/pda.postprocess.R +++ b/modules/assim.batch/R/pda.postprocess.R @@ -236,14 +236,11 @@ write_sf_posterior <- function(sf.samp.list, sf.prior, sf.filename){ # convert mcmc.list to list of matrices sf.subset.list <- list() - sf.subset.list[[1]] <- do.call("rbind", sf.samp) - - # reformat each sublist such that params have their own list and return - sf.subset <- lapply(seq_along(sf.subset.list), function(x) as.list(data.frame(sf.subset.list[[x]]))) - + sf.subset.list[[1]] <- as.data.frame(do.call("rbind", sf.samp)) + filename.flag <- gsub(".*post.distns\\s*|.Rdata.*", "", basename(sf.filename)) - sf.post.distns <- PEcAn.MA::approx.posterior(trait.mcmc = sf.subset[[1]], priors = sf.prior, + sf.post.distns <- PEcAn.MA::approx.posterior(trait.mcmc = sf.subset.list[[1]], priors = sf.prior, outdir = dirname(sf.filename), filename.flag = filename.flag) From a6260f66aa7821187ad17d39eae8889e9903333c Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 14 Sep 2017 14:34:20 -0400 Subject: [PATCH 635/771] roxygen docs sry... --- modules/data.land/man/dataone_download.Rd | 2 ++ 1 file changed, 2 insertions(+) diff --git a/modules/data.land/man/dataone_download.Rd b/modules/data.land/man/dataone_download.Rd index 5fc774adace..716f6ed243f 100644 --- a/modules/data.land/man/dataone_download.Rd +++ b/modules/data.land/man/dataone_download.Rd @@ -22,8 +22,10 @@ dataone_download(id, filepath = "/fs/data1/pecan.data/dbfiles/", Adapts the dataone::getDataPackage workflow to allow users to download data from the DataONE federation by simply entering the doi or associated package id } \examples{ +/dontrun{ doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", filepath = "/fs/data1/pecan.data/dbfiles/") } +} \author{ Liam P Burke, \email{lpburke@bu.edu} } From 89015e643c4284cb4d7bb93f32a806fab3cab963 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 14 Sep 2017 13:48:48 -0500 Subject: [PATCH 636/771] remote: Make check_model_run return TRUE/FALSE --- base/remote/R/check_model_run.R | 6 +++++- base/remote/man/check_model_run.Rd | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/base/remote/R/check_model_run.R b/base/remote/R/check_model_run.R index 3a9556bc315..1859a653d10 100644 --- a/base/remote/R/check_model_run.R +++ b/base/remote/R/check_model_run.R @@ -3,15 +3,19 @@ #' @param out Output from model execution, as a character. #' @inheritParams start.model.runs #' -#' @return `NULL` +#' @return `TRUE` if model run succeeded. If model run failed, throw an error if `stop.on.error`, or return FALSE. #' @export check_model_run <- function(out, stop.on.error = TRUE) { if ("ERROR IN MODEL RUN" %in% out) { + success <- TRUE msg <- paste0("Model run aborted with the following error:\n", out) if (stop.on.error) { PEcAn.logger::logger.severe(msg) } else { PEcAn.logger::logger.error(msg) } + } else { + success <- FALSE } + return(success) } diff --git a/base/remote/man/check_model_run.Rd b/base/remote/man/check_model_run.Rd index 8ae60b37fc5..24ffdd454b1 100644 --- a/base/remote/man/check_model_run.Rd +++ b/base/remote/man/check_model_run.Rd @@ -12,7 +12,7 @@ check_model_run(out, stop.on.error = TRUE) \item{stop.on.error}{Throw error if \emph{any} of the runs fails. Default TRUE.} } \value{ -\code{NULL} +\code{TRUE} if model run succeeded. If model run failed, throw an error if \code{stop.on.error}, or return FALSE. } \description{ Check if model run was successful From 80f350f35f71a8be007448429b9eca56168bc2f1 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 14 Sep 2017 13:49:48 -0500 Subject: [PATCH 637/771] db: Check if parent ID is NULL --- base/db/R/dbfiles.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/base/db/R/dbfiles.R b/base/db/R/dbfiles.R index 3f9867a136e..ccdaf5bb18e 100644 --- a/base/db/R/dbfiles.R +++ b/base/db/R/dbfiles.R @@ -50,7 +50,7 @@ dbfile.input.insert <- function(in.path, in.prefix, siteid, startdate, enddate, ) # setup parent part of query if specified - if (is.na(parentid)) { + if (is.na(parentid) || is.null(parentid)) { parent <- "" } else { parent <- paste0(" AND parent_id=", parentid) @@ -192,7 +192,7 @@ dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, f } # setup parent part of query if specified - if (is.na(parentid)) { + if (is.na(parentid) || is.null(parentid)) { parent <- "" } else { parent <- paste0(" AND parent_id=", parentid) @@ -226,7 +226,7 @@ dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, f } else { ## parent check when NA - if (is.na(parentid)) { + if (is.na(parentid) || is.null(parentid)) { if (!is.null(pattern)) { ## Case where pattern is not NULL From ad6c2263b9d138e8a20b4515eb941bba23a47edc Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 14 Sep 2017 13:55:15 -0500 Subject: [PATCH 638/771] Revert "db: Check if parent ID is NULL" This reverts commit 80f350f35f71a8be007448429b9eca56168bc2f1. --- base/db/R/dbfiles.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/base/db/R/dbfiles.R b/base/db/R/dbfiles.R index ccdaf5bb18e..3f9867a136e 100644 --- a/base/db/R/dbfiles.R +++ b/base/db/R/dbfiles.R @@ -50,7 +50,7 @@ dbfile.input.insert <- function(in.path, in.prefix, siteid, startdate, enddate, ) # setup parent part of query if specified - if (is.na(parentid) || is.null(parentid)) { + if (is.na(parentid)) { parent <- "" } else { parent <- paste0(" AND parent_id=", parentid) @@ -192,7 +192,7 @@ dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, f } # setup parent part of query if specified - if (is.na(parentid) || is.null(parentid)) { + if (is.na(parentid)) { parent <- "" } else { parent <- paste0(" AND parent_id=", parentid) @@ -226,7 +226,7 @@ dbfile.input.check <- function(siteid, startdate=NULL, enddate=NULL, mimetype, f } else { ## parent check when NA - if (is.na(parentid) || is.null(parentid)) { + if (is.na(parentid)) { if (!is.null(pattern)) { ## Case where pattern is not NULL From 7fb9ee3d075694888888c7e2679e4ddd33d75828 Mon Sep 17 00:00:00 2001 From: Rob Kooper Date: Thu, 14 Sep 2017 13:59:07 -0500 Subject: [PATCH 639/771] Fixes #1659, now uses GET to switch to 08-finish.php which will put the workflowid in the url. --- CHANGELOG.md | 1 + documentation/index_vm.html | 28 +++++++++++----------------- web/05-running.php | 2 +- 3 files changed, 13 insertions(+), 18 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index afdd232536b..56d3a45b195 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha ## [Unreleased] ### Fixes +- Show workflowid in the URL when run is finshed and user clicks results (#1659) - `PEcAn.BIOCRO` now uses PEcAn-standard variable names. As a result, two output variables have been renamed but keep their exiting units and definitions: - `StemBiom` renamed to `AbvGrndWood` - `RootBiom` renamed to `root_carbon_content` diff --git a/documentation/index_vm.html b/documentation/index_vm.html index 3a3e077c41f..75b5772e2c7 100644 --- a/documentation/index_vm.html +++ b/documentation/index_vm.html @@ -3,23 +3,17 @@

    PEcAn

    -

    Run Models

    - -

    Database

    - -

    Output Visualization

    - -

    Output Archive

    - -

    RStudio

    - -

    Code Repository

    - -

    Chat Room

    - -

    Submit an Issue / Bug Report

    - -

    Project Homepage

    +

    Documentation

    diff --git a/web/05-running.php b/web/05-running.php index aa074ae9750..84abcad8c15 100644 --- a/web/05-running.php +++ b/web/05-running.php @@ -135,7 +135,7 @@ function refresh() { -
    + From a68d3cddadbe63550db3b41a276738e331f676b0 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 14 Sep 2017 15:04:49 -0400 Subject: [PATCH 640/771] refactored bety config --- utils/NAMESPACE | 1 + utils/R/read_web_config.R | 24 ++++++++++++++++++++++++ utils/man/read_web_config.Rd | 20 ++++++++++++++++++++ 3 files changed, 45 insertions(+) create mode 100644 utils/R/read_web_config.R create mode 100644 utils/man/read_web_config.Rd diff --git a/utils/NAMESPACE b/utils/NAMESPACE index 4ec10624920..5288cc9ecdf 100644 --- a/utils/NAMESPACE +++ b/utils/NAMESPACE @@ -61,6 +61,7 @@ export(r2bugs.distributions) export(read.ensemble.output) export(read.output) export(read.sa.output) +export(read_web_config) export(remote.copy.from) export(remote.copy.to) export(remote.copy.update) diff --git a/utils/R/read_web_config.R b/utils/R/read_web_config.R new file mode 100644 index 00000000000..16b468d51ec --- /dev/null +++ b/utils/R/read_web_config.R @@ -0,0 +1,24 @@ +#' read_web_config +#' +#' @author Michael Dietze and Rob Kooper +#' @param php.config +#' +#' @return config.list +#' @export +#' +#' +read_web_config = function(php.config = "../../web/config.php") { + + ## Read PHP config file for webserver + config <- scan(php.config, what = "character", sep = "\n") + config <- config[grep("^\\$", config)] ## find lines that begin with $ (variables) + config <- sub("$", "", config, fixed = TRUE) ## remove $ + config <- sub(";", "", config, fixed = TRUE) ## remove ; + config <- sub("false", "FALSE", config, fixed = TRUE) ## Boolean capitalization + config <- sub("true", "TRUE", config, fixed = TRUE) ## Boolean capitalization + config <- config[-grep("$", config, fixed = TRUE)] ## lines with variable references fail + config <- config[-grep("exec", config, fixed = TRUE)] ## lines 'exec' fail + config.list <- eval(parse(text = paste("list(", paste0(config[1:14], collapse = ","), ")"))) + + return(config.list) +} \ No newline at end of file diff --git a/utils/man/read_web_config.Rd b/utils/man/read_web_config.Rd new file mode 100644 index 00000000000..e996c040775 --- /dev/null +++ b/utils/man/read_web_config.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/read_web_config.R +\name{read_web_config} +\alias{read_web_config} +\title{read_web_config} +\usage{ +read_web_config(php.config = "../../web/config.php") +} +\arguments{ +\item{php.config}{} +} +\value{ +config.list +} +\description{ +read_web_config +} +\author{ +Michael Dietze and Rob Kooper +} From 4c10fe62bc55ba7349fa306326ba0094b4f87924 Mon Sep 17 00:00:00 2001 From: mccabete Date: Thu, 14 Sep 2017 15:07:38 -0400 Subject: [PATCH 641/771] align_pft, with only data_to_data comparisons implimented --- modules/benchmark/NAMESPACE | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/modules/benchmark/NAMESPACE b/modules/benchmark/NAMESPACE index a399f73166b..a1bd3946a69 100644 --- a/modules/benchmark/NAMESPACE +++ b/modules/benchmark/NAMESPACE @@ -1,6 +1,10 @@ # Generated by roxygen2: do not edit by hand +export(align_by_observation_one) +export(align_by_observation_two) export(align_data) +export(align_data_to_data_pft) +export(align_pft) export(calc_benchmark) export(calc_metrics) export(create_BRR) From 42cb079f7aff1aae8861cb54100374315e628948 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 14 Sep 2017 15:17:34 -0400 Subject: [PATCH 642/771] updated `query.dyplr.R` to use read_web_config (per alexey's request to not have duplicate code --- db/R/query.dplyr.R | 11 ++--------- utils/R/read_web_config.R | 2 +- utils/man/read_web_config.Rd | 2 +- 3 files changed, 4 insertions(+), 11 deletions(-) diff --git a/db/R/query.dplyr.R b/db/R/query.dplyr.R index 18c52d7cd16..3cc2ea55c1e 100644 --- a/db/R/query.dplyr.R +++ b/db/R/query.dplyr.R @@ -1,17 +1,10 @@ #' Connect to bety using current PEcAn configuration #' @param php.config Path to `config.php` #' @export +#' betyConnect <- function(php.config = "../../web/config.php") { ## Read PHP config file for webserver - config <- scan(php.config, what = "character", sep = "\n") - config <- config[grep("^\\$", config)] ## find lines that begin with $ (variables) - config <- sub("$", "", config, fixed = TRUE) ## remove $ - config <- sub(";", "", config, fixed = TRUE) ## remove ; - config <- sub("false", "FALSE", config, fixed = TRUE) ## Boolean capitalization - config <- sub("true", "TRUE", config, fixed = TRUE) ## Boolean capitalization - config <- config[-grep("$", config, fixed = TRUE)] ## lines with variable references fail - config <- config[-grep("exec", config, fixed = TRUE)] ## lines 'exec' fail - config.list <- eval(parse(text = paste("list(", paste0(config[1:14], collapse = ","), ")"))) + config.list <- PEcAn.utils::read_web_config(php.config) ## Database connection src_postgres(dbname = config.list$db_bety_database, diff --git a/utils/R/read_web_config.R b/utils/R/read_web_config.R index 16b468d51ec..919eb7d9ffb 100644 --- a/utils/R/read_web_config.R +++ b/utils/R/read_web_config.R @@ -1,7 +1,7 @@ #' read_web_config #' #' @author Michael Dietze and Rob Kooper -#' @param php.config +#' @param php.config Path to `config.php` #' #' @return config.list #' @export diff --git a/utils/man/read_web_config.Rd b/utils/man/read_web_config.Rd index e996c040775..35778c9df8b 100644 --- a/utils/man/read_web_config.Rd +++ b/utils/man/read_web_config.Rd @@ -7,7 +7,7 @@ read_web_config(php.config = "../../web/config.php") } \arguments{ -\item{php.config}{} +\item{php.config}{Path to `config.php`} } \value{ config.list From 79894b0012bb2c76d45c5bfa80a50de6228a0b76 Mon Sep 17 00:00:00 2001 From: mccabete Date: Thu, 14 Sep 2017 15:23:31 -0400 Subject: [PATCH 643/771] align_pft, only data_to_data implimented, with files --- .../benchmark/R/align_by_obeservation_one.R | 47 +++++ .../benchmark/R/align_by_obeservation_two.R | 45 ++++ modules/benchmark/R/align_data_to_data_pft.R | 196 ++++++++++++++++++ modules/benchmark/R/align_pft.R | 71 +++++++ modules/benchmark/R/check_if_legal_table.R | 66 ++++++ modules/benchmark/R/check_if_list_of_pfts.R | 19 ++ modules/benchmark/R/check_if_species_list.R | 34 +++ .../benchmark/R/get_species_list_standard.R | 32 +++ .../benchmark/man/align_by_observation_one.Rd | 36 ++++ .../benchmark/man/align_by_observation_two.Rd | 36 ++++ .../benchmark/man/align_data_to_data_pft.Rd | 72 +++++++ modules/benchmark/man/align_pft.Rd | 73 +++++++ modules/benchmark/man/check_if_legal_table.Rd | 28 +++ .../benchmark/man/check_if_list_of_pfts.Rd | 23 ++ .../benchmark/man/check_if_species_list.Rd | 25 +++ .../man/get_species_list_standard.Rd | 26 +++ 16 files changed, 829 insertions(+) create mode 100644 modules/benchmark/R/align_by_obeservation_one.R create mode 100644 modules/benchmark/R/align_by_obeservation_two.R create mode 100644 modules/benchmark/R/align_data_to_data_pft.R create mode 100644 modules/benchmark/R/align_pft.R create mode 100644 modules/benchmark/R/check_if_legal_table.R create mode 100644 modules/benchmark/R/check_if_list_of_pfts.R create mode 100644 modules/benchmark/R/check_if_species_list.R create mode 100644 modules/benchmark/R/get_species_list_standard.R create mode 100644 modules/benchmark/man/align_by_observation_one.Rd create mode 100644 modules/benchmark/man/align_by_observation_two.Rd create mode 100644 modules/benchmark/man/align_data_to_data_pft.Rd create mode 100644 modules/benchmark/man/align_pft.Rd create mode 100644 modules/benchmark/man/check_if_legal_table.Rd create mode 100644 modules/benchmark/man/check_if_list_of_pfts.Rd create mode 100644 modules/benchmark/man/check_if_species_list.Rd create mode 100644 modules/benchmark/man/get_species_list_standard.Rd diff --git a/modules/benchmark/R/align_by_obeservation_one.R b/modules/benchmark/R/align_by_obeservation_one.R new file mode 100644 index 00000000000..7b5a176c498 --- /dev/null +++ b/modules/benchmark/R/align_by_obeservation_one.R @@ -0,0 +1,47 @@ +################################################################# +#' +#' @title align_by_observation_one +#' @param observation_one a vector of plant fucntional types, or species +#' @param observation_two anouther vector of plant fucntional types, or species +#' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +#' In the second case, must be passable to match_species_id. +#' @return \code{vector} Returns a vector of PFT's/species from observation_one that matches the order of observation_two } +#' +#' @author Tempest McCabe +#' @examples +#' +#' observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") +#' observation_two<-c("a", "b", "a", "a") +#' table<-list() +#' table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") +#' table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings +#' table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species +#' table<-as.data.frame(table) +#' +#' format_one<-"species_USDA_symbol" +#' format_two<-"plant_funtional_type" +#' +#' aligned<-align_by_observation_one(observation_one = observation_one, observation_two = observation_two, +#' custom_table = table) +#' # aligned should be a vector '[1] "AMCA3" "ARHY" "AMCA3" "AMCA3"' +#' @export +align_by_observation_one<-function(observation_one, observation_two, custom_table){ + final<-c() + for( i in 1:length(observation_two)){ # For loop finds "coursest" PFT. + subset<-custom_table[custom_table$plant_functional_type_two == observation_two[i],] + if(length(subset$plant_functional_type_one)>length(subset$plant_functional_type_two)){ + final[i]<-as.character(subset$plant_functional_type_two) + }else if(length(subset$plant_functional_type_one)>length(subset$plant_functional_type_two)){ + final[i]<-as.character(subset$plant_functional_type_one) + }else if (length(subset$plant_functional_type_one)==length(subset$plant_functional_type_two)){ + final[i]<-as.character(subset$plant_functional_type_one) + }else{ + PEcAn.logger::logger.warn("There are no subsets of the custom_table that are alignable. Likely a problem with the custom_table format") + aligned_species_list$final<-NULL + } + } + as.vector(final) + return(final) +} + + diff --git a/modules/benchmark/R/align_by_obeservation_two.R b/modules/benchmark/R/align_by_obeservation_two.R new file mode 100644 index 00000000000..d68ba0cbcdf --- /dev/null +++ b/modules/benchmark/R/align_by_obeservation_two.R @@ -0,0 +1,45 @@ +################################################################# +#' @title align_by_observation_two +#' @param observation_one a vector of plant fucntional types, or species +#' @param observation_two anouther vector of plant fucntional types, or species +#' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +#' In the second case, must be passable to match_species_id. +#' @return \code{vector} Returns a vector of PFT's/species from observation_two that matches the order of observation_one } +#' @author Tempest McCabe +#' @examples +#' +#' observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") +#' observation_two<-c("a", "b", "a", "a") +#' table<-list() +#' table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") +#' table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings +#' table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species +#' table<-as.data.frame(table) +#' +#' format_one<-"species_USDA_symbol" +#' format_two<-"plant_funtional_type" +#' +#' aligned<-align_by_observation_one(observation_one = observation_one, observation_two = observation_two, +#' custom_table = table) +#' # aligned should be a vector '[1] "a" "a" "a" "a"' +#' @export + +align_by_observation_two<-function(observation_one, observation_two, custom_table){ +final<-c() + for( i in 1:length(observation_two)){ # For loop finds "coursest" PFT. + subset<-custom_table[custom_table$plant_functional_type_one == observation_one[i],] + if(length(subset$plant_functional_type_two)>length(subset$plant_functional_type_one)){ + final[i]<-as.character(subset$plant_functional_type_one) + }else if(length(subset$plant_functional_type_two)>length(subset$plant_functional_type_one)){ + final[i]<-as.character(subset$plant_functional_type_two) + }else if (length(subset$plant_functional_type_two)==length(subset$plant_functional_type_one)){ + final[i]<-as.character(subset$plant_functional_type_two) + }else{ + PEcAn.logger::logger.warn("There are no subsets of the custom_table that are alignable. Likely a problem with the custom_table format") + aligned_species_list$final<-NULL + } + } + as.vector(final) + return(final) +} + diff --git a/modules/benchmark/R/align_data_to_data_pft.R b/modules/benchmark/R/align_data_to_data_pft.R new file mode 100644 index 00000000000..b9ceb95d42a --- /dev/null +++ b/modules/benchmark/R/align_data_to_data_pft.R @@ -0,0 +1,196 @@ +################################################################# +#'@title{align_data_to_data_pft} +#'@details +#' Aligns vectors of Plant Fucntional Typed and species. +#' Can align: +#' - two vectors of plant fucntional types (pft's) if a custom map is provided +#' - a list of species (usda, fia, or latin_name format) to a plant fucntional type +#' - a list of species in a custom format, with a table mapping it to bety_species_id's +#' +#' Will return a list of what was originally provided, bety_speceis_codes if possible, +#' and an aligned output. Becuase some alignement is order-sensitive, alignment based on observation_one +#' and observation_two are both provided. +#' +#'\code{comparison_type} can be one of the following: +#' \describe{ +#' \item{\code{data_to_data}}{Will align lists of pfts and species. Must be assosiated with inputs.} +#' \item{\code{data_to_model}}{Not yet implemented} +#' \item{\code{model_to_model}}{Not yet implemented} +#' } +#' +#' +#' @param con database connection +#' @param observation_one a vector of plant fucntional types, or species +#' @param observation_two anouther vector of plant fucntional types, or species +#' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +#' In the second case, must be passable to match_species_id. +#' @param format_one The output of query.format.vars() of observation one of the form output$vars$bety_names +#' @param format_two The output of query.format.vars() of observation two of the form output$vars$bety_names +#' @param subset_are_ok When aligning two species lists, this allows for alignement when species lists aren't identical. +#' set to FALSE by default. +#' @return \code{list} containing the following columns: +#' \describe{ +#' \item{\code{$original}}{Will spit back out original vectors pre-alignment} +#' \item{\code{$aligned$aligned_by_observation_one}}{Where possible, will return a vector of observation_one pft's/species in the order of observation_two} +#' \item{\code{species}}{{Where possible, will return a vector of observation_two's pft's/species in the order of observation_one}} +#' \item{\code{$bety_species_id}}{Where possible, will return the bety_species_id's for one or both observations} +#' } +#' @author Tempest McCabe +#' @examples +#' +#' observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") +#' observation_two<-c("a", "b", "a", "a") +#' table<-list() +#' table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") +#' table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings +#' table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species +#' table<-as.data.frame(table) +#' +#' format_one<-"species_USDA_symbol" +#' format_two<-"plant_funtional_type" +#' +#' aligned<-align_data_to_data_pft(con = con, observation_one = observation_one, observation_two = observation_two, +#' format_one = format_one, format_two = format_two, custom_table = table) +#' @export + +align_data_to_data_pft<-function(observation_one, observation_two, custom_table=NULL, format_one, format_two, subset_are_ok=FALSE){ + + + ### Note: Right now, all the PFT's in bety are assosiated with a model. There is no way to assosiate PFT's with data inputs. + # It seems like down the line we might want to invest in a way to assosiate pft's with input records. Then we could use match_pft for data + # Until then, this function will be written to just take custom mapping tables. + + if(check_if_species_list(format_one) && check_if_species_list(format_two)){ #Both are lists of species + + translation_table<-NULL + if (get_species_list_standard(format_one)=="custom"|get_species_list_standard(format_two)=="custom"){tanslation_table<-custom_table} + + bety_codes_one<-PEcAn.data.land::match_species_id(input_codes=observation_one, format_name= get_species_list_standard(format_one),translation_table = translation_table, bety=con) + bety_codes_two<-PEcAn.data.land::match_species_id(input_codes=observation_two, format_name= get_species_list_standard(format_two), translation_table = translation_table,bety=con) + + #check if ideantical lists. + if(setequal(bety_codes_one, bety_codes_two)){ + + aligned_species_list<-list() + aligned_species_list$bety_species_id_one<-bety_codes_one + aligned_species_list$original_standard_id_one<-observation_one + aligned_species_list$bety_species_id_one<-bety_codes_two + aligned_species_list$original_standard_id_one<-observation_two + + aligned_species_list$final<-bety_codes_one# Allows all code to referece same column name + + return(aligned_species_list)# If order of species matter this could cause errors + }else if(subsets_are_ok) { + bety_codes_intersect<-intersect(bety_codes_one, bety_codes_two) + + aligned_species_list<-list() + aligned_species_list$bety_species_id_one<-bety_codes_one + aligned_species_list$original_standard_id_one<-observation_one + aligned_species_list$bety_species_id_one<-bety_codes_two + aligned_species_list$original_standard_id_one<-observation_two + aligne_speces_list$bety_species_id_intersection<-bety_codes_intersect + + aligned_species_list$final<-bety_codes_intersect + + return(aligned_species_list) #Returns the intersection of the speceies lists + }else{ + PEcAn.logger::logger.warn("These observations cannot be aligned, as they have different species lists. Returning NULL. Check species lists, or set 'subset_are_ok' to TRUE. ") + return(NULL) + } + + }else if(check_if_species_list(format_one) && !check_if_species_list(format_two)){ + + if(is.null(custom_table)){logger.severe("Please provide custom_table")}else if (!is.null(custom_table)) + { + if(check_if_legal_table(custom_table, observation_one, observation_two)){ + + translation_table<-NULL + if (get_species_list_standard(format_one)=="custom"){tanslation_table<-custom_table} + + bety_codes_one<-PEcAn.data.land::match_species_id(input_codes=observation_one, format_name= get_species_list_standard(format_one),translation_table = translation_table, bety=con) + + aligned_by_one<-align_by_observation_one(observation_one,observation_two, custom_table) + aligned_by_two<-align_by_observation_two(observation_one,observation_two, custom_table) + + aligned_species_list<-list() + aligned_species_list$bety_species_id$observation_one<-bety_codes_one + aligned_species_list$bety_species_id$observation_two<-NA + aligned_species_list$original$observation_one<-observation_one + aligned_species_list$original$observation_two<-observation_two + aligned_species_list$aligned$aligned_by_observation_one<-aligned_by_one + aligned_species_list$aligned$aligned_by_observation_two<-aligned_by_two + + return(aligned_species_list) + + + }else{ + logger.severe("custom_table provided does not correctly map plant_function_type_one to plant_functional_type_two. One or more rows are mapped to multiple plant funcitonal types.") + } + } + + + + }else if(!check_if_species_list(format_one) && check_if_species_list(format_two)){ + + if(is.null(custom_table)){PEcAn.logger::logger.severe("Please provide custom_table")}else if (!is.null(custom_table)) + { + if(check_if_legal_table(custom_table, observation_one, observation_two)){ + + translation_table<-NULL + if (get_species_list_standard(format_two)=="custom"){tanslation_table<-custom_table} + + bety_codes_two<-PEcAn.data.land::match_species_id(input_codes=observation_two, format_name= get_species_list_standard(format_two),translation_table = translation_table, bety=con) + + aligned_by_one<-align_by_observation_one(observation_one,observation_two, custom_table) + aligned_by_two<-align_by_observation_two(observation_one,observation_two, custom_table) + + aligned_species_list<-list() + aligned_species_list$bety_species_id$observation_one<-bety_codes_one + aligned_species_list$bety_species_id$observation_two<-NA + aligned_species_list$original$observation_one<-observation_one + aligned_species_list$original$observation_two<-observation_two + aligned_species_list$aligned$aligned_by_observation_one<-aligned_by_one + aligned_species_list$aligned$aligned_by_observation_two<-aligned_by_two + + return(aligned_species_list) + + + }else{ + logger.severe("custom_table provided does not correctly map plant_function_type_one to plant_functional_type_two. One or more rows are mapped to multiple plant funcitonal types.") + } + } + + return(aligned_species_list) + + }else if(check_if_list_of_pfts(format_one) && (check_if_list_of_pfts(format_two))){ + + + + if(is.null(custom_table)){logger.severe("Please provide custom_table")}else if (!is.null(custom_table)) + { + if(check_if_legal_table(custom_table, observation_one, observation_two)){ + + aligned_by_one<-align_by_observation_one(observation_one,observation_two, custom_table) + aligned_by_two<-align_by_observation_two(observation_one,observation_two, custom_table) + + aligned_species_list<-list() + aligned_species_list$bety_species_id$observation_one<-bety_codes_one + aligned_species_list$bety_species_id$observation_two<-NA + aligned_species_list$original$observation_one<-observation_one + aligned_species_list$original$observation_two<-observation_two + aligned_species_list$aligned$aligned_by_observation_one<-aligned_by_one + aligned_species_list$aligned$aligned_by_observation_two<-aligned_by_two + + + return(aligned_species_list) + }else{ + logger.severe("custom_table provided does not correctly map plant_function_type_one to plant_functional_type_two. One or more rows are mapped to multiple plant funcitonal types.") + } + } + + }else{ + logger.severe("PFTs are not in the correct format. Observations must have variables compatible with check_if_species_list(), or use the 'plant_funtional_type' variable") + } + + +} \ No newline at end of file diff --git a/modules/benchmark/R/align_pft.R b/modules/benchmark/R/align_pft.R new file mode 100644 index 00000000000..c2e9e23692a --- /dev/null +++ b/modules/benchmark/R/align_pft.R @@ -0,0 +1,71 @@ +################################################################# +#'@title{align_pft} +#'@details +#' Aligns vectors of Plant Fucntional Typed and species. +#' Can align: +#' - two vectors of plant fucntional types (pft's) if a custom map is provided +#' - a list of species (usda, fia, or latin_name format) to a plant fucntional type +#' - a list of species in a custom format, with a table mapping it to bety_species_id's +#' +#' Will return a list of what was originally provided, bety_speceis_codes if possible, +#' and an aligned output. Becuase some alignement is order-sensitive, alignment based on observation_one +#' and observation_two are both provided. +#' +#'\code{comparison_type} can be one of the following: +#' \describe{ +#' \item{\code{data_to_data}}{Will align lists of pfts and species. Must be assosiated with inputs.} +#' \item{\code{data_to_model}}{Not yet implemented} +#' \item{\code{model_to_model}}{Not yet implemented} +#' } +#' +#' +#' @param con database connection +#' @param observation_one a vector of plant fucntional types, or species +#' @param observation_two anouther vector of plant fucntional types, or species +#' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +#' In the second case, must be passable to match_species_id. +#' @param format_one The output of query.format.vars() of observation one of the form output$vars$bety_names +#' @param format_two The output of query.format.vars() of observation two of the form output$vars$bety_names +#' @param subset_are_ok When aligning two species lists, this allows for alignement when species lists aren't identical. +#' set to FALSE by default. +#' @return \code{list} containing the following columns: +#' \describe{ +#' \item{\code{$original}}{Will spit back out original vectors pre-alignment} +#' \item{\code{$aligned$aligned_by_observation_one}}{Where possible, will return a vector of observation_one pft's/species in the order of observation_two} +#' \item{\code{species}}{{Where possible, will return a vector of observation_two's pft's/species in the order of observation_one}} +#' \item{\code{$bety_species_id}}{Where possible, will return the bety_species_id's for one or both observations} +#' } +#' @author Tempest McCabe +#' @examples +#' +#' observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") +#' observation_two<-c("a", "b", "a", "a") +#' table<-list() +#' table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") +#' table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings +#' table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species +#' table<-as.data.frame(table) +#' +#' format_one<-"species_USDA_symbol" +#' format_two<-"plant_funtional_type" +#' +#' aligned<-align_pft(con = con, observation_one = observation_one, observation_two = observation_two, +#' format_one = format_one, format_two = format_two, custom_table = table) +#' @export +align_pft<-function(con, observation_one, observation_two, custom_table=NULL, format_one, format_two, subset_are_ok=FALSE, comparison_type="data_to_data", ...){ + + if(comparison_type=="data_to_model"){ + #align_data_to_model_pft(settings_one, observations_1) + PEcAn.logger::logger.warn("data_to_model alignment not yet implemented. Returning NULL.") + return(NULL) + }else if (comparison_type=="data_to_data"){ + align_data_to_data_pft(observation_one, observation_two, custom_table=NULL, format_one, format_two, subset_are_ok=FALSE) + }else if (comparison_type == "model_to_model"){ + #align_model_to_model_pft(settings_one, settings_two) + PEcAn.logger::logger.warn("model_to_model alignment not yet implemented. Returning NULL.") + return(NULL) + }else{ + PEcAn.logger::logger.severe("comparison_type must be set to either 'data_to_model', 'data_to_data', or model_to_model") + } + +} diff --git a/modules/benchmark/R/check_if_legal_table.R b/modules/benchmark/R/check_if_legal_table.R new file mode 100644 index 00000000000..d2805d5f7fd --- /dev/null +++ b/modules/benchmark/R/check_if_legal_table.R @@ -0,0 +1,66 @@ +#' @title check_if_legal_table +#' @details +#' Checks if custom_table: +#' 1. is formated correctly +#' 2. is complete (has all of the species/pft's in both observations) +#' 3. is condense-able (Could be represented as a hierachry) +#' +#' @param observation_one a vector of plant fucntional types, or species +#' @param observation_two anouther vector of plant fucntional types, or species +#' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +#' In the second case, must be passable to match_species_id. +#' @return \code{boolean} +#' @author Tempest McCabe +check_if_legal_table<-function(table, observation_one, observation_two){ + all_there<-TRUE + names<-names(table) + if(!"plant_functional_type_one" %in% names|!"plant_functional_type_two" %in% names ){ + logger.severe("Custom table provided does not use correct column names. Requires both 'plant_fucntional_type_one', and 'plant_fucntional_type_two'. + Column names are currently", names(table)) + }else{ + missing<-list() + for(h in 1:length(observation_one)){ + if(!observation_one[h] %in% table$plant_functional_type_one){all_there<-FALSE; missing<-c(missing,observation_one[h])} + } + for(h in 1:length(observation_two)){ + if(!observation_two[h] %in% table$plant_functional_type_two){all_there<-FALSE; missing<-c(missing,observation_two[h])} + } + if(all_there){ + is_legal_table<-TRUE + pft_1<-as.character(unique(table$plant_functional_type_one)) + pft_2<-as.character(unique(table$plant_functional_type_two)) + + for(i in 1:length(pft_1)){ + aggregated_1<-FALSE + aggregated_2<-FALSE + + subset<-subset(table, table$plant_functional_type_one==pft_1[i]) + + length_of_pft_1_uniques_1<-length(as.character(unique(subset$plant_functional_type_one))) + length_of_pft_2_uniques_1<-length(as.character(unique(subset$plant_functional_type_two))) + + if(length_of_pft_2_uniques_1>1 | length_of_pft_1_uniques_1>1){aggregated_1<- TRUE} + + for(j in 1:length(unique(subset$plant_functional_type_two))){ + subset_2<-subset(table, table$plant_functional_type_two==as.character(subset$plant_functional_type_two[j])) + length_of_pft_1_uniques<-length(as.character(unique(subset_2$plant_functional_type_one))) + length_of_pft_2_uniques<-length(as.character(unique(subset_2$plant_functional_type_two))) + if(length_of_pft_2_uniques>1 | length_of_pft_1_uniques>1){aggregated_2<- TRUE} + + if(aggregated_1 && aggregated_2){is_legal_table<-FALSE } + } + + } + + return(is_legal_table) + } else{ + logger.severe("Not every species or plant_fucntional_type is accounted for in custom_table provided. Please account for", missing, "and make sure that 'plant_fucntional_type_one' is matches to 'observation_one'") + } + + } +} + + + + + \ No newline at end of file diff --git a/modules/benchmark/R/check_if_list_of_pfts.R b/modules/benchmark/R/check_if_list_of_pfts.R new file mode 100644 index 00000000000..b78179fa235 --- /dev/null +++ b/modules/benchmark/R/check_if_list_of_pfts.R @@ -0,0 +1,19 @@ +#' @title check_if_list_of_pfts +#' Checks if format contains a variable named "plant_functional_type" +#' @param observation_one a vector of plant fucntional types, or species +#' @param observation_two anouther vector of plant fucntional types, or species +#' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +#' In the second case, must be passable to match_species_id. +#' @return \code{boolean} +#' @author Tempest McCabe +check_if_list_of_pfts<-function(vars){ + + if("plant_functional_type" %in% vars){ + return(TRUE) + }else if("species_name" %in% vars){ + return(TRUE) + }else{ + return(FALSE) + } +} + diff --git a/modules/benchmark/R/check_if_species_list.R b/modules/benchmark/R/check_if_species_list.R new file mode 100644 index 00000000000..8004e101b17 --- /dev/null +++ b/modules/benchmark/R/check_if_species_list.R @@ -0,0 +1,34 @@ +#'@title check_if_species_list +#'@details +#' Checks if format contains a species list in a known format, or a declared custom format. +#' +#' @param observation_one a vector of plant fucntional types, or species +#' @param observation_two anouther vector of plant fucntional types, or species +#' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +#' In the second case, must be passable to match_species_id. +#' @return \code{boolean} +#' @author Tempest McCabe +check_if_species_list<-function(vars,custom_table=NULL){ + + if("species_id" %in% vars){ + return(TRUE) + }else if("species_name" %in% vars){ + return(TRUE) + }else if("species_USDA_symbol" %in% vars){ + return(TRUE) + }else if("species_FIA_symbol" %in% vars){ + return(TRUE) + }else if(!is.null(custom_table)){ + if("bety_species_id" %in% names(custom_table)){ + return(TRUE) + }else{ + PEcAn.logger::logger.warn("Note: custom_table does not have column named 'bety_species_id' and cannot be used with match_species_id(). + Tables that do not have a 'bety_species_id' column cannot be used for species-level mapping, + but can be used for PFT level mapping.") + } + }else{ + return(FALSE) + } +} + + diff --git a/modules/benchmark/R/get_species_list_standard.R b/modules/benchmark/R/get_species_list_standard.R new file mode 100644 index 00000000000..bc2da20da0b --- /dev/null +++ b/modules/benchmark/R/get_species_list_standard.R @@ -0,0 +1,32 @@ +#'@title get_species_list_standard +#' Checks if custom_table: +#' 1. is formated correctly +#' 2. is complete (has all of the species/pft's in both observations) +#' 3. is condense-able (Could be represented as a hierachry) +#' +#' @param observation_one a vector of plant fucntional types, or species +#' @param observation_two anouther vector of plant fucntional types, or species +#' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +#' In the second case, must be passable to match_species_id. +#' @return \code{character} Returns "usda", "latin_name", "fia" or "custom" +#' @author Tempest McCabe +get_species_list_standard<-function(vars){ + + if("species_id" %in% vars){ + return("usda") + }else if("species_name" %in% vars){ + return('latin_name') + }else if("species_USDA_symbol" %in% vars){ + return("usda") + }else if("species_FIA_symbol" %in% vars){ + return('fia') + }else if(!is.null(custom_table)){ + if("bety_species_id" %in% names(custom_table)){ + return("custom") + }else{ + logger.warn("Note: custom_table does not have column named 'bety_species_id' and cannot be used with match_species_id(). This prohibits species-level mapping, but allows PFT level mapping.") + } + }else{ + return(FALSE) + } +} diff --git a/modules/benchmark/man/align_by_observation_one.Rd b/modules/benchmark/man/align_by_observation_one.Rd new file mode 100644 index 00000000000..1e0186747cd --- /dev/null +++ b/modules/benchmark/man/align_by_observation_one.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/align_by_obeservation_one.R +\name{align_by_observation_one} +\alias{align_by_observation_one} +\title{align_by_observation_one} +\usage{ +align_by_observation_one(observation_one, observation_two, custom_table) +} +\arguments{ +\item{observation_one}{a vector of plant fucntional types, or species} + +\item{observation_two}{anouther vector of plant fucntional types, or species} + +\item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +In the second case, must be passable to match_species_id.} +} +\examples{ + +observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") +observation_two<-c("a", "b", "a", "a") +table<-list() +table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") +table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings +table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species +table<-as.data.frame(table) + +format_one<-"species_USDA_symbol" +format_two<-"plant_funtional_type" + +aligned<-align_by_observation_one(observation_one = observation_one, observation_two = observation_two, +custom_table = table) +# aligned should be a vector '[1] "AMCA3" "ARHY" "AMCA3" "AMCA3"' +} +\author{ +Tempest McCabe +} diff --git a/modules/benchmark/man/align_by_observation_two.Rd b/modules/benchmark/man/align_by_observation_two.Rd new file mode 100644 index 00000000000..61134b7a304 --- /dev/null +++ b/modules/benchmark/man/align_by_observation_two.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/align_by_obeservation_two.R +\name{align_by_observation_two} +\alias{align_by_observation_two} +\title{align_by_observation_two} +\usage{ +align_by_observation_two(observation_one, observation_two, custom_table) +} +\arguments{ +\item{observation_one}{a vector of plant fucntional types, or species} + +\item{observation_two}{anouther vector of plant fucntional types, or species} + +\item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +In the second case, must be passable to match_species_id.} +} +\examples{ + +observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") +observation_two<-c("a", "b", "a", "a") +table<-list() +table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") +table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings +table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species +table<-as.data.frame(table) + +format_one<-"species_USDA_symbol" +format_two<-"plant_funtional_type" + +aligned<-align_by_observation_one(observation_one = observation_one, observation_two = observation_two, +custom_table = table) +# aligned should be a vector '[1] "a" "a" "a" "a"' +} +\author{ +Tempest McCabe +} diff --git a/modules/benchmark/man/align_data_to_data_pft.Rd b/modules/benchmark/man/align_data_to_data_pft.Rd new file mode 100644 index 00000000000..4c5f2c1905d --- /dev/null +++ b/modules/benchmark/man/align_data_to_data_pft.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/align_data_to_data_pft.R +\name{align_data_to_data_pft} +\alias{align_data_to_data_pft} +\title{{align_data_to_data_pft}} +\usage{ +align_data_to_data_pft(observation_one, observation_two, custom_table = NULL, + format_one, format_two, subset_are_ok = FALSE) +} +\arguments{ +\item{observation_one}{a vector of plant fucntional types, or species} + +\item{observation_two}{anouther vector of plant fucntional types, or species} + +\item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +In the second case, must be passable to match_species_id.} + +\item{format_one}{The output of query.format.vars() of observation one of the form output$vars$bety_names} + +\item{format_two}{The output of query.format.vars() of observation two of the form output$vars$bety_names} + +\item{subset_are_ok}{When aligning two species lists, this allows for alignement when species lists aren't identical. +set to FALSE by default.} + +\item{con}{database connection} +} +\value{ +\code{list} containing the following columns: +\describe{ + \item{\code{$original}}{Will spit back out original vectors pre-alignment} + \item{\code{$aligned$aligned_by_observation_one}}{Where possible, will return a vector of observation_one pft's/species in the order of observation_two} + \item{\code{species}}{{Where possible, will return a vector of observation_two's pft's/species in the order of observation_one}} + \item{\code{$bety_species_id}}{Where possible, will return the bety_species_id's for one or both observations} +} +} +\details{ +Aligns vectors of Plant Fucntional Typed and species. +Can align: +- two vectors of plant fucntional types (pft's) if a custom map is provided +- a list of species (usda, fia, or latin_name format) to a plant fucntional type +- a list of species in a custom format, with a table mapping it to bety_species_id's + + Will return a list of what was originally provided, bety_speceis_codes if possible, + and an aligned output. Becuase some alignement is order-sensitive, alignment based on observation_one + and observation_two are both provided. + +\code{comparison_type} can be one of the following: +\describe{ + \item{\code{data_to_data}}{Will align lists of pfts and species. Must be assosiated with inputs.} + \item{\code{data_to_model}}{Not yet implemented} + \item{\code{model_to_model}}{Not yet implemented} + } +} +\examples{ + +observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") +observation_two<-c("a", "b", "a", "a") +table<-list() +table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") +table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings +table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species +table<-as.data.frame(table) + +format_one<-"species_USDA_symbol" +format_two<-"plant_funtional_type" + +aligned<-align_data_to_data_pft(con = con, observation_one = observation_one, observation_two = observation_two, +format_one = format_one, format_two = format_two, custom_table = table) +} +\author{ +Tempest McCabe +} diff --git a/modules/benchmark/man/align_pft.Rd b/modules/benchmark/man/align_pft.Rd new file mode 100644 index 00000000000..807a3a6bdd0 --- /dev/null +++ b/modules/benchmark/man/align_pft.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/align_pft.R +\name{align_pft} +\alias{align_pft} +\title{{align_pft}} +\usage{ +align_pft(con, observation_one, observation_two, custom_table = NULL, + format_one, format_two, subset_are_ok = FALSE, + comparison_type = "data_to_data", ...) +} +\arguments{ +\item{con}{database connection} + +\item{observation_one}{a vector of plant fucntional types, or species} + +\item{observation_two}{anouther vector of plant fucntional types, or species} + +\item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +In the second case, must be passable to match_species_id.} + +\item{format_one}{The output of query.format.vars() of observation one of the form output$vars$bety_names} + +\item{format_two}{The output of query.format.vars() of observation two of the form output$vars$bety_names} + +\item{subset_are_ok}{When aligning two species lists, this allows for alignement when species lists aren't identical. +set to FALSE by default.} +} +\value{ +\code{list} containing the following columns: +\describe{ + \item{\code{$original}}{Will spit back out original vectors pre-alignment} + \item{\code{$aligned$aligned_by_observation_one}}{Where possible, will return a vector of observation_one pft's/species in the order of observation_two} + \item{\code{species}}{{Where possible, will return a vector of observation_two's pft's/species in the order of observation_one}} + \item{\code{$bety_species_id}}{Where possible, will return the bety_species_id's for one or both observations} +} +} +\details{ +Aligns vectors of Plant Fucntional Typed and species. +Can align: +- two vectors of plant fucntional types (pft's) if a custom map is provided +- a list of species (usda, fia, or latin_name format) to a plant fucntional type +- a list of species in a custom format, with a table mapping it to bety_species_id's + + Will return a list of what was originally provided, bety_speceis_codes if possible, + and an aligned output. Becuase some alignement is order-sensitive, alignment based on observation_one + and observation_two are both provided. + +\code{comparison_type} can be one of the following: +\describe{ + \item{\code{data_to_data}}{Will align lists of pfts and species. Must be assosiated with inputs.} + \item{\code{data_to_model}}{Not yet implemented} + \item{\code{model_to_model}}{Not yet implemented} + } +} +\examples{ + +observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") +observation_two<-c("a", "b", "a", "a") +table<-list() +table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") +table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings +table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species +table<-as.data.frame(table) + +format_one<-"species_USDA_symbol" +format_two<-"plant_funtional_type" + +aligned<-align_pft(con = con, observation_one = observation_one, observation_two = observation_two, +format_one = format_one, format_two = format_two, custom_table = table) +} +\author{ +Tempest McCabe +} diff --git a/modules/benchmark/man/check_if_legal_table.Rd b/modules/benchmark/man/check_if_legal_table.Rd new file mode 100644 index 00000000000..751f16252a4 --- /dev/null +++ b/modules/benchmark/man/check_if_legal_table.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/check_if_legal_table.R +\name{check_if_legal_table} +\alias{check_if_legal_table} +\title{check_if_legal_table} +\usage{ +check_if_legal_table(table, observation_one, observation_two) +} +\arguments{ +\item{observation_one}{a vector of plant fucntional types, or species} + +\item{observation_two}{anouther vector of plant fucntional types, or species} + +\item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +In the second case, must be passable to match_species_id.} +} +\value{ +\code{boolean} +} +\details{ +Checks if custom_table: +1. is formated correctly +2. is complete (has all of the species/pft's in both observations) +3. is condense-able (Could be represented as a hierachry) +} +\author{ +Tempest McCabe +} diff --git a/modules/benchmark/man/check_if_list_of_pfts.Rd b/modules/benchmark/man/check_if_list_of_pfts.Rd new file mode 100644 index 00000000000..35cc8b32415 --- /dev/null +++ b/modules/benchmark/man/check_if_list_of_pfts.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/check_if_list_of_pfts.R +\name{check_if_list_of_pfts} +\alias{check_if_list_of_pfts} +\title{check_if_list_of_pfts +Checks if format contains a variable named "plant_functional_type"} +\usage{ +check_if_list_of_pfts(vars) +} +\arguments{ +\item{observation_one}{a vector of plant fucntional types, or species} + +\item{observation_two}{anouther vector of plant fucntional types, or species} + +\item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +In the second case, must be passable to match_species_id.} +} +\value{ +\code{boolean} +} +\author{ +Tempest McCabe +} diff --git a/modules/benchmark/man/check_if_species_list.Rd b/modules/benchmark/man/check_if_species_list.Rd new file mode 100644 index 00000000000..8b15fc04a55 --- /dev/null +++ b/modules/benchmark/man/check_if_species_list.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/check_if_species_list.R +\name{check_if_species_list} +\alias{check_if_species_list} +\title{check_if_species_list} +\usage{ +check_if_species_list(vars, custom_table = NULL) +} +\arguments{ +\item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +In the second case, must be passable to match_species_id.} + +\item{observation_one}{a vector of plant fucntional types, or species} + +\item{observation_two}{anouther vector of plant fucntional types, or species} +} +\value{ +\code{boolean} +} +\details{ +Checks if format contains a species list in a known format, or a declared custom format. +} +\author{ +Tempest McCabe +} diff --git a/modules/benchmark/man/get_species_list_standard.Rd b/modules/benchmark/man/get_species_list_standard.Rd new file mode 100644 index 00000000000..444e1ab4523 --- /dev/null +++ b/modules/benchmark/man/get_species_list_standard.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_species_list_standard.R +\name{get_species_list_standard} +\alias{get_species_list_standard} +\title{get_species_list_standard +Checks if custom_table: +1. is formated correctly +2. is complete (has all of the species/pft's in both observations) +3. is condense-able (Could be represented as a hierachry)} +\usage{ +get_species_list_standard(vars) +} +\arguments{ +\item{observation_one}{a vector of plant fucntional types, or species} + +\item{observation_two}{anouther vector of plant fucntional types, or species} + +\item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +In the second case, must be passable to match_species_id.} +} +\value{ +\code{character} Returns "usda", "latin_name", "fia" or "custom" +} +\author{ +Tempest McCabe +} From b342c58159f4c4efe3eef3ec07999abc01be274a Mon Sep 17 00:00:00 2001 From: Tess McCabe Date: Thu, 14 Sep 2017 15:26:24 -0400 Subject: [PATCH 644/771] Update CHANGELOG.md --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index afdd232536b..08f7f97bc16 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -29,6 +29,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) - New `PEcAn.utils::days_in_year(year)` function that should make it easier to work with leap years. - New `PEcAn.data.atmosphere::solar_angle` function that replaces math that occurs in some models. +- New `PEcAn.benchmarking::align_pft` fucntion that aligns data assosiated with two different plant functional types - #1594 shiny/workflowPlot Adding interactiveness using ggploltly - #1594 shiny/workflowPlot Load outputs from multiple runs of the model @@ -39,6 +40,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Allow SIPNET and DALEC met files and model2netcdf to start or end mid year + ### Changed - Clean up directory structure: * Move `base` packages (`utils`, `settings`, `db`, `visualizaton`) to a `base` directory, for consistency with `modules` and `models` From 9ea2c81c726e9747f1b67f1f84c661c3ef311d94 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 14 Sep 2017 15:35:45 -0400 Subject: [PATCH 645/771] updated changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index afdd232536b..a3aaf820ed0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -44,6 +44,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha * Move `base` packages (`utils`, `settings`, `db`, `visualizaton`) to a `base` directory, for consistency with `modules` and `models` * Move `logger.*` functions out of the `PEcAn.utils` package and into the `pecan.logger` package - #1594 shiny/workflowPlot Refactoring of code. `get_workflow_ids` in db/R/query.dplyr.R changed with `ensemble = FALSE`. Also allowing to load all workflow IDs. `load_data_single_run` and `var_names_all` also moved from shiny/workflowPlot/server.R to query.dplyr.R +- `betyConnect` function in `query.dplyr.R` is now refactored into `read_web_config` so that the the Data-Ingest app can leverage `read_web_config` and provide it with a machine specific filepath for `.../dbfiles` ## [1.5.0] - 2017-07-13 ### Added From b394431322a137565e7ac4537c0f4f0715208078 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Thu, 14 Sep 2017 15:41:36 -0400 Subject: [PATCH 646/771] fixed a merge conflict --- base/db/R/query.dplyr.R | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/base/db/R/query.dplyr.R b/base/db/R/query.dplyr.R index af003767fe1..22d98df5262 100644 --- a/base/db/R/query.dplyr.R +++ b/base/db/R/query.dplyr.R @@ -7,18 +7,6 @@ betyConnect <- function(php.config = "../../web/config.php") { config.list <- PEcAn.utils::read_web_config(php.config) -======= - config <- scan(php.config, what = "character", sep = "\n") - config <- config[grep("^\\$", config)] ## find lines that begin with $ (variables) - config <- sub("$", "", config, fixed = TRUE) ## remove $ - config <- sub(";", "", config, fixed = TRUE) ## remove ; - config <- sub("false", "FALSE", config, fixed = TRUE) ## Boolean capitalization - config <- sub("true", "TRUE", config, fixed = TRUE) ## Boolean capitalization - config <- config[-grep("$", config, fixed = TRUE)] ## lines with variable references fail - config <- config[-grep("exec", config, fixed = TRUE)] ## lines 'exec' fail - config.list <- eval(parse(text = paste("list(", paste0(config[1:14], collapse = ","), ")"))) - - ## Database connection # TODO: The latest version of dplyr/dbplyr works with standard DBI-based # objects, so we should replace this with a standard `db.open` call. From 4ba7d13171714719c4d249424da49e72e315300e Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 14 Sep 2017 15:46:02 -0400 Subject: [PATCH 647/771] Merge new remote documentation with original --- .../adv_user_guide_cmd/Remote-execution.Rmd | 223 --------------- .../Connecting-pecan-to-a-remote-server.Rmd | 256 ++++++++++++++---- 2 files changed, 197 insertions(+), 282 deletions(-) delete mode 100644 book_source/adv_user_guide_cmd/Remote-execution.Rmd diff --git a/book_source/adv_user_guide_cmd/Remote-execution.Rmd b/book_source/adv_user_guide_cmd/Remote-execution.Rmd deleted file mode 100644 index ce393f713ea..00000000000 --- a/book_source/adv_user_guide_cmd/Remote-execution.Rmd +++ /dev/null @@ -1,223 +0,0 @@ -## Remote execution - -### Introduction - -Remote execution allows the user to leverage the power and storage of high performance computing clusters, AWS instances, or specially configured virtual machines, but without leaving their local working environment. -PEcAn uses remote execution primarily to run ecosystem models. - -The infrastructure for remote execution lives in the `PEcAn.remote` package (`base/remote` in the PEcAn repository). - -### Basics of SSH - -All of the PEcAn remote infrastructure depends on the system `ssh` utility, so it's important to make sure this works before attempting the advanced remote execution functionality in PEcAn. - -To connect to a remote server interactively, the command is simply: - -```sh -ssh @ -``` - -For instance, my connection to the BU shared computing cluster looks like: - -```sh -ssh ashiklom@geo.bu.edu -``` - -...which will prompt me for my BU password, and, if successful, will drop me into a login shell on the remote machine. - -Alternatively to the login shell, `ssh` can be used to execute arbitrary code, whose output will be returned exactly as it would if you ran the command locally. -For example, the following: - -```sh -ssh ashiklom@geo.bu.edu pwd -``` - -...will run the `pwd` command, and return the path to my home directory on the BU SCC. -The more advanced example below will run some simple R code on the BU SCC and return the output as if it was run locally. - -```sh -ssh ashiklom@geo.bu.edu Rscript -e "seq(1, 10)" -``` - -### SSH authentication -- password vs. SSH key - -Because this server uses passwords for authentication, this command will then prompt me for my password. - -An alternative to password authentication is using SSH keys. -Under this system, the host machine (say, your laptop, or the PEcAn VM) has to generate a public and private key pair (using the `ssh-keygen` command). -The private key (by default, a file in `~/.ssh/id_rsa`) lives on the host machine, and should **never** be shared with anyone. -The public key will be distributed to any remote machines to which you want the host to be able to connect. -On each remote machine, the public key should be added to a list of authorized keys located in the `~/.ssh/authorized_keys` file (on the remote machine). -The authorized keys list indicates which machines (technically, which keys -- a single machine, and even a single user, can have many keys) are allowed to connect to it. -This is the system used by all of the PEcAn servers (`pecan1`, `pecan2`, `test-pecan`). - -### SSH tunneling - -SSH authentication can be more advanced than indicated above, especially on systems that require dual authentication. -Even simple password-protection can be tricky in scripts, since (by design) it is fairly difficult to get SSH to accept a password from anything other than the raw keyboard input (i.e. SSH doesn't let you pass passwords as input or arguments, because this exposes your password as plain text). - -A convenient and secure way to follow SSH security protocol, but prevent having to go through the full authentication process every time, is to use SSH tunnels (or "sockets", which are effectively synonymous). -Essentially, an SSH socket is a read- and write-protectected file that contains all of the information about an SSH connection. - -To create an SSH tunnel, use a command like the following: - -``` -ssh -n -N -f -o ControlMaster=yes -S /path/to/socket/file @ -``` - -If appropriate, this will prompt you for your password (if using password authentication), and then will drop you back to the command line (thanks to the `-N` flag, which runs SSH without executing a command, the `-f` flag, which pushes SSH into the background, and the `-n` flag, which prevents ssh from reading any input). -It will also create the file `/path/to/socket/file`. - -To use this socket with another command, use the `-S /path/to/file` flag, pointing to the same tunnel file you just created. - -``` -ssh -S /path/to/socket/file -``` - -This will let you access the server without any sort of authentication step. -As before, if `` is blank, you will be dropped into an interactive shell on the remote, or if it's a command, that command will be executed and the output returned. - -To close a socket, use the following: - -``` -ssh -S /path/to/socket/file -O exit -``` - -This will delete the socket file and close the connection. -Alternatively, a scorched earth approach to closing the SSH tunnel if you don't remember where you put the socket file is something like the following: - -``` -pgrep ssh # See which processes will be killed -pkill ssh # Kill those processes -``` - -...which will kill all user processes called `ssh`. - -### SSH tunnels and PEcAn - -Many of the `PEcAn.remote` functions assume that a tunnel is already open. -If working from the web interface, the tunnel will be opened for you by some under-the-hood PHP and Bash code, but if debugging or working locally, you will have to create the tunnel yourself. -The best way to do this is to create the tunnel first, outside of R, as described above. -(In the following examples, I'll use my username `ashiklom` connecting to the `test-pecan` server with a socket stored in `/tmp/testpecan`. -To follow along, replace these with your own username and designated server, respectively). - -```{sh} -ssh -nNf -o ControlMaster=yes -S /tmp/testpecan ashiklom@test-pecan.bu.edu -``` - -Then, in R, create a `host` object, which is just a list containing the elements `name` (hostname) and `tunnel` (path to tunnel file). - -```{r} -my_host <- list(name = "test-pecan.bu.edu", tunnel = "/tmp/testpecan") -``` - -This host object can then be used in any of the remote execution functions. - - -## Basic remote execute functions - -The `PEcAn.remote::remote.execute.cmd` function runs a system command on a remote server (or on the local server, if `host$name == "localhost"`). - -```{r} -x <- PEcAn.remote::remote.execute.cmd(host = my_host, cmd = "echo", args = "Hello world") -x -``` - -Note that `remote.execute.cmd` is similar to base R's `system2`, in that the base command (in this case, `echo`) is passed separately from its arguments (`"Hello world"`). -Note also that the output of the remote command is returned as a character. - -For R code, there is a special wrapper around `remote.execute.cmd` -- `PEcAn.remote::remote.execute.R`, which runs R code on a remote and returns the output. -R code can be passed in as a list of strings... - -```{r} -code <- c("x <- 2:4", "y <- 3:1", "dput(x ^ y)") -``` - -...as a single string... - -```{r} -code <- " - x <- 2:4 - y <- 3:1 - dput(x ^ y) -" -``` - -...or as an unevaluated R expression (generated by the base R `quote` function). - -```{r} -code <- quote({ - x <- 2:4 - y <- 3:1 - dput(x ^ y) -}) -out <- PEcAn.remote::remote.execute.R(code = code, host = my_host) -out -``` - -Note that the `dput()` statement at the end is required to properly return output. - -For additional functions related to file operations and other stuff, see the `PEcAn.remote` package documentation. - - -## Remote model execution with PEcAn - -The workhorse of remote model execution is the `PEcAn.remote::start.model.runs` function, which distributes execution of each run in a list of runs (e.g. multiple runs in an ensemble) to the local machine or a remote based on the configuration in the PEcAn settings. - -Broadly, there are three major types of model execution: - -- Serialized (`PEcAn.remote::start_serial`) -- This runs models one at a time, directly on the local machine or remote (i.e. same as calling the executables one at a time for each run). -- Via a queue system, (`PEcAn.remote::start_qsub`) -- This uses a queue management system, such as SGE (e.g. `qsub`, `qstat`) found on the BU SCC machines, to submit jobs. - For computationally intensive tasks, this is the recommended way to go. -- Via a model launcher script (`PEcAn.remote::setup_modellauncher`) -- This is a highly customizable approach where task submission is controlled by a user-provided script (`launcher.sh`). - -### XML configuration - -The relevant section of the PEcAn XML file is the `` block. -Here is a minimal example from one of my recent runs: - -``` - - geo.bu.edu - ashiklom - /home/carya/output//PEcAn_99000000008/tunnel/tunnel - -``` - -Breaking this down: - -- `name` -- The hostname of the machine where the runs will be performed. - Set it to `localhost` to run on the local machine. -- `user` -- Your username on the remote machine (note that this may be different from the username on your local machine). -- `tunnel` -- This is the tunnel file for the connection used by all remote execution files. - The tunnel is created automatically by the web interface, but must be created by the user for command line execution. - -This configuration will run in serialized mode. -To use `qsub`, the configuration is slightly more involved: - -``` - - geo.bu.edu - ashiklom - qsub -V -N @NAME@ -o @STDOUT@ -e @STDERR@ -S /bin/bash - Your job ([0-9]+) .* - qstat -j @JOBID@ || echo DONE - /home/carya/output//PEcAn_99000000008/tunnel/tunnel - -``` - -The additional fields are as follows: - -- `qsub` -- The command used to submit jobs to the queue system. - Despite the name, this can be any command used for any queue system. - The following variables are available to be set here: - - `@NAME@` -- Job name to display - - `@STDOUT@` -- File to which `stdout` will be redirected - - `@STDERR@` -- File to which `stderr` will be redirected -- `qsub.jobid` -- A regular expression, from which the job ID will be determined. - This string will be parsed by R as `jobid <- gsub(qsub.jobid, "\\1", output)` -- note that the first pattern match is taken as the job ID. -- `qstat` -- The command used to check the status of a job. - Internally, PEcAn will look for the `DONE` string at the end, so a structure like ` || echo DONE` is required. - The `@JOBID@` here is the job ID determined from the `qsub.jobid` parsing. - -Documentation for using the model launcher is currently unavailable. diff --git a/book_source/adv_user_guide_web/Connecting-pecan-to-a-remote-server.Rmd b/book_source/adv_user_guide_web/Connecting-pecan-to-a-remote-server.Rmd index 8a0327d57fb..701ca9fff88 100755 --- a/book_source/adv_user_guide_web/Connecting-pecan-to-a-remote-server.Rmd +++ b/book_source/adv_user_guide_web/Connecting-pecan-to-a-remote-server.Rmd @@ -1,46 +1,107 @@ # PEcAn and Remote Machines -This section will describe how to use PEcAn with remote machines. This -will be split into three pieces. The first section will describe how to -setup your system to allow you to execute remotely without any password -prompts. The next section will describe any items to add to the -pecan.xml and the config.php files to enable remote execution from both -PEcAn on the command line and PEcAn on the web. Finally the final -section will describe how to install sub pieces of PEcAn on machines, to -allow those machines to run the models. +Remote execution allows the user to leverage the power and storage of high performance computing clusters, AWS instances, or specially configured virtual machines, but without leaving their local working environment. +PEcAn uses remote execution primarily to run ecosystem models. -## SSH to remote machines +The infrastructure for remote execution lives in the `PEcAn.remote` package (`base/remote` in the PEcAn repository). -PEcAn leverages of SSH to communicate with remote machines. PEcAn expects -to be able to connect to the remote machines without any password prompts. -This can be accomplished many different ways, two common methods are to -use a public/private keypair, the other is to use tunnels. The web -interface is build to leverage the latter. +This section describes the following: -Once setup you should be able to login to the remote machine without -being asked for a password. +- Basics of command line SSH +- SSH authentication with keys and passwords +- Basics of SSH tunnels, and how they are used in PEcAn +- Basic remote exectuion R functions in `PEcAn.remote` +- Remote model execution configuration in the `pecan.xml` and `config.php` +- Additional information about preparing remote servers for execution -### public/prvate keypairs -Before the first time, run `scripts/sshkey.sh` This will create a -public/private keypair, and places the public key on the remote server. +## Basics of SSH -### machine authentcation +All of the PEcAn remote infrastructure depends on the system `ssh` utility, so it's important to make sure this works before attempting the advanced remote execution functionality in PEcAn. -Some systems (e.g. BU cluster) use authentication at the machine-level -rather than the user-level. In this case you will need to create a .rhosts -file in your home directory on the remote machine and list the servers you -want to connect from. [See issue #428](https://github.com/PecanProject/pecan/issues/428) +To connect to a remote server interactively, the command is simply: -### ssh tunnels +```sh +ssh @ +``` + +For instance, my connection to the BU shared computing cluster looks like: + +```sh +ssh ashiklom@geo.bu.edu +``` + +...which will prompt me for my BU password, and, if successful, will drop me into a login shell on the remote machine. + +Alternatively to the login shell, `ssh` can be used to execute arbitrary code, whose output will be returned exactly as it would if you ran the command locally. +For example, the following: + +```sh +ssh ashiklom@geo.bu.edu pwd +``` + +...will run the `pwd` command, and return the path to my home directory on the BU SCC. +The more advanced example below will run some simple R code on the BU SCC and return the output as if it was run locally. + +```sh +ssh ashiklom@geo.bu.edu Rscript -e "seq(1, 10)" +``` + +## SSH authentication -- password vs. SSH key + +Because this server uses passwords for authentication, this command will then prompt me for my password. + +An alternative to password authentication is using SSH keys. +Under this system, the host machine (say, your laptop, or the PEcAn VM) has to generate a public and private key pair (using the `ssh-keygen` command). +The private key (by default, a file in `~/.ssh/id_rsa`) lives on the host machine, and should **never** be shared with anyone. +The public key will be distributed to any remote machines to which you want the host to be able to connect. +On each remote machine, the public key should be added to a list of authorized keys located in the `~/.ssh/authorized_keys` file (on the remote machine). +The authorized keys list indicates which machines (technically, which keys -- a single machine, and even a single user, can have many keys) are allowed to connect to it. +This is the system used by all of the PEcAn servers (`pecan1`, `pecan2`, `test-pecan`). + +### SSH tunneling + +SSH authentication can be more advanced than indicated above, especially on systems that require dual authentication. +Even simple password-protection can be tricky in scripts, since (by design) it is fairly difficult to get SSH to accept a password from anything other than the raw keyboard input (i.e. SSH doesn't let you pass passwords as input or arguments, because this exposes your password as plain text). + +A convenient and secure way to follow SSH security protocol, but prevent having to go through the full authentication process every time, is to use SSH tunnels (or "sockets", which are effectively synonymous). +Essentially, an SSH socket is a read- and write-protectected file that contains all of the information about an SSH connection. + +To create an SSH tunnel, use a command like the following: + +``` +ssh -n -N -f -o ControlMaster=yes -S /path/to/socket/file @ +``` + +If appropriate, this will prompt you for your password (if using password authentication), and then will drop you back to the command line (thanks to the `-N` flag, which runs SSH without executing a command, the `-f` flag, which pushes SSH into the background, and the `-n` flag, which prevents ssh from reading any input). +It will also create the file `/path/to/socket/file`. + +To use this socket with another command, use the `-S /path/to/file` flag, pointing to the same tunnel file you just created. + +``` +ssh -S /path/to/socket/file +``` + +This will let you access the server without any sort of authentication step. +As before, if `` is blank, you will be dropped into an interactive shell on the remote, or if it's a command, that command will be executed and the output returned. + +To close a socket, use the following: + +``` +ssh -S /path/to/socket/file -O exit +``` + +This will delete the socket file and close the connection. +Alternatively, a scorched earth approach to closing the SSH tunnel if you don't remember where you put the socket file is something like the following: + +``` +pgrep ssh # See which processes will be killed +pkill ssh # Kill those processes +``` -This works especially well for servers that use two factor authentication. -This method leverages of the ability of SSH to send multiple channels -across the same encrypted connection (tunnel). You will setup the -first connection, and all subsequent connections will use the same -connection. +...which will kill all user processes called `ssh`. -To automatically create the tunnels, you can add the following to your +To automatically create tunnels following a specific pattern, you can add the following to your `~/.ssh/config` ``` @@ -49,29 +110,120 @@ Host ControlPath /tmp/%r@%h:%p ``` -You can also create the tunnel using the following command: +For more information, see `man ssh`. + +### SSH tunnels and PEcAn + +Many of the `PEcAn.remote` functions assume that a tunnel is already open. +If working from the web interface, the tunnel will be opened for you by some under-the-hood PHP and Bash code, but if debugging or working locally, you will have to create the tunnel yourself. +The best way to do this is to create the tunnel first, outside of R, as described above. +(In the following examples, I'll use my username `ashiklom` connecting to the `test-pecan` server with a socket stored in `/tmp/testpecan`. +To follow along, replace these with your own username and designated server, respectively). + +```{sh} +ssh -nNf -o ControlMaster=yes -S /tmp/testpecan ashiklom@test-pecan.bu.edu +``` + +Then, in R, create a `host` object, which is just a list containing the elements `name` (hostname) and `tunnel` (path to tunnel file). + +```{r} +my_host <- list(name = "test-pecan.bu.edu", tunnel = "/tmp/testpecan") +``` + +This host object can then be used in any of the remote execution functions. + + +## Basic remote execute functions + +The `PEcAn.remote::remote.execute.cmd` function runs a system command on a remote server (or on the local server, if `host$name == "localhost"`). + +```{r} +x <- PEcAn.remote::remote.execute.cmd(host = my_host, cmd = "echo", args = "Hello world") +x +``` + +Note that `remote.execute.cmd` is similar to base R's `system2`, in that the base command (in this case, `echo`) is passed separately from its arguments (`"Hello world"`). +Note also that the output of the remote command is returned as a character. + +For R code, there is a special wrapper around `remote.execute.cmd` -- `PEcAn.remote::remote.execute.R`, which runs R code (passed as a string) on a remote and returns the output. + +```{r} +code <- " + x <- 2:4 + y <- 3:1 + x ^ y +" +out <- PEcAn.remote::remote.execute.R(code = code, host = my_host) +``` + +For additional functions related to remote file operations and other stuff, see the `PEcAn.remote` package documentation. + + +## Remote model execution with PEcAn + +The workhorse of remote model execution is the `PEcAn.remote::start.model.runs` function, which distributes execution of each run in a list of runs (e.g. multiple runs in an ensemble) to the local machine or a remote based on the configuration in the PEcAn settings. + +Broadly, there are three major types of model execution: + +- Serialized (`PEcAn.remote::start_serial`) -- This runs models one at a time, directly on the local machine or remote (i.e. same as calling the executables one at a time for each run). +- Via a queue system, (`PEcAn.remote::start_qsub`) -- This uses a queue management system, such as SGE (e.g. `qsub`, `qstat`) found on the BU SCC machines, to submit jobs. + For computationally intensive tasks, this is the recommended way to go. +- Via a model launcher script (`PEcAn.remote::setup_modellauncher`) -- This is a highly customizable approach where task submission is controlled by a user-provided script (`launcher.sh`). + +### XML configuration + +The relevant section of the PEcAn XML file is the `` block. +Here is a minimal example from one of my recent runs: ``` -ssh -o ControlMaster=yes -o ControlPath=/tmp/mytunnel -l username host + + geo.bu.edu + ashiklom + /home/carya/output//PEcAn_99000000008/tunnel/tunnel + ``` -Next create a single ssh connection to the host, any ssh connection -afterwards will use the same connection and should not require a -password. +Breaking this down: -Before running the PEcAn workflow, open (and leave open) a single ssh -connection from the local machine to the remote machine. +- `name` -- The hostname of the machine where the runs will be performed. + Set it to `localhost` to run on the local machine. +- `user` -- Your username on the remote machine (note that this may be different from the username on your local machine). +- `tunnel` -- This is the tunnel file for the connection used by all remote execution files. + The tunnel is created automatically by the web interface, but must be created by the user for command line execution. -## Configuring PEcAn to execute remotely +This configuration will run in serialized mode. +To use `qsub`, the configuration is slightly more involved: -To enable PEcAn to run remotely we will need to modify the `pecan.xml` -to specify what host to connect to, what user to connect as, and how -to connect. The web interface will create the `pecan.xml` with the -appropriate entries. +``` + + geo.bu.edu + ashiklom + qsub -V -N @NAME@ -o @STDOUT@ -e @STDERR@ -S /bin/bash + Your job ([0-9]+) .* + qstat -j @JOBID@ || echo DONE + /home/carya/output//PEcAn_99000000008/tunnel/tunnel + +``` + +The additional fields are as follows: + +- `qsub` -- The command used to submit jobs to the queue system. + Despite the name, this can be any command used for any queue system. + The following variables are available to be set here: + - `@NAME@` -- Job name to display + - `@STDOUT@` -- File to which `stdout` will be redirected + - `@STDERR@` -- File to which `stderr` will be redirected +- `qsub.jobid` -- A regular expression, from which the job ID will be determined. + This string will be parsed by R as `jobid <- gsub(qsub.jobid, "\\1", output)` -- note that the first pattern match is taken as the job ID. +- `qstat` -- The command used to check the status of a job. + Internally, PEcAn will look for the `DONE` string at the end, so a structure like ` || echo DONE` is required. + The `@JOBID@` here is the job ID determined from the `qsub.jobid` parsing. -### config.php for PEcAn web interface +Documentation for using the model launcher is currently unavailable. -The config.php has a few variables that will control where the web +### Configuration for PEcAn web interface + +The `config.php` has a few variables that will control where the web interface can run jobs, and how to run those jobs. These variables are `$hostlist`, `$qsublist`, `$qsuboptions`, and `$SSHtunnel`. In the near future `$hostlist`, `$qsublist`, `$qsuboptions` will be @@ -114,20 +266,6 @@ are additional entries to add to the job.sh file generated to run the model. This can be used to make sure modules are loaded on the HPC cluster before running the actual model. -### pecan.xml for PEcAn command line runs - -To enable remote execution from the command line you will need -to add the <host> tag to pecan.xml (under <run>). -This will let PEcAn know it should run the model on the remote -system. You will need to specify the <name> tag to specify -the remote machine. You can add <user> to specify the -user, or you can use <tunnel> to specify the location of -the tunnel to be used. - -You can also add <job.sh> to both <host> and -<model> to add specific information to the job.sh file -used to run the model. - ## Running PEcAn code for modules remotely You can compile and install the model specific code pieces of From 1905133b6e331b6c707df44b62cc272941d7bdbc Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 14 Sep 2017 17:29:41 -0400 Subject: [PATCH 648/771] remote: Remove "hello" file from package creation --- base/remote/man/hello.Rd | 12 ------------ 1 file changed, 12 deletions(-) delete mode 100644 base/remote/man/hello.Rd diff --git a/base/remote/man/hello.Rd b/base/remote/man/hello.Rd deleted file mode 100644 index 0fa7c4b8817..00000000000 --- a/base/remote/man/hello.Rd +++ /dev/null @@ -1,12 +0,0 @@ -\name{hello} -\alias{hello} -\title{Hello, World!} -\usage{ -hello() -} -\description{ -Prints 'Hello, world!'. -} -\examples{ -hello() -} From 54a3a8ca852c08587dc5e53e1405d4d0f25e3287 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Thu, 14 Sep 2017 18:07:53 -0400 Subject: [PATCH 649/771] fix merge conflict --- base/db/R/query.dplyr.R | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/base/db/R/query.dplyr.R b/base/db/R/query.dplyr.R index af003767fe1..51fc643cf56 100644 --- a/base/db/R/query.dplyr.R +++ b/base/db/R/query.dplyr.R @@ -6,18 +6,6 @@ betyConnect <- function(php.config = "../../web/config.php") { ## Read PHP config file for webserver config.list <- PEcAn.utils::read_web_config(php.config) - -======= - config <- scan(php.config, what = "character", sep = "\n") - config <- config[grep("^\\$", config)] ## find lines that begin with $ (variables) - config <- sub("$", "", config, fixed = TRUE) ## remove $ - config <- sub(";", "", config, fixed = TRUE) ## remove ; - config <- sub("false", "FALSE", config, fixed = TRUE) ## Boolean capitalization - config <- sub("true", "TRUE", config, fixed = TRUE) ## Boolean capitalization - config <- config[-grep("$", config, fixed = TRUE)] ## lines with variable references fail - config <- config[-grep("exec", config, fixed = TRUE)] ## lines 'exec' fail - config.list <- eval(parse(text = paste("list(", paste0(config[1:14], collapse = ","), ")"))) - ## Database connection # TODO: The latest version of dplyr/dbplyr works with standard DBI-based From 6586ac84ff1a38191ba4d7e4d0c77d482082ace3 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Fri, 15 Sep 2017 05:27:49 -0400 Subject: [PATCH 650/771] merge conflict: Changelog --- CHANGELOG.md | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6f174a42dd5..0186fcb38ae 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -49,11 +49,10 @@ For more information about this file see also [Keep a Changelog](http://keepacha * Move `logger.*` functions out of the `PEcAn.utils` package and into the `PEcAn.logger` package * More `remote` functions out of the `PEcAn.utils` package and into their own `PEcAn.remote` package. - #1594 shiny/workflowPlot Refactoring of code. `get_workflow_ids` in db/R/query.dplyr.R changed with `ensemble = FALSE`. Also allowing to load all workflow IDs. `load_data_single_run` and `var_names_all` also moved from shiny/workflowPlot/server.R to query.dplyr.R -<<<<<<< HEAD -- `betyConnect` function in `query.dplyr.R` is now refactored into `read_web_config` so that the the Data-Ingest app can leverage `read_web_config` and provide it with a machine specific filepath for `.../dbfiles` -======= - `PEcAn.remote::start.model.runs` has been significantly refactored to be less redundant and more robust ->>>>>>> 88f98fecc3db6187b1175660162adf758efbc691 +- `betyConnect` function in `query.dplyr.R` is now refactored into `read_web_config` so that the the Data-Ingest app can leverage `read_web_config` and provide it with a machine specific filepath for `.../dbfiles` + + ## [1.5.0] - 2017-07-13 ### Added From 15c9fc5b48aca9d9eeaca7c3ef3b36d2bc9da9b6 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Fri, 15 Sep 2017 05:28:34 -0400 Subject: [PATCH 651/771] merge conflict: betyConnect --- base/db/R/query.dplyr.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/base/db/R/query.dplyr.R b/base/db/R/query.dplyr.R index 34b6d778fe4..51fc643cf56 100644 --- a/base/db/R/query.dplyr.R +++ b/base/db/R/query.dplyr.R @@ -6,11 +6,7 @@ betyConnect <- function(php.config = "../../web/config.php") { ## Read PHP config file for webserver config.list <- PEcAn.utils::read_web_config(php.config) -<<<<<<< HEAD - -======= ->>>>>>> 88f98fecc3db6187b1175660162adf758efbc691 ## Database connection # TODO: The latest version of dplyr/dbplyr works with standard DBI-based # objects, so we should replace this with a standard `db.open` call. From e1a1fdc58a5f2a4ebcb6763b89e1bd001631a5d2 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Fri, 15 Sep 2017 07:10:21 -0400 Subject: [PATCH 652/771] read_web_config wasn't put in base --- {utils => base/utils}/R/read_web_config.R | 0 {utils => base/utils}/man/read_web_config.Rd | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename {utils => base/utils}/R/read_web_config.R (100%) rename {utils => base/utils}/man/read_web_config.Rd (100%) diff --git a/utils/R/read_web_config.R b/base/utils/R/read_web_config.R similarity index 100% rename from utils/R/read_web_config.R rename to base/utils/R/read_web_config.R diff --git a/utils/man/read_web_config.Rd b/base/utils/man/read_web_config.Rd similarity index 100% rename from utils/man/read_web_config.Rd rename to base/utils/man/read_web_config.Rd From ef5b98f815a956bbbdf0aba746f9a1de4f4c359a Mon Sep 17 00:00:00 2001 From: istfer Date: Fri, 15 Sep 2017 08:40:59 -0400 Subject: [PATCH 653/771] multiply the whole beta term --- modules/assim.batch/R/pda.define.llik.R | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/modules/assim.batch/R/pda.define.llik.R b/modules/assim.batch/R/pda.define.llik.R index 300a6804cdd..d567e018e4d 100644 --- a/modules/assim.batch/R/pda.define.llik.R +++ b/modules/assim.batch/R/pda.define.llik.R @@ -83,9 +83,17 @@ pda.calc.error <-function(settings, con, model_out, run.id, inputs, bias.terms){ # pda.errors[[k]] <- sum(SS, na.rm = TRUE) # SSdb[[k]] <- sum(SS, na.rm = TRUE) - beta_p <- (inputs[[k]]$par[1] + inputs[[k]]$par[2] * model_out[[k]][pos]* sqrt(inputs[[k]]$n/inputs[[k]]$n_eff) ) - beta_n <- (inputs[[k]]$par[1] + inputs[[k]]$par[3] * model_out[[k]][!pos]* sqrt(inputs[[k]]$n/inputs[[k]]$n_eff)) + # heteroskedastic slopes, slope varies with magnitude of the flux + # inflated by sqrt(n/neff) because var is 2b^2 for laplacian likelihood + beta_p <- (inputs[[k]]$par[1] + inputs[[k]]$par[2] * model_out[[k]][pos]) * sqrt(inputs[[k]]$n/inputs[[k]]$n_eff) + beta_n <- (inputs[[k]]$par[1] + inputs[[k]]$par[3] * model_out[[k]][!pos])* sqrt(inputs[[k]]$n/inputs[[k]]$n_eff) + + # there might not be a negative slope if non-negative variable, assign zero, move on suppressWarnings(if(length(beta_n) == 0) beta_n <- 0) + + # weigh down log-likelihood calculation with neff + # if we had one beta value (no heteroscadasticity), we could've multiply n_eff*beta + # now need to multiply every term with n_eff/n SS_p <- - (inputs[[k]]$n_eff/inputs[[k]]$n) * log(beta_p) - resid[[1]][pos]/beta_p SS_n <- - (inputs[[k]]$n_eff/inputs[[k]]$n) * log(beta_n) - resid[[1]][!pos]/beta_n suppressWarnings(if(length(SS_n) == 0) SS_n <- 0) From 2b72589cb4a75eff91a111246d9c5c76caa959d9 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Fri, 15 Sep 2017 11:35:40 -0500 Subject: [PATCH 654/771] increased max file upload and cleaning --- shiny/Data-Ingest/app.R | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/shiny/Data-Ingest/app.R b/shiny/Data-Ingest/app.R index 562e6714b28..90cf6998fd6 100644 --- a/shiny/Data-Ingest/app.R +++ b/shiny/Data-Ingest/app.R @@ -56,18 +56,32 @@ ui <- dashboardPage( ) server <- function(input, output) { + options(shiny.maxRequestSize=30*1024^2) #maximum file input size - # d1d <- eventReactive(input$D1Button, { input$id }) #print doi on click - - # How do I force R to load the dependencies before I run dataone_download? brew, redland, datapack, dataone - d1d <- eventReactive(input$D1Button, { PEcAn.data.land::dataone_download(input$id) }) #run dataone_download with input from id on click + #path <- PEcAn.utils::read_web_config(config.php) + + d1d <- eventReactive(input$D1Button, { PEcAn.data.land::dataone_download(input$id, filepath = path) }) #run dataone_download with input from id on click output$identifier <- renderText({ d1d() }) - # output$debug <- # file.copy copy from tmp file to + # output$debug <- + + # + + output$upload <- renderTable({ + if(is.null(data())){return()} + input$file + }) + + #file.copy(inFile$datapath, header = input$header) + + + +# file.copy copy from tmp file to + } # Run the application From 737e18f7cd5a978511f1fca444baa2a8c2e5a399 Mon Sep 17 00:00:00 2001 From: Tess McCabe Date: Fri, 15 Sep 2017 12:43:11 -0400 Subject: [PATCH 655/771] Update align_by_obeservation_one.R --- modules/benchmark/R/align_by_obeservation_one.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/benchmark/R/align_by_obeservation_one.R b/modules/benchmark/R/align_by_obeservation_one.R index 7b5a176c498..e99bc532237 100644 --- a/modules/benchmark/R/align_by_obeservation_one.R +++ b/modules/benchmark/R/align_by_obeservation_one.R @@ -1,6 +1,6 @@ ################################################################# #' -#' @title align_by_observation_one +#' align_by_observation_one #' @param observation_one a vector of plant fucntional types, or species #' @param observation_two anouther vector of plant fucntional types, or species #' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. From 1b17207650630ad79b2ea239f2d45fff2880027f Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Fri, 15 Sep 2017 13:39:27 -0400 Subject: [PATCH 656/771] Fixed bug with the naming scheme --- modules/data.land/R/dataone_download.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index eda35acd9e8..ef100bc5ede 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -40,8 +40,7 @@ dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNod dir.create(newdir) for(i in 1:n){ - rename <- paste(i, basename(names(files[i])), sep="_") # new file name - system(paste("cd", newdir, "&&", "{", "wget", "--content-disposition", rename, names(files)[i], "; cd -; }")) # cd to newdir, download files with wget, cd back + system(paste("cd", newdir, "&&", "{", "wget", "--content-disposition", names(files)[i], "; cd -; }")) # cd to newdir, download files with wget, cd back } list.files(newdir) # checks that files were downloaded to From c4d8c265b330707cae9f73c332a0e5a7aa40b498 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Fri, 15 Sep 2017 13:51:34 -0400 Subject: [PATCH 657/771] cleaned up and made clarifying comment --- modules/data.land/R/dataone_download.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index ef100bc5ede..8097dbf1bcf 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -39,10 +39,9 @@ dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNod newdir <- file.path(filepath, paste0("DataOne_", gsub("/", "-", id))) dir.create(newdir) + # download the data with wget for(i in 1:n){ system(paste("cd", newdir, "&&", "{", "wget", "--content-disposition", names(files)[i], "; cd -; }")) # cd to newdir, download files with wget, cd back } - list.files(newdir) # checks that files were downloaded to - - # Naming could still be improved to include part of title + } From 18ec96a15fcca977c0c41303cd5c93e194eb3948 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Fri, 15 Sep 2017 14:08:17 -0400 Subject: [PATCH 658/771] Fixed error in example. --- modules/data.land/R/dataone_download.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/modules/data.land/R/dataone_download.R b/modules/data.land/R/dataone_download.R index 8097dbf1bcf..4e574bd3c6c 100644 --- a/modules/data.land/R/dataone_download.R +++ b/modules/data.land/R/dataone_download.R @@ -14,7 +14,7 @@ #' @examples #' /dontrun{ -#' doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", filepath = "/fs/data1/pecan.data/dbfiles/") +#' dataone_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", filepath = "/fs/data1/pecan.data/dbfiles/") #' } dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNode = "PROD", lazyLoad = FALSE, quiet = F){ @@ -44,4 +44,7 @@ dataone_download = function(id, filepath = "/fs/data1/pecan.data/dbfiles/", CNod system(paste("cd", newdir, "&&", "{", "wget", "--content-disposition", names(files)[i], "; cd -; }")) # cd to newdir, download files with wget, cd back } - } +} + + + From 6992de1205ebd26330adb6805943fc27e6a81a2f Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Fri, 15 Sep 2017 14:15:58 -0400 Subject: [PATCH 659/771] FORGOT THE ROXYGENDOCS AGAIN!!!!!!! --- modules/data.land/man/dataone_download.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/man/dataone_download.Rd b/modules/data.land/man/dataone_download.Rd index 716f6ed243f..be7195ee8e5 100644 --- a/modules/data.land/man/dataone_download.Rd +++ b/modules/data.land/man/dataone_download.Rd @@ -23,7 +23,7 @@ Adapts the dataone::getDataPackage workflow to allow users to download data from } \examples{ /dontrun{ -doi_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", filepath = "/fs/data1/pecan.data/dbfiles/") +dataone_download(id = "doi:10.6073/pasta/63ad7159306bc031520f09b2faefcf87", filepath = "/fs/data1/pecan.data/dbfiles/") } } \author{ From 98eaa9743d853365ec00f01a495c7540baa1252b Mon Sep 17 00:00:00 2001 From: mccabete Date: Fri, 15 Sep 2017 16:22:32 -0400 Subject: [PATCH 660/771] Pull request fixes --- modules/benchmark/NAMESPACE | 3 +- ...ion_one.R => align_by_first_observation.R} | 41 ++++-- .../benchmark/R/align_by_obeservation_two.R | 45 ------ modules/benchmark/R/align_data_to_data_pft.R | 138 +++++++----------- modules/benchmark/R/align_pft.R | 33 +++-- modules/benchmark/R/check_if_legal_table.R | 2 +- modules/benchmark/R/check_if_list_of_pfts.R | 4 +- .../benchmark/R/get_species_list_standard.R | 11 +- ...n_one.Rd => align_by_first_observation.Rd} | 18 +-- .../benchmark/man/align_by_observation_two.Rd | 36 ----- .../benchmark/man/align_data_to_data_pft.Rd | 5 +- modules/benchmark/man/align_pft.Rd | 15 +- modules/benchmark/man/check_if_legal_table.Rd | 3 + .../benchmark/man/check_if_list_of_pfts.Rd | 9 +- .../man/get_species_list_standard.Rd | 14 +- 15 files changed, 146 insertions(+), 231 deletions(-) rename modules/benchmark/R/{align_by_obeservation_one.R => align_by_first_observation.R} (64%) delete mode 100644 modules/benchmark/R/align_by_obeservation_two.R rename modules/benchmark/man/{align_by_observation_one.Rd => align_by_first_observation.Rd} (64%) delete mode 100644 modules/benchmark/man/align_by_observation_two.Rd diff --git a/modules/benchmark/NAMESPACE b/modules/benchmark/NAMESPACE index a1bd3946a69..3f206c2ac73 100644 --- a/modules/benchmark/NAMESPACE +++ b/modules/benchmark/NAMESPACE @@ -1,7 +1,6 @@ # Generated by roxygen2: do not edit by hand -export(align_by_observation_one) -export(align_by_observation_two) +export(align_by_first_observation) export(align_data) export(align_data_to_data_pft) export(align_pft) diff --git a/modules/benchmark/R/align_by_obeservation_one.R b/modules/benchmark/R/align_by_first_observation.R similarity index 64% rename from modules/benchmark/R/align_by_obeservation_one.R rename to modules/benchmark/R/align_by_first_observation.R index 7b5a176c498..f435eb93b61 100644 --- a/modules/benchmark/R/align_by_obeservation_one.R +++ b/modules/benchmark/R/align_by_first_observation.R @@ -1,9 +1,9 @@ ################################################################# #' -#' @title align_by_observation_one -#' @param observation_one a vector of plant fucntional types, or species -#' @param observation_two anouther vector of plant fucntional types, or species -#' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +#' align_first_observation +#' @param observation_one a vector of plant fucntional types, or species. Provides species/pft names. +#' @param observation_two another vector of plant fucntional types, or species. Provides the order. +#' @param custom_table a table that either maps two pft's to one another or maps custom species codes to bety id codes. #' In the second case, must be passable to match_species_id. #' @return \code{vector} Returns a vector of PFT's/species from observation_one that matches the order of observation_two } #' @@ -12,35 +12,44 @@ #' #' observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") #' observation_two<-c("a", "b", "a", "a") +#' #' table<-list() #' table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") #' table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings -#' table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species #' table<-as.data.frame(table) #' -#' format_one<-"species_USDA_symbol" -#' format_two<-"plant_funtional_type" -#' #' aligned<-align_by_observation_one(observation_one = observation_one, observation_two = observation_two, #' custom_table = table) +#' #' # aligned should be a vector '[1] "AMCA3" "ARHY" "AMCA3" "AMCA3"' #' @export -align_by_observation_one<-function(observation_one, observation_two, custom_table){ +align_by_first_observation<-function(observation_one, observation_two, custom_table){ + final<-c() - for( i in 1:length(observation_two)){ # For loop finds "coursest" PFT. + + for( i in seq_along(observation_two)){ # For loop finds "coursest" PFT. + subset<-custom_table[custom_table$plant_functional_type_two == observation_two[i],] - if(length(subset$plant_functional_type_one)>length(subset$plant_functional_type_two)){ + + if(length(subset$plant_functional_type_one) > length(subset$plant_functional_type_two)){ + final[i]<-as.character(subset$plant_functional_type_two) - }else if(length(subset$plant_functional_type_one)>length(subset$plant_functional_type_two)){ + + }else if(length(subset$plant_functional_type_one) < length(subset$plant_functional_type_two)){ + final[i]<-as.character(subset$plant_functional_type_one) - }else if (length(subset$plant_functional_type_one)==length(subset$plant_functional_type_two)){ + + }else if (length(subset$plant_functional_type_one) == length(subset$plant_functional_type_two)){ + final[i]<-as.character(subset$plant_functional_type_one) + }else{ + PEcAn.logger::logger.warn("There are no subsets of the custom_table that are alignable. Likely a problem with the custom_table format") - aligned_species_list$final<-NULL - } + + } + } - as.vector(final) return(final) } diff --git a/modules/benchmark/R/align_by_obeservation_two.R b/modules/benchmark/R/align_by_obeservation_two.R deleted file mode 100644 index d68ba0cbcdf..00000000000 --- a/modules/benchmark/R/align_by_obeservation_two.R +++ /dev/null @@ -1,45 +0,0 @@ -################################################################# -#' @title align_by_observation_two -#' @param observation_one a vector of plant fucntional types, or species -#' @param observation_two anouther vector of plant fucntional types, or species -#' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. -#' In the second case, must be passable to match_species_id. -#' @return \code{vector} Returns a vector of PFT's/species from observation_two that matches the order of observation_one } -#' @author Tempest McCabe -#' @examples -#' -#' observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") -#' observation_two<-c("a", "b", "a", "a") -#' table<-list() -#' table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") -#' table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings -#' table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species -#' table<-as.data.frame(table) -#' -#' format_one<-"species_USDA_symbol" -#' format_two<-"plant_funtional_type" -#' -#' aligned<-align_by_observation_one(observation_one = observation_one, observation_two = observation_two, -#' custom_table = table) -#' # aligned should be a vector '[1] "a" "a" "a" "a"' -#' @export - -align_by_observation_two<-function(observation_one, observation_two, custom_table){ -final<-c() - for( i in 1:length(observation_two)){ # For loop finds "coursest" PFT. - subset<-custom_table[custom_table$plant_functional_type_one == observation_one[i],] - if(length(subset$plant_functional_type_two)>length(subset$plant_functional_type_one)){ - final[i]<-as.character(subset$plant_functional_type_one) - }else if(length(subset$plant_functional_type_two)>length(subset$plant_functional_type_one)){ - final[i]<-as.character(subset$plant_functional_type_two) - }else if (length(subset$plant_functional_type_two)==length(subset$plant_functional_type_one)){ - final[i]<-as.character(subset$plant_functional_type_two) - }else{ - PEcAn.logger::logger.warn("There are no subsets of the custom_table that are alignable. Likely a problem with the custom_table format") - aligned_species_list$final<-NULL - } - } - as.vector(final) - return(final) -} - diff --git a/modules/benchmark/R/align_data_to_data_pft.R b/modules/benchmark/R/align_data_to_data_pft.R index b9ceb95d42a..8c77515d639 100644 --- a/modules/benchmark/R/align_data_to_data_pft.R +++ b/modules/benchmark/R/align_data_to_data_pft.R @@ -1,5 +1,5 @@ ################################################################# -#'@title{align_data_to_data_pft} +#'align_data_to_data_pft #'@details #' Aligns vectors of Plant Fucntional Typed and species. #' Can align: @@ -11,13 +11,6 @@ #' and an aligned output. Becuase some alignement is order-sensitive, alignment based on observation_one #' and observation_two are both provided. #' -#'\code{comparison_type} can be one of the following: -#' \describe{ -#' \item{\code{data_to_data}}{Will align lists of pfts and species. Must be assosiated with inputs.} -#' \item{\code{data_to_model}}{Not yet implemented} -#' \item{\code{model_to_model}}{Not yet implemented} -#' } -#' #' #' @param con database connection #' @param observation_one a vector of plant fucntional types, or species @@ -34,16 +27,17 @@ #' \item{\code{$aligned$aligned_by_observation_one}}{Where possible, will return a vector of observation_one pft's/species in the order of observation_two} #' \item{\code{species}}{{Where possible, will return a vector of observation_two's pft's/species in the order of observation_one}} #' \item{\code{$bety_species_id}}{Where possible, will return the bety_species_id's for one or both observations} +#' \item{\code{$bety_species_intersection}}{Where possible, will return the intersection of two aligned lists of species. subset_is_ok must be set to TRUE.} #' } #' @author Tempest McCabe #' @examples #' #' observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") #' observation_two<-c("a", "b", "a", "a") +#' #' table<-list() #' table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") #' table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings -#' table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species #' table<-as.data.frame(table) #' #' format_one<-"species_USDA_symbol" @@ -53,46 +47,38 @@ #' format_one = format_one, format_two = format_two, custom_table = table) #' @export -align_data_to_data_pft<-function(observation_one, observation_two, custom_table=NULL, format_one, format_two, subset_are_ok=FALSE){ - +align_data_to_data_pft<-function(observation_one, observation_two, custom_table=NULL, format_one, format_two, subset_is_ok=FALSE){ - ### Note: Right now, all the PFT's in bety are assosiated with a model. There is no way to assosiate PFT's with data inputs. - # It seems like down the line we might want to invest in a way to assosiate pft's with input records. Then we could use match_pft for data - # Until then, this function will be written to just take custom mapping tables. + translation_table<-NULL + bety_codes_one<-NA + bety_codes_two<-NA + bety_species_intersection<-NA if(check_if_species_list(format_one) && check_if_species_list(format_two)){ #Both are lists of species - - translation_table<-NULL - if (get_species_list_standard(format_one)=="custom"|get_species_list_standard(format_two)=="custom"){tanslation_table<-custom_table} + + if (get_species_list_standard(format_one) == "custom" | get_species_list_standard(format_two) == "custom"){tanslation_table<-custom_table} bety_codes_one<-PEcAn.data.land::match_species_id(input_codes=observation_one, format_name= get_species_list_standard(format_one),translation_table = translation_table, bety=con) bety_codes_two<-PEcAn.data.land::match_species_id(input_codes=observation_two, format_name= get_species_list_standard(format_two), translation_table = translation_table,bety=con) - #check if ideantical lists. - if(setequal(bety_codes_one, bety_codes_two)){ + if(setequal(bety_codes_one, bety_codes_two)){ #check if identical lists. - aligned_species_list<-list() - aligned_species_list$bety_species_id_one<-bety_codes_one - aligned_species_list$original_standard_id_one<-observation_one - aligned_species_list$bety_species_id_one<-bety_codes_two - aligned_species_list$original_standard_id_one<-observation_two + aligned_by_one<-bety_codes_two #Since they are identical, this has the same names as one, but in the order of two + aligned_by_two<-bety_codes_one - aligned_species_list$final<-bety_codes_one# Allows all code to referece same column name + }else if(subset_is_ok){ - return(aligned_species_list)# If order of species matter this could cause errors - }else if(subsets_are_ok) { - bety_codes_intersect<-intersect(bety_codes_one, bety_codes_two) + #for the case where intersections are ok, making columns where a species is present in on list but not the other NA's + + bety_species_intersection<-dplyr::intersect(bety_codes_one$bety_species_id,bety_codes_two$bety_species_id) + + bety_codes_one$bety_species_id[bety_codes_one$bety_species!=bety_species_intersection]<-NA + bety_codes_two$bety_species_id[bety_codes_two$bety_species!=bety_species_intersection]<-NA - aligned_species_list<-list() - aligned_species_list$bety_species_id_one<-bety_codes_one - aligned_species_list$original_standard_id_one<-observation_one - aligned_species_list$bety_species_id_one<-bety_codes_two - aligned_species_list$original_standard_id_one<-observation_two - aligne_speces_list$bety_species_id_intersection<-bety_codes_intersect + aligned_by_one<-bety_codes_two$bety_species_id + aligned_by_two<-bety_codes_one$bety_species_id - aligned_species_list$final<-bety_codes_intersect - return(aligned_species_list) #Returns the intersection of the speceies lists }else{ PEcAn.logger::logger.warn("These observations cannot be aligned, as they have different species lists. Returning NULL. Check species lists, or set 'subset_are_ok' to TRUE. ") return(NULL) @@ -100,35 +86,26 @@ align_data_to_data_pft<-function(observation_one, observation_two, custom_table= }else if(check_if_species_list(format_one) && !check_if_species_list(format_two)){ - if(is.null(custom_table)){logger.severe("Please provide custom_table")}else if (!is.null(custom_table)) - { + if(is.null(custom_table)){ + + PEcAn.logger::logger.severe("Please provide custom_table") + + }else if (!is.null(custom_table)){ + if(check_if_legal_table(custom_table, observation_one, observation_two)){ - translation_table<-NULL if (get_species_list_standard(format_one)=="custom"){tanslation_table<-custom_table} bety_codes_one<-PEcAn.data.land::match_species_id(input_codes=observation_one, format_name= get_species_list_standard(format_one),translation_table = translation_table, bety=con) - aligned_by_one<-align_by_observation_one(observation_one,observation_two, custom_table) - aligned_by_two<-align_by_observation_two(observation_one,observation_two, custom_table) - - aligned_species_list<-list() - aligned_species_list$bety_species_id$observation_one<-bety_codes_one - aligned_species_list$bety_species_id$observation_two<-NA - aligned_species_list$original$observation_one<-observation_one - aligned_species_list$original$observation_two<-observation_two - aligned_species_list$aligned$aligned_by_observation_one<-aligned_by_one - aligned_species_list$aligned$aligned_by_observation_two<-aligned_by_two - - return(aligned_species_list) + aligned_by_one<-align_by_first_observation(observation_one,observation_two, custom_table) + aligned_by_one<-align_by_first_observation(observation_two,observation_one, custom_table) }else{ - logger.severe("custom_table provided does not correctly map plant_function_type_one to plant_functional_type_two. One or more rows are mapped to multiple plant funcitonal types.") + PEcAn.logger::logger.severe("custom_table provided does not correctly map plant_function_type_one to plant_functional_type_two. One or more rows are mapped to multiple plant funcitonal types.") } } - - }else if(!check_if_species_list(format_one) && check_if_species_list(format_two)){ @@ -136,61 +113,48 @@ align_data_to_data_pft<-function(observation_one, observation_two, custom_table= { if(check_if_legal_table(custom_table, observation_one, observation_two)){ - translation_table<-NULL - if (get_species_list_standard(format_two)=="custom"){tanslation_table<-custom_table} - - bety_codes_two<-PEcAn.data.land::match_species_id(input_codes=observation_two, format_name= get_species_list_standard(format_two),translation_table = translation_table, bety=con) - - aligned_by_one<-align_by_observation_one(observation_one,observation_two, custom_table) - aligned_by_two<-align_by_observation_two(observation_one,observation_two, custom_table) - - aligned_species_list<-list() - aligned_species_list$bety_species_id$observation_one<-bety_codes_one - aligned_species_list$bety_species_id$observation_two<-NA - aligned_species_list$original$observation_one<-observation_one - aligned_species_list$original$observation_two<-observation_two - aligned_species_list$aligned$aligned_by_observation_one<-aligned_by_one - aligned_species_list$aligned$aligned_by_observation_two<-aligned_by_two - - return(aligned_species_list) + if (get_species_list_standard(format_two)=="custom"){ + tanslation_table<-custom_table + } + + bety_codes_two<-PEcAn.data.land::match_species_id(input_codes=observation_two, format_name= get_species_list_standard(format_two),translation_table = translation_table,bety=con) + aligned_by_one<-align_by_first_observation(observation_one,observation_two, custom_table) + aligned_by_two<-align_by_first_observation(observation_two,observation_one, custom_table) }else{ - logger.severe("custom_table provided does not correctly map plant_function_type_one to plant_functional_type_two. One or more rows are mapped to multiple plant funcitonal types.") + PEcAn.logger::logger.severe("custom_table provided does not correctly map plant_function_type_one to plant_functional_type_two. One or more rows are mapped to multiple plant funcitonal types.") } } return(aligned_species_list) }else if(check_if_list_of_pfts(format_one) && (check_if_list_of_pfts(format_two))){ - - if(is.null(custom_table)){logger.severe("Please provide custom_table")}else if (!is.null(custom_table)) { if(check_if_legal_table(custom_table, observation_one, observation_two)){ - aligned_by_one<-align_by_observation_one(observation_one,observation_two, custom_table) - aligned_by_two<-align_by_observation_two(observation_one,observation_two, custom_table) + aligned_by_one<-align_by_first_observation(observation_one,observation_two, custom_table) + aligned_by_two<-align_by_first_observation(observation_two,observation_one, custom_table) - aligned_species_list<-list() - aligned_species_list$bety_species_id$observation_one<-bety_codes_one - aligned_species_list$bety_species_id$observation_two<-NA - aligned_species_list$original$observation_one<-observation_one - aligned_species_list$original$observation_two<-observation_two - aligned_species_list$aligned$aligned_by_observation_one<-aligned_by_one - aligned_species_list$aligned$aligned_by_observation_two<-aligned_by_two - - - return(aligned_species_list) }else{ logger.severe("custom_table provided does not correctly map plant_function_type_one to plant_functional_type_two. One or more rows are mapped to multiple plant funcitonal types.") } } }else{ - logger.severe("PFTs are not in the correct format. Observations must have variables compatible with check_if_species_list(), or use the 'plant_funtional_type' variable") + PEcAn.logger::logger.severe("PFTs are not in the correct format. Observations must have variables compatible with check_if_species_list(), or use the 'plant_funtional_type' variable") } + aligned_species_list<-list() + aligned_species_list$bety_species_id$observation_one<-bety_codes_one + aligned_species_list$bety_species_id$observation_two<-bety_codes_two + aligned_species_list$original$observation_one<-observation_one + aligned_species_list$original$observation_two<-observation_two + aligned_species_list$aligned$aligned_by_observation_one<-aligned_by_one + aligned_species_list$aligned$aligned_by_observation_two<-aligned_by_two + + return(aligned_species_list) } \ No newline at end of file diff --git a/modules/benchmark/R/align_pft.R b/modules/benchmark/R/align_pft.R index c2e9e23692a..4cb50603081 100644 --- a/modules/benchmark/R/align_pft.R +++ b/modules/benchmark/R/align_pft.R @@ -1,5 +1,5 @@ ################################################################# -#'@title{align_pft} +#'align_pft #'@details #' Aligns vectors of Plant Fucntional Typed and species. #' Can align: @@ -38,32 +38,43 @@ #' @author Tempest McCabe #' @examples #' +#' +#' #------------ A species to PFT alignment ----------- #' observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") -#' observation_two<-c("a", "b", "a", "a") +#' observation_two<-c("a", "b", "a", "a") # +#' +#' format_one<-"species_USDA_symbol" +#' format_two<-"plant_funtional_type" +#' #' table<-list() #' table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") #' table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings -#' table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species #' table<-as.data.frame(table) #' -#' format_one<-"species_USDA_symbol" -#' format_two<-"plant_funtional_type" #' #' aligned<-align_pft(con = con, observation_one = observation_one, observation_two = observation_two, #' format_one = format_one, format_two = format_two, custom_table = table) +#' +#' #' @export align_pft<-function(con, observation_one, observation_two, custom_table=NULL, format_one, format_two, subset_are_ok=FALSE, comparison_type="data_to_data", ...){ - if(comparison_type=="data_to_model"){ + if(comparison_type == "data_to_model"){ + #align_data_to_model_pft(settings_one, observations_1) - PEcAn.logger::logger.warn("data_to_model alignment not yet implemented. Returning NULL.") - return(NULL) - }else if (comparison_type=="data_to_data"){ + PEcAn.logger::logger.severe("data_to_model alignment not yet implemented. Returning NULL.") + + + }else if (comparison_type == "data_to_data"){ + align_data_to_data_pft(observation_one, observation_two, custom_table=NULL, format_one, format_two, subset_are_ok=FALSE) + }else if (comparison_type == "model_to_model"){ + #align_model_to_model_pft(settings_one, settings_two) - PEcAn.logger::logger.warn("model_to_model alignment not yet implemented. Returning NULL.") - return(NULL) + PEcAn.logger::logger.severe("model_to_model alignment not yet implemented. Returning NULL.") + + }else{ PEcAn.logger::logger.severe("comparison_type must be set to either 'data_to_model', 'data_to_data', or model_to_model") } diff --git a/modules/benchmark/R/check_if_legal_table.R b/modules/benchmark/R/check_if_legal_table.R index d2805d5f7fd..872a9ffc0ce 100644 --- a/modules/benchmark/R/check_if_legal_table.R +++ b/modules/benchmark/R/check_if_legal_table.R @@ -1,4 +1,4 @@ -#' @title check_if_legal_table +#' check_if_legal_table #' @details #' Checks if custom_table: #' 1. is formated correctly diff --git a/modules/benchmark/R/check_if_list_of_pfts.R b/modules/benchmark/R/check_if_list_of_pfts.R index b78179fa235..a55a3715b91 100644 --- a/modules/benchmark/R/check_if_list_of_pfts.R +++ b/modules/benchmark/R/check_if_list_of_pfts.R @@ -1,5 +1,5 @@ -#' @title check_if_list_of_pfts -#' Checks if format contains a variable named "plant_functional_type" +#' check_if_list_of_pfts +#' @details Checks if format contains a variable named "plant_functional_type" #' @param observation_one a vector of plant fucntional types, or species #' @param observation_two anouther vector of plant fucntional types, or species #' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. diff --git a/modules/benchmark/R/get_species_list_standard.R b/modules/benchmark/R/get_species_list_standard.R index bc2da20da0b..a125737b7a1 100644 --- a/modules/benchmark/R/get_species_list_standard.R +++ b/modules/benchmark/R/get_species_list_standard.R @@ -1,12 +1,9 @@ -#'@title get_species_list_standard -#' Checks if custom_table: -#' 1. is formated correctly -#' 2. is complete (has all of the species/pft's in both observations) -#' 3. is condense-able (Could be represented as a hierachry) -#' +#' get_species_list_standard +#' @details +#' returns the format type for convience of use with match_species_id #' @param observation_one a vector of plant fucntional types, or species #' @param observation_two anouther vector of plant fucntional types, or species -#' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +#' @param custom_table a table that either maps two pft's to one another or maps custom species codes to bety id codes. #' In the second case, must be passable to match_species_id. #' @return \code{character} Returns "usda", "latin_name", "fia" or "custom" #' @author Tempest McCabe diff --git a/modules/benchmark/man/align_by_observation_one.Rd b/modules/benchmark/man/align_by_first_observation.Rd similarity index 64% rename from modules/benchmark/man/align_by_observation_one.Rd rename to modules/benchmark/man/align_by_first_observation.Rd index 1e0186747cd..dfad443880d 100644 --- a/modules/benchmark/man/align_by_observation_one.Rd +++ b/modules/benchmark/man/align_by_first_observation.Rd @@ -1,15 +1,15 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/align_by_obeservation_one.R -\name{align_by_observation_one} -\alias{align_by_observation_one} -\title{align_by_observation_one} +% Please edit documentation in R/align_by_first_observation.R +\name{align_by_first_observation} +\alias{align_by_first_observation} +\title{align_first_observation} \usage{ -align_by_observation_one(observation_one, observation_two, custom_table) +align_by_first_observation(observation_one, observation_two, custom_table) } \arguments{ -\item{observation_one}{a vector of plant fucntional types, or species} +\item{observation_one}{a vector of plant fucntional types, or species. Provides species/pft names.} -\item{observation_two}{anouther vector of plant fucntional types, or species} +\item{observation_two}{another vector of plant fucntional types, or species. Provides the order.} \item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. In the second case, must be passable to match_species_id.} @@ -21,12 +21,8 @@ observation_two<-c("a", "b", "a", "a") table<-list() table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings -table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species table<-as.data.frame(table) -format_one<-"species_USDA_symbol" -format_two<-"plant_funtional_type" - aligned<-align_by_observation_one(observation_one = observation_one, observation_two = observation_two, custom_table = table) # aligned should be a vector '[1] "AMCA3" "ARHY" "AMCA3" "AMCA3"' diff --git a/modules/benchmark/man/align_by_observation_two.Rd b/modules/benchmark/man/align_by_observation_two.Rd deleted file mode 100644 index 61134b7a304..00000000000 --- a/modules/benchmark/man/align_by_observation_two.Rd +++ /dev/null @@ -1,36 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/align_by_obeservation_two.R -\name{align_by_observation_two} -\alias{align_by_observation_two} -\title{align_by_observation_two} -\usage{ -align_by_observation_two(observation_one, observation_two, custom_table) -} -\arguments{ -\item{observation_one}{a vector of plant fucntional types, or species} - -\item{observation_two}{anouther vector of plant fucntional types, or species} - -\item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. -In the second case, must be passable to match_species_id.} -} -\examples{ - -observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") -observation_two<-c("a", "b", "a", "a") -table<-list() -table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") -table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings -table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species -table<-as.data.frame(table) - -format_one<-"species_USDA_symbol" -format_two<-"plant_funtional_type" - -aligned<-align_by_observation_one(observation_one = observation_one, observation_two = observation_two, -custom_table = table) -# aligned should be a vector '[1] "a" "a" "a" "a"' -} -\author{ -Tempest McCabe -} diff --git a/modules/benchmark/man/align_data_to_data_pft.Rd b/modules/benchmark/man/align_data_to_data_pft.Rd index 4c5f2c1905d..5c2404b5b7e 100644 --- a/modules/benchmark/man/align_data_to_data_pft.Rd +++ b/modules/benchmark/man/align_data_to_data_pft.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/align_data_to_data_pft.R \name{align_data_to_data_pft} \alias{align_data_to_data_pft} -\title{{align_data_to_data_pft}} +\title{align_data_to_data_pft} \usage{ align_data_to_data_pft(observation_one, observation_two, custom_table = NULL, format_one, format_two, subset_are_ok = FALSE) @@ -33,6 +33,9 @@ set to FALSE by default.} \item{\code{$bety_species_id}}{Where possible, will return the bety_species_id's for one or both observations} } } +\description{ +align_data_to_data_pft +} \details{ Aligns vectors of Plant Fucntional Typed and species. Can align: diff --git a/modules/benchmark/man/align_pft.Rd b/modules/benchmark/man/align_pft.Rd index 807a3a6bdd0..de3548bef07 100644 --- a/modules/benchmark/man/align_pft.Rd +++ b/modules/benchmark/man/align_pft.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/align_pft.R \name{align_pft} \alias{align_pft} -\title{{align_pft}} +\title{align_pft} \usage{ align_pft(con, observation_one, observation_two, custom_table = NULL, format_one, format_two, subset_are_ok = FALSE, @@ -34,6 +34,9 @@ set to FALSE by default.} \item{\code{$bety_species_id}}{Where possible, will return the bety_species_id's for one or both observations} } } +\description{ +align_pft +} \details{ Aligns vectors of Plant Fucntional Typed and species. Can align: @@ -54,16 +57,20 @@ Can align: } \examples{ + +#------------ A species to PFT alignment ----------- observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") -observation_two<-c("a", "b", "a", "a") +observation_two<-c("a", "b", "a", "a") # + +format_one<-"species_USDA_symbol" +format_two<-"plant_funtional_type" + table<-list() table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species table<-as.data.frame(table) -format_one<-"species_USDA_symbol" -format_two<-"plant_funtional_type" aligned<-align_pft(con = con, observation_one = observation_one, observation_two = observation_two, format_one = format_one, format_two = format_two, custom_table = table) diff --git a/modules/benchmark/man/check_if_legal_table.Rd b/modules/benchmark/man/check_if_legal_table.Rd index 751f16252a4..c3ad4693e75 100644 --- a/modules/benchmark/man/check_if_legal_table.Rd +++ b/modules/benchmark/man/check_if_legal_table.Rd @@ -17,6 +17,9 @@ In the second case, must be passable to match_species_id.} \value{ \code{boolean} } +\description{ +check_if_legal_table +} \details{ Checks if custom_table: 1. is formated correctly diff --git a/modules/benchmark/man/check_if_list_of_pfts.Rd b/modules/benchmark/man/check_if_list_of_pfts.Rd index 35cc8b32415..ed2fa46c778 100644 --- a/modules/benchmark/man/check_if_list_of_pfts.Rd +++ b/modules/benchmark/man/check_if_list_of_pfts.Rd @@ -2,8 +2,7 @@ % Please edit documentation in R/check_if_list_of_pfts.R \name{check_if_list_of_pfts} \alias{check_if_list_of_pfts} -\title{check_if_list_of_pfts -Checks if format contains a variable named "plant_functional_type"} +\title{check_if_list_of_pfts} \usage{ check_if_list_of_pfts(vars) } @@ -18,6 +17,12 @@ In the second case, must be passable to match_species_id.} \value{ \code{boolean} } +\description{ +check_if_list_of_pfts +} +\details{ +Checks if format contains a variable named "plant_functional_type" +} \author{ Tempest McCabe } diff --git a/modules/benchmark/man/get_species_list_standard.Rd b/modules/benchmark/man/get_species_list_standard.Rd index 444e1ab4523..921c18a77fc 100644 --- a/modules/benchmark/man/get_species_list_standard.Rd +++ b/modules/benchmark/man/get_species_list_standard.Rd @@ -2,11 +2,7 @@ % Please edit documentation in R/get_species_list_standard.R \name{get_species_list_standard} \alias{get_species_list_standard} -\title{get_species_list_standard -Checks if custom_table: -1. is formated correctly -2. is complete (has all of the species/pft's in both observations) -3. is condense-able (Could be represented as a hierachry)} +\title{get_species_list_standard} \usage{ get_species_list_standard(vars) } @@ -15,12 +11,18 @@ get_species_list_standard(vars) \item{observation_two}{anouther vector of plant fucntional types, or species} -\item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +\item{custom_table}{a table that either maps two pft's to one another or maps custom species codes to bety id codes. In the second case, must be passable to match_species_id.} } \value{ \code{character} Returns "usda", "latin_name", "fia" or "custom" } +\description{ +get_species_list_standard +} +\details{ +returns the format type for convience of use with match_species_id +} \author{ Tempest McCabe } From 32bfc9d3362e1fb31325dfa3a4748b8064c21b8c Mon Sep 17 00:00:00 2001 From: mccabete Date: Fri, 15 Sep 2017 16:29:53 -0400 Subject: [PATCH 661/771] updating package documentation --- .../man/align_by_first_observation.Rd | 7 ++++++- .../benchmark/man/align_data_to_data_pft.Rd | 18 ++++++------------ modules/benchmark/man/align_pft.Rd | 3 ++- 3 files changed, 14 insertions(+), 14 deletions(-) diff --git a/modules/benchmark/man/align_by_first_observation.Rd b/modules/benchmark/man/align_by_first_observation.Rd index dfad443880d..270f975b59c 100644 --- a/modules/benchmark/man/align_by_first_observation.Rd +++ b/modules/benchmark/man/align_by_first_observation.Rd @@ -11,13 +11,17 @@ align_by_first_observation(observation_one, observation_two, custom_table) \item{observation_two}{another vector of plant fucntional types, or species. Provides the order.} -\item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. +\item{custom_table}{a table that either maps two pft's to one another or maps custom species codes to bety id codes. In the second case, must be passable to match_species_id.} } +\description{ +align_first_observation +} \examples{ observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") observation_two<-c("a", "b", "a", "a") + table<-list() table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings @@ -25,6 +29,7 @@ table<-as.data.frame(table) aligned<-align_by_observation_one(observation_one = observation_one, observation_two = observation_two, custom_table = table) + # aligned should be a vector '[1] "AMCA3" "ARHY" "AMCA3" "AMCA3"' } \author{ diff --git a/modules/benchmark/man/align_data_to_data_pft.Rd b/modules/benchmark/man/align_data_to_data_pft.Rd index 5c2404b5b7e..6d3867cf5ef 100644 --- a/modules/benchmark/man/align_data_to_data_pft.Rd +++ b/modules/benchmark/man/align_data_to_data_pft.Rd @@ -5,7 +5,7 @@ \title{align_data_to_data_pft} \usage{ align_data_to_data_pft(observation_one, observation_two, custom_table = NULL, - format_one, format_two, subset_are_ok = FALSE) + format_one, format_two, subset_is_ok = FALSE) } \arguments{ \item{observation_one}{a vector of plant fucntional types, or species} @@ -19,10 +19,10 @@ In the second case, must be passable to match_species_id.} \item{format_two}{The output of query.format.vars() of observation two of the form output$vars$bety_names} +\item{con}{database connection} + \item{subset_are_ok}{When aligning two species lists, this allows for alignement when species lists aren't identical. set to FALSE by default.} - -\item{con}{database connection} } \value{ \code{list} containing the following columns: @@ -31,6 +31,7 @@ set to FALSE by default.} \item{\code{$aligned$aligned_by_observation_one}}{Where possible, will return a vector of observation_one pft's/species in the order of observation_two} \item{\code{species}}{{Where possible, will return a vector of observation_two's pft's/species in the order of observation_one}} \item{\code{$bety_species_id}}{Where possible, will return the bety_species_id's for one or both observations} + \item{\code{$bety_species_intersection}}{Where possible, will return the intersection of two aligned lists of species. subset_is_ok must be set to TRUE.} } } \description{ @@ -45,23 +46,16 @@ Can align: Will return a list of what was originally provided, bety_speceis_codes if possible, and an aligned output. Becuase some alignement is order-sensitive, alignment based on observation_one - and observation_two are both provided. - -\code{comparison_type} can be one of the following: -\describe{ - \item{\code{data_to_data}}{Will align lists of pfts and species. Must be assosiated with inputs.} - \item{\code{data_to_model}}{Not yet implemented} - \item{\code{model_to_model}}{Not yet implemented} - } + and observation_two are both provided. } \examples{ observation_one<-c("AMCA3","AMCA3","AMCA3","AMCA3") observation_two<-c("a", "b", "a", "a") + table<-list() table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings -table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species table<-as.data.frame(table) format_one<-"species_USDA_symbol" diff --git a/modules/benchmark/man/align_pft.Rd b/modules/benchmark/man/align_pft.Rd index de3548bef07..5f0a7ba897f 100644 --- a/modules/benchmark/man/align_pft.Rd +++ b/modules/benchmark/man/align_pft.Rd @@ -68,12 +68,13 @@ format_two<-"plant_funtional_type" table<-list() table$plant_functional_type_one<- c("AMCA3","AMCA3","ARHY", "ARHY") table$plant_functional_type_two<- c('a','a','b', 'b') # PFT groupings -table$input_code<-c("AMCA3","AMCA3","ARHY", "ARHY") # Species table<-as.data.frame(table) aligned<-align_pft(con = con, observation_one = observation_one, observation_two = observation_two, format_one = format_one, format_two = format_two, custom_table = table) + + } \author{ Tempest McCabe From 59fe77b4e57c655a5a9904fa7d719377bd28f5bb Mon Sep 17 00:00:00 2001 From: Tess McCabe Date: Fri, 15 Sep 2017 16:34:24 -0400 Subject: [PATCH 662/771] Update align_data_to_data_pft.R --- modules/benchmark/R/align_data_to_data_pft.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/benchmark/R/align_data_to_data_pft.R b/modules/benchmark/R/align_data_to_data_pft.R index 8c77515d639..fccb221e23d 100644 --- a/modules/benchmark/R/align_data_to_data_pft.R +++ b/modules/benchmark/R/align_data_to_data_pft.R @@ -8,13 +8,13 @@ #' - a list of species in a custom format, with a table mapping it to bety_species_id's #' #' Will return a list of what was originally provided, bety_speceis_codes if possible, -#' and an aligned output. Becuase some alignement is order-sensitive, alignment based on observation_one +#' and an aligned output. Because some alignement is order-sensitive, alignment based on observation_one #' and observation_two are both provided. #' #' #' @param con database connection #' @param observation_one a vector of plant fucntional types, or species -#' @param observation_two anouther vector of plant fucntional types, or species +#' @param observation_two another vector of plant fucntional types, or species #' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. #' In the second case, must be passable to match_species_id. #' @param format_one The output of query.format.vars() of observation one of the form output$vars$bety_names @@ -157,4 +157,4 @@ align_data_to_data_pft<-function(observation_one, observation_two, custom_table= return(aligned_species_list) -} \ No newline at end of file +} From bd86d0c5ef4efcde1a62595a87a4fd20c2f17eba Mon Sep 17 00:00:00 2001 From: Tess McCabe Date: Fri, 15 Sep 2017 16:35:05 -0400 Subject: [PATCH 663/771] Update align_data_to_data_pft.R --- modules/benchmark/R/align_data_to_data_pft.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/benchmark/R/align_data_to_data_pft.R b/modules/benchmark/R/align_data_to_data_pft.R index fccb221e23d..d014d3b4963 100644 --- a/modules/benchmark/R/align_data_to_data_pft.R +++ b/modules/benchmark/R/align_data_to_data_pft.R @@ -7,7 +7,7 @@ #' - a list of species (usda, fia, or latin_name format) to a plant fucntional type #' - a list of species in a custom format, with a table mapping it to bety_species_id's #' -#' Will return a list of what was originally provided, bety_speceis_codes if possible, +#' Will return a list of what was originally provided, bety_species_codes if possible, #' and an aligned output. Because some alignement is order-sensitive, alignment based on observation_one #' and observation_two are both provided. #' From 80bbc08e3a11d6c57b5e9d9a67c5e8ace9a19b18 Mon Sep 17 00:00:00 2001 From: Tess McCabe Date: Fri, 15 Sep 2017 16:36:00 -0400 Subject: [PATCH 664/771] Update check_if_legal_table.R --- modules/benchmark/R/check_if_legal_table.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/modules/benchmark/R/check_if_legal_table.R b/modules/benchmark/R/check_if_legal_table.R index 872a9ffc0ce..cf896f0abb8 100644 --- a/modules/benchmark/R/check_if_legal_table.R +++ b/modules/benchmark/R/check_if_legal_table.R @@ -5,8 +5,8 @@ #' 2. is complete (has all of the species/pft's in both observations) #' 3. is condense-able (Could be represented as a hierachry) #' -#' @param observation_one a vector of plant fucntional types, or species -#' @param observation_two anouther vector of plant fucntional types, or species +#' @param observation_one a vector of plant functional types, or species +#' @param observation_two anouther vector of plant functional types, or species #' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. #' In the second case, must be passable to match_species_id. #' @return \code{boolean} @@ -15,7 +15,7 @@ check_if_legal_table<-function(table, observation_one, observation_two){ all_there<-TRUE names<-names(table) if(!"plant_functional_type_one" %in% names|!"plant_functional_type_two" %in% names ){ - logger.severe("Custom table provided does not use correct column names. Requires both 'plant_fucntional_type_one', and 'plant_fucntional_type_two'. + logger.severe("Custom table provided does not use correct column names. Requires both 'plant_functional_type_one', and 'plant_functional_type_two'. Column names are currently", names(table)) }else{ missing<-list() @@ -54,7 +54,7 @@ check_if_legal_table<-function(table, observation_one, observation_two){ return(is_legal_table) } else{ - logger.severe("Not every species or plant_fucntional_type is accounted for in custom_table provided. Please account for", missing, "and make sure that 'plant_fucntional_type_one' is matches to 'observation_one'") + logger.severe("Not every species or plant_functional_type is accounted for in custom_table provided. Please account for", missing, "and make sure that 'plant_fucntional_type_one' is matches to 'observation_one'") } } @@ -63,4 +63,4 @@ check_if_legal_table<-function(table, observation_one, observation_two){ - \ No newline at end of file + From 14d7f9f5eb18567f267515e8773fa3336187cc54 Mon Sep 17 00:00:00 2001 From: Tess McCabe Date: Fri, 15 Sep 2017 16:37:06 -0400 Subject: [PATCH 665/771] Update check_if_species_list.R --- modules/benchmark/R/check_if_species_list.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/benchmark/R/check_if_species_list.R b/modules/benchmark/R/check_if_species_list.R index 8004e101b17..739637ebbc0 100644 --- a/modules/benchmark/R/check_if_species_list.R +++ b/modules/benchmark/R/check_if_species_list.R @@ -2,8 +2,8 @@ #'@details #' Checks if format contains a species list in a known format, or a declared custom format. #' -#' @param observation_one a vector of plant fucntional types, or species -#' @param observation_two anouther vector of plant fucntional types, or species +#' @param observation_one a vector of plant functional types, or species +#' @param observation_two another vector of plant functional types, or species #' @param custom_table a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. #' In the second case, must be passable to match_species_id. #' @return \code{boolean} From 68ea18819662f66f9d6c8c119b5bed7c224a419d Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Fri, 15 Sep 2017 17:44:18 -0400 Subject: [PATCH 666/771] fix examples and add new ones --- .../Adding-an-Input-Converter.Rmd | 113 +++++++++++++++--- .../How-to-insert-new-Input-data.Rmd | 14 ++- book_source/workflow/met_processing.RMD | 28 +++-- 3 files changed, 129 insertions(+), 26 deletions(-) diff --git a/book_source/developers_guide/Adding-an-Input-Converter.Rmd b/book_source/developers_guide/Adding-an-Input-Converter.Rmd index 3e218029979..8e698ca3ae1 100755 --- a/book_source/developers_guide/Adding-an-Input-Converter.Rmd +++ b/book_source/developers_guide/Adding-an-Input-Converter.Rmd @@ -1,16 +1,19 @@ -# How to Add an Input Converter +# Input Conversion + +Three Types of data conversions are discussed below: Meteorological data, Vegetation data, and Soil data. Each section provides instructions on how to convert data from their raw formats into a PEcAn standard format, whether it be from a database or if you have raw data in hand. ## Meterological Data conversion -In general, you will need to write a function to download the raw met data andone to convert it to the PEcAn standard. +### Adding a function to PEcAn to convert a met data source +In general, you will need to write a function to download the raw met data and one to convert it to the PEcAn standard. -Downloading raw data function are named `download..R`. Example functions can be found within the PEcAn directory [`/modules/data.atmosphere/R`](https://github.com/PecanProject/pecan/tree/develop/modules/data.atmosphere/R). +Downloading raw data function are named `download..R`. These functions are stored within the PEcAn directory: [`/modules/data.atmosphere/R`](https://github.com/PecanProject/pecan/tree/develop/modules/data.atmosphere/R). -Conversion function from raw to standard are named `met2CF..R`. Example functions can be found within the PEcAn directory [`/modules/data.atmosphere/R`](https://github.com/PecanProject/pecan/tree/develop/modules/data.atmosphere/R). +Conversion function from raw to standard are named `met2CF..R`. These functions are stored within the PEcAn directory: [`/modules/data.atmosphere/R`](https://github.com/PecanProject/pecan/tree/develop/modules/data.atmosphere/R). Current Meteorological products that are coupled to PEcAn can be found in our [Available Meterological Drivers] page. -Note: You will not need to write a script to convert from PEcAn standard to PEcAn models. Those conversoin scripts are written when a model is added and can be found within each model's PEcAn directory. +Note: Unless you are also adding a new model, you will not need to write a script to convert from PEcAn standard to PEcAn models. Those conversion scripts are written when a model is added and can be found within each model's PEcAn directory. ### Dimensions: @@ -66,13 +69,14 @@ Perhaps you have meteorological data specific to one site, with a unique format 1. write a script or function to convert your files into the netcdf PEcAn standard 2. insert that file as an input record for your site following these [instructions](How to Insert new Input Data) -### Downloading Met data outside of the workflow +### Processing Met data outside of the workflow using PEcAn functions Perhaps you would like to obtain data from one of the sources coupled to PEcAn on its own. To do so you can run PEcAn functions on their own. -Example 1: +#### Example 1: Processing data from a database + +Download Amerifluxlbl from Niwot Ridge for the year 2004: -Downloading Amerifluxlbl from Niwot Ridge for the year 2004: ``` raw.file <-PEcAn.data.atmosphere::download.AmerifluxLBL(sitename = "US-NR1", outfolder = ".", @@ -80,12 +84,21 @@ raw.file <-PEcAn.data.atmosphere::download.AmerifluxLBL(sitename = "US-NR1", end_date = "2004-12-31") ``` -If you wanted to convert it to PEcAn Standard you would subsequently execute the following: +Using the information returned as the object `raw.file` you will then convert the raw files into a standard file. + +Open a connection with BETY. You may need to change the host name depending on what mahcine you are hosting BETY. You can find the hostname listed in the machines table of BETY. + ``` -bety = list(user='bety', password='bety',host='localhost', dbname='bety', driver='PostgreSQL',write=TRUE) -con <- PEcAn.DB::db.open(bety) -bety$con <- con +bety <- dplyr::src_postgres(dbname = 'bety', + host ='localhost', + user = "bety", + password = "bety") + +bety$con <- con +``` +Next you will set up the arguments for the function +``` in.path <- '.' in.prefix <- raw.file$dbfile.name outfolder <- '.' @@ -94,17 +107,85 @@ format <- PEcAn.DB::query.format.vars(format.id=format.id,bety = bety) lon <- 105.54 lat <- 40.03 format$time_zone <- "America/Chicago" +``` +Note: The format.id can be pulled from the BETY database if you know the format of the raw data. Once + + +``` PEcAn.data.atmosphere::met2CF.csv(in.path = in.path, in.prefix ="US-NR1_CF", outfolder = ".", start_date ="2004-01-01", end_date = "2004-01-01", + lat= lat, + lon = lon, format = format) ``` Note: The format.id is specific to the format type of the raw data. You can look up the format id in the Bety database. +Example 2: Processing data from data already in hand + +If you have Met data already in hand and you would like to convert into the PEcAn standard follow these instructions. + +Use met2CF.csv to + + +``` +``` + +## Vegetation Data + +Vegetation data will be required to parameterize your model. In these examples we will go over how to produce a standard initial condition file. + +The main function to process cohort data is the `ic.process.R` function. As of now however, if you require pool data you will run a seperate function, `pool_ic_list2netcdf.R`. + +Example 1: Raw data from a database + +If your data is coming from a datbase (ex.FIA) the section of your pecan.xml will need to look like the following: +``` +paste inputs section here +``` +From here you read in the pecan.xml to obtain a settings object +``` +settings<- + +``` +You can then execute the `ic.process` function to convert data into a standard Rds file: + +``` +ic.process(settings, input, dir, overwrite = FALSE) + +``` + +Example 2: Raw data in hand + +You will first need to update the BETY database with the appropriate records. A file record with location of the raw file, a format record with requisite meta data information about the structure of the file, and then an input record what has the file and format record assiciated with it. Instructions on how to do that can be found here [How to Insert new Input Data]. + +Once that part is complete, you will need that input id in the pecan.xml. Edit your xml to look like this: + +``` +``` +Read in settings + +``` +ic.process(settings, input, dir, overwrite = FALSE) + +``` + + + + +If you have pool vegetation data, you'll need the [`pool_ic_list2netcdf.R`](https://github.com/PecanProject/pecan/blob/develop/modules/data.land/R/pool_ic_list2netcdf.R) function to convert the pool data into PEcAn +standard. + +``` + + +``` + +## Soil Data + +In order to process Soil Data + + -## Cohort and Pool Data - -COMING SOON! - \ No newline at end of file diff --git a/book_source/developers_guide/How-to-insert-new-Input-data.Rmd b/book_source/developers_guide/How-to-insert-new-Input-data.Rmd index 1ccad7b99af..d733cb69c4d 100755 --- a/book_source/developers_guide/How-to-insert-new-Input-data.Rmd +++ b/book_source/developers_guide/How-to-insert-new-Input-data.Rmd @@ -15,7 +15,7 @@ From your BETY interface: + From the menu click RUNS then INPUTS + Click “New Input” + Select the SITE that this data is associated with the input data set - + Other required fields are a unique name for the input, the start and end dates of the data set, and the format of the data. If the data is not in a currently known format you will need to create a NEW FORMAT and possibly a new input converter. Instructions on how to do that can be found here [How to Add an Input Converter] + + Other required fields are a unique name for the input, the start and end dates of the data set, and the format of the data. If the data is not in a currently known format you will need to create a NEW FORMAT and possibly a new input converter. Instructions on how to do add a converter can be found here [Input conversion]. Instructions on how to add a format record can be found below. + Parent ID is an optional variable to indicated that one dataset was derived from another. + Click “Create” * Associate the DBFILE with the INPUT @@ -25,3 +25,15 @@ From your BETY interface: + In the Search window, search for the DBFILE you just created * Once you have found the DBFILE, click on the “+” icon to add the file * Click on “Update” at the bottom when you are done. + + + +## Create a Format Record + +Creating a Format Record allow PEcAn to levereage Meta-data about your data in order to properly handle. It allows you to define what type of file it is by defining it's mimetype (i.e. text, netcdf,rds, etc.), define what information is hel in the header of your file, and how many lines need to be skipped within the file to get to ge to the header. To create a format record + + * Navigate to the Formats table in BETY under the RUNS tab. + * Click "New Format" + * Fill in the appropriate information to define your files format + * Click "Create" + \ No newline at end of file diff --git a/book_source/workflow/met_processing.RMD b/book_source/workflow/met_processing.RMD index d52a548d09d..41cff20665b 100644 --- a/book_source/workflow/met_processing.RMD +++ b/book_source/workflow/met_processing.RMD @@ -1,16 +1,26 @@ ## Meteorological Data The main script that handles Met Processing, is [`met.process`](https://github.com/PecanProject/pecan/blob/develop/modules/data.atmosphere/R/met.process.R). It acts as a wrapper function that calls individual modules to facilitate the processing of meteorological data from it's original form to a pecan standard, and then from that standard to model specific formats. It also handles recording these processes in the BETY database. + 1. Downloading raw data - - Currently supported products - - Example Code - 2. Converting raw data into a CF standard - - Example Code - 3. Downscaling and gapfilling - - Example Code + - [Available Meteorological Drivers] + - Example Code to download [Ameriflux data](https://github.com/PecanProject/pecan/blob/develop/modules/data.atmosphere/R/download.AmerifluxLBL.R) + 2. Converting raw data into a CF standard (if needed) + - Example Code to [convert from raw csv to CF standard](https://github.com/PecanProject/pecan/blob/develop/modules/data.atmosphere/R/met2CF.csv.R) + 3. Downscaling and gapfilling(if needed) + - Example Code to [gapfill](https://github.com/PecanProject/pecan/blob/develop/modules/data.atmosphere/R/metgapfill.R) 4. Coverting to Model Specific format - - Example Code + - Example Code to [convert Standard into Sipnet format](https://github.com/PecanProject/pecan/blob/develop/models/sipnet/R/met2model.SIPNET.R) -## Downloading Raw data - PEcAn Automated downloading of raw meteorological data has simplified the often painful task of \ No newline at end of file +## Downloading Raw data (Description of Process) + + Given the information passed from the pecan.xml met.process will call the `download.raw.met.module` to facilitate the execution of the necessary functions to download raw data. +``` + + AmerifluxLBL + SIPNET + pecan + +``` + \ No newline at end of file From fd3d069ad2f5493bc8e30191c635e03b8e3f053e Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Fri, 15 Sep 2017 17:46:29 -0400 Subject: [PATCH 667/771] add line of instructions --- book_source/developers_guide/Adding-an-Input-Converter.Rmd | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/book_source/developers_guide/Adding-an-Input-Converter.Rmd b/book_source/developers_guide/Adding-an-Input-Converter.Rmd index 8e698ca3ae1..670984be317 100755 --- a/book_source/developers_guide/Adding-an-Input-Converter.Rmd +++ b/book_source/developers_guide/Adding-an-Input-Converter.Rmd @@ -108,20 +108,20 @@ lon <- 105.54 lat <- 40.03 format$time_zone <- "America/Chicago" ``` -Note: The format.id can be pulled from the BETY database if you know the format of the raw data. Once +Note: The format.id can be pulled from the BETY database if you know the format of the raw data. +Once these arguments are defined you can execute the `met2CF.csv` function ``` PEcAn.data.atmosphere::met2CF.csv(in.path = in.path, in.prefix ="US-NR1_CF", outfolder = ".", start_date ="2004-01-01", - end_date = "2004-01-01", + end_date = "2004-12-01", lat= lat, lon = lon, format = format) ``` -Note: The format.id is specific to the format type of the raw data. You can look up the format id in the Bety database. Example 2: Processing data from data already in hand From e77000b3d0fe4fbbd1e41d92dde8fd851bafda46 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Fri, 15 Sep 2017 17:59:51 -0400 Subject: [PATCH 668/771] add more instructions --- .../Adding-an-Input-Converter.Rmd | 48 +++++++++++++++++-- 1 file changed, 44 insertions(+), 4 deletions(-) diff --git a/book_source/developers_guide/Adding-an-Input-Converter.Rmd b/book_source/developers_guide/Adding-an-Input-Converter.Rmd index 670984be317..284a184e70f 100755 --- a/book_source/developers_guide/Adding-an-Input-Converter.Rmd +++ b/book_source/developers_guide/Adding-an-Input-Converter.Rmd @@ -95,7 +95,7 @@ bety <- dplyr::src_postgres(dbname = 'bety', user = "bety", password = "bety") -bety$con <- con +con <- bety$con ``` Next you will set up the arguments for the function ``` @@ -114,7 +114,7 @@ Once these arguments are defined you can execute the `met2CF.csv` function ``` PEcAn.data.atmosphere::met2CF.csv(in.path = in.path, - in.prefix ="US-NR1_CF", + in.prefix =in.prefix outfolder = ".", start_date ="2004-01-01", end_date = "2004-12-01", @@ -123,16 +123,56 @@ PEcAn.data.atmosphere::met2CF.csv(in.path = in.path, format = format) ``` -Example 2: Processing data from data already in hand + + +#### Example 2: Processing data from data already in hand If you have Met data already in hand and you would like to convert into the PEcAn standard follow these instructions. -Use met2CF.csv to +Update BETY with file record, format record and input record according to this page [How to Insert new Input Data] + +If your data is in a csv formate you can use the `met2CF.csv`function to convert your data into a PEcAn standard file. + +Open a connection with BETY. You may need to change the host name depending on what mahcine you are hosting BETY. You can find the hostname listed in the machines table of BETY. + +``` + +bety <- dplyr::src_postgres(dbname = 'bety', + host ='localhost', + user = "bety", + password = "bety") + +con <- bety$con +``` + +Prepare the arguments you need to execute the met2CF.csv function +``` +in.path <- 'path/where/the/raw/file/lives' +in.prefix <- 'prefix_of_the_raw_file' +outfolder <- 'path/to/where/you/want/to/output/thecsv/' +format.id <- formatid of the format your created +format <- PEcAn.DB::query.format.vars(format.id=format.id,bety = bety) +lon <- longitude of your site +lat <- latitude of your site +format$time_zone <- time zone of your site +start_date <- Start date of your data in "y-m-d" +end_date <- End date of your data in "y-m-d" +``` +Next you can execute the function: ``` +PEcAn.data.atmosphere::met2CF.csv(in.path = in.path, + in.prefix =in.prefix, + outfolder = ".", + start_date = start_date, + end_date = end_date, + lat= lat, + lon = lon, + ``` + ## Vegetation Data Vegetation data will be required to parameterize your model. In these examples we will go over how to produce a standard initial condition file. From 0626eec8d655d8088e895eda5cbb90b18b1509d5 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Fri, 15 Sep 2017 18:00:34 -0400 Subject: [PATCH 669/771] add comma --- book_source/developers_guide/Adding-an-Input-Converter.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/book_source/developers_guide/Adding-an-Input-Converter.Rmd b/book_source/developers_guide/Adding-an-Input-Converter.Rmd index 284a184e70f..df6e34646fb 100755 --- a/book_source/developers_guide/Adding-an-Input-Converter.Rmd +++ b/book_source/developers_guide/Adding-an-Input-Converter.Rmd @@ -114,7 +114,7 @@ Once these arguments are defined you can execute the `met2CF.csv` function ``` PEcAn.data.atmosphere::met2CF.csv(in.path = in.path, - in.prefix =in.prefix + in.prefix =in.prefix, outfolder = ".", start_date ="2004-01-01", end_date = "2004-12-01", From 63a876f633975b36a03c4b6278077bf5d23008d6 Mon Sep 17 00:00:00 2001 From: istfer Date: Sat, 16 Sep 2017 11:26:21 -0400 Subject: [PATCH 670/771] bugfix to start_qsub --- base/remote/R/start_qsub.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/base/remote/R/start_qsub.R b/base/remote/R/start_qsub.R index 01a38599086..5dc8a29537a 100644 --- a/base/remote/R/start_qsub.R +++ b/base/remote/R/start_qsub.R @@ -18,8 +18,8 @@ start_qsub <- function(run, qsub_string, rundir, stdout_log, stderr_log, job_script, qsub_extra = NULL) { run_id_string <- format(run, scientific = FALSE) qsub <- gsub("@NAME@", paste0("PEcAn-", run_id_string), qsub_string) - qsub <- gsub("@STDOUT@", file.path(outdir, run_id_string, stdout_log), qsub) - qsub <- gsub("@STDERR@", file.path(outdir, run_id_string, stderr_log), qsub) + qsub <- gsub("@STDOUT@", file.path(host_outdir, run_id_string, stdout_log), qsub) + qsub <- gsub("@STDERR@", file.path(host_outdir, run_id_string, stderr_log), qsub) if (!is.null(qsub_extra)) { qsub <- paste(qsub, qsub_extra) } From 50452e9ee80f8892588b064a0bb5a013893286ce Mon Sep 17 00:00:00 2001 From: mccabete Date: Sat, 16 Sep 2017 13:04:01 -0400 Subject: [PATCH 671/771] Cleaning up with some vectorization as per Alexey's suggestion --- modules/benchmark/R/check_if_legal_table.R | 14 ++++++++++---- modules/benchmark/R/check_if_list_of_pfts.R | 4 +--- modules/benchmark/R/check_if_species_list.R | 8 +------- 3 files changed, 12 insertions(+), 14 deletions(-) diff --git a/modules/benchmark/R/check_if_legal_table.R b/modules/benchmark/R/check_if_legal_table.R index 872a9ffc0ce..bd9227ebc87 100644 --- a/modules/benchmark/R/check_if_legal_table.R +++ b/modules/benchmark/R/check_if_legal_table.R @@ -34,18 +34,24 @@ check_if_legal_table<-function(table, observation_one, observation_two){ aggregated_1<-FALSE aggregated_2<-FALSE - subset<-subset(table, table$plant_functional_type_one==pft_1[i]) + subset<-subset(table, table$plant_functional_type_one == pft_1[i]) length_of_pft_1_uniques_1<-length(as.character(unique(subset$plant_functional_type_one))) length_of_pft_2_uniques_1<-length(as.character(unique(subset$plant_functional_type_two))) - if(length_of_pft_2_uniques_1>1 | length_of_pft_1_uniques_1>1){aggregated_1<- TRUE} + if(length_of_pft_2_uniques_1>1 | length_of_pft_1_uniques_1>1){ + aggregated_1<- TRUE + } for(j in 1:length(unique(subset$plant_functional_type_two))){ - subset_2<-subset(table, table$plant_functional_type_two==as.character(subset$plant_functional_type_two[j])) + + subset_2<-subset(table, table$plant_functional_type_two == as.character(subset$plant_functional_type_two[j])) length_of_pft_1_uniques<-length(as.character(unique(subset_2$plant_functional_type_one))) length_of_pft_2_uniques<-length(as.character(unique(subset_2$plant_functional_type_two))) - if(length_of_pft_2_uniques>1 | length_of_pft_1_uniques>1){aggregated_2<- TRUE} + + if(length_of_pft_2_uniques>1 | length_of_pft_1_uniques>1){ + aggregated_2<- TRUE + } if(aggregated_1 && aggregated_2){is_legal_table<-FALSE } } diff --git a/modules/benchmark/R/check_if_list_of_pfts.R b/modules/benchmark/R/check_if_list_of_pfts.R index a55a3715b91..4a5e4baf93d 100644 --- a/modules/benchmark/R/check_if_list_of_pfts.R +++ b/modules/benchmark/R/check_if_list_of_pfts.R @@ -8,9 +8,7 @@ #' @author Tempest McCabe check_if_list_of_pfts<-function(vars){ - if("plant_functional_type" %in% vars){ - return(TRUE) - }else if("species_name" %in% vars){ + if( any(c("plant_functional_type","species_name")) %in% vars){ return(TRUE) }else{ return(FALSE) diff --git a/modules/benchmark/R/check_if_species_list.R b/modules/benchmark/R/check_if_species_list.R index 8004e101b17..bf77674c36f 100644 --- a/modules/benchmark/R/check_if_species_list.R +++ b/modules/benchmark/R/check_if_species_list.R @@ -10,13 +10,7 @@ #' @author Tempest McCabe check_if_species_list<-function(vars,custom_table=NULL){ - if("species_id" %in% vars){ - return(TRUE) - }else if("species_name" %in% vars){ - return(TRUE) - }else if("species_USDA_symbol" %in% vars){ - return(TRUE) - }else if("species_FIA_symbol" %in% vars){ + if(any(c("species_id", "species_name", "species_USDA_symbol", "species_FIA_symbol")) %in% vars){ return(TRUE) }else if(!is.null(custom_table)){ if("bety_species_id" %in% names(custom_table)){ From 60913f76f0df95f8b2a926b692fbe821ef25b9a0 Mon Sep 17 00:00:00 2001 From: mccabete Date: Sat, 16 Sep 2017 13:10:27 -0400 Subject: [PATCH 672/771] A few more fixes. --- modules/benchmark/R/check_if_legal_table.R | 16 ++++++++++------ modules/benchmark/R/get_species_list_standard.R | 4 ++-- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/modules/benchmark/R/check_if_legal_table.R b/modules/benchmark/R/check_if_legal_table.R index 095f23080c8..405c484104b 100644 --- a/modules/benchmark/R/check_if_legal_table.R +++ b/modules/benchmark/R/check_if_legal_table.R @@ -19,18 +19,22 @@ check_if_legal_table<-function(table, observation_one, observation_two){ Column names are currently", names(table)) }else{ missing<-list() - for(h in 1:length(observation_one)){ - if(!observation_one[h] %in% table$plant_functional_type_one){all_there<-FALSE; missing<-c(missing,observation_one[h])} + for(h in seq_along(observation_one)){ + if(!observation_one[h] %in% table$plant_functional_type_one){ + all_there<-FALSE; missing<-c(missing,observation_one[h]) + } } - for(h in 1:length(observation_two)){ - if(!observation_two[h] %in% table$plant_functional_type_two){all_there<-FALSE; missing<-c(missing,observation_two[h])} + for(h in seq_along(observation_two)){ + if(!observation_two[h] %in% table$plant_functional_type_two){ + all_there<-FALSE; missing<-c(missing,observation_two[h]) + } } if(all_there){ is_legal_table<-TRUE pft_1<-as.character(unique(table$plant_functional_type_one)) pft_2<-as.character(unique(table$plant_functional_type_two)) - for(i in 1:length(pft_1)){ + for(i in seq_along(pft_1)){ aggregated_1<-FALSE aggregated_2<-FALSE @@ -43,7 +47,7 @@ check_if_legal_table<-function(table, observation_one, observation_two){ aggregated_1<- TRUE } - for(j in 1:length(unique(subset$plant_functional_type_two))){ + for(j in seq_along(unique(subset$plant_functional_type_two))){ subset_2<-subset(table, table$plant_functional_type_two == as.character(subset$plant_functional_type_two[j])) length_of_pft_1_uniques<-length(as.character(unique(subset_2$plant_functional_type_one))) diff --git a/modules/benchmark/R/get_species_list_standard.R b/modules/benchmark/R/get_species_list_standard.R index a125737b7a1..5aa7eabbe7b 100644 --- a/modules/benchmark/R/get_species_list_standard.R +++ b/modules/benchmark/R/get_species_list_standard.R @@ -1,6 +1,6 @@ #' get_species_list_standard #' @details -#' returns the format type for convience of use with match_species_id +#' Returns the format type for convience of use with match_species_id #' @param observation_one a vector of plant fucntional types, or species #' @param observation_two anouther vector of plant fucntional types, or species #' @param custom_table a table that either maps two pft's to one another or maps custom species codes to bety id codes. @@ -9,7 +9,7 @@ #' @author Tempest McCabe get_species_list_standard<-function(vars){ - if("species_id" %in% vars){ + if(any(c("species_id")) %in% vars){ return("usda") }else if("species_name" %in% vars){ return('latin_name') From 0417c4383672f227565df87f0212814f1760c3e4 Mon Sep 17 00:00:00 2001 From: mccabete Date: Sat, 16 Sep 2017 13:20:21 -0400 Subject: [PATCH 673/771] one more fix --- modules/benchmark/R/get_species_list_standard.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/modules/benchmark/R/get_species_list_standard.R b/modules/benchmark/R/get_species_list_standard.R index 5aa7eabbe7b..2acb437d8e1 100644 --- a/modules/benchmark/R/get_species_list_standard.R +++ b/modules/benchmark/R/get_species_list_standard.R @@ -9,12 +9,10 @@ #' @author Tempest McCabe get_species_list_standard<-function(vars){ - if(any(c("species_id")) %in% vars){ + if(any(c("species_id", "species_USDA_symbol")) %in% vars){ return("usda") }else if("species_name" %in% vars){ return('latin_name') - }else if("species_USDA_symbol" %in% vars){ - return("usda") }else if("species_FIA_symbol" %in% vars){ return('fia') }else if(!is.null(custom_table)){ From 186081883d952d14249c24495ab776773b76679d Mon Sep 17 00:00:00 2001 From: mccabete Date: Sat, 16 Sep 2017 13:27:11 -0400 Subject: [PATCH 674/771] documentation changes --- modules/benchmark/man/align_data_to_data_pft.Rd | 6 +++--- modules/benchmark/man/check_if_legal_table.Rd | 4 ++-- modules/benchmark/man/check_if_species_list.Rd | 4 ++-- modules/benchmark/man/get_species_list_standard.Rd | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/modules/benchmark/man/align_data_to_data_pft.Rd b/modules/benchmark/man/align_data_to_data_pft.Rd index 6d3867cf5ef..1e86bfe166c 100644 --- a/modules/benchmark/man/align_data_to_data_pft.Rd +++ b/modules/benchmark/man/align_data_to_data_pft.Rd @@ -10,7 +10,7 @@ align_data_to_data_pft(observation_one, observation_two, custom_table = NULL, \arguments{ \item{observation_one}{a vector of plant fucntional types, or species} -\item{observation_two}{anouther vector of plant fucntional types, or species} +\item{observation_two}{another vector of plant fucntional types, or species} \item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. In the second case, must be passable to match_species_id.} @@ -44,8 +44,8 @@ Can align: - a list of species (usda, fia, or latin_name format) to a plant fucntional type - a list of species in a custom format, with a table mapping it to bety_species_id's - Will return a list of what was originally provided, bety_speceis_codes if possible, - and an aligned output. Becuase some alignement is order-sensitive, alignment based on observation_one + Will return a list of what was originally provided, bety_species_codes if possible, + and an aligned output. Because some alignement is order-sensitive, alignment based on observation_one and observation_two are both provided. } \examples{ diff --git a/modules/benchmark/man/check_if_legal_table.Rd b/modules/benchmark/man/check_if_legal_table.Rd index c3ad4693e75..d31609148f6 100644 --- a/modules/benchmark/man/check_if_legal_table.Rd +++ b/modules/benchmark/man/check_if_legal_table.Rd @@ -7,9 +7,9 @@ check_if_legal_table(table, observation_one, observation_two) } \arguments{ -\item{observation_one}{a vector of plant fucntional types, or species} +\item{observation_one}{a vector of plant functional types, or species} -\item{observation_two}{anouther vector of plant fucntional types, or species} +\item{observation_two}{anouther vector of plant functional types, or species} \item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. In the second case, must be passable to match_species_id.} diff --git a/modules/benchmark/man/check_if_species_list.Rd b/modules/benchmark/man/check_if_species_list.Rd index 8b15fc04a55..d1a356170be 100644 --- a/modules/benchmark/man/check_if_species_list.Rd +++ b/modules/benchmark/man/check_if_species_list.Rd @@ -10,9 +10,9 @@ check_if_species_list(vars, custom_table = NULL) \item{custom_table}{a table that either maps two pft's to one anouther or maps custom species codes to bety id codes. In the second case, must be passable to match_species_id.} -\item{observation_one}{a vector of plant fucntional types, or species} +\item{observation_one}{a vector of plant functional types, or species} -\item{observation_two}{anouther vector of plant fucntional types, or species} +\item{observation_two}{another vector of plant functional types, or species} } \value{ \code{boolean} diff --git a/modules/benchmark/man/get_species_list_standard.Rd b/modules/benchmark/man/get_species_list_standard.Rd index 921c18a77fc..944f8492026 100644 --- a/modules/benchmark/man/get_species_list_standard.Rd +++ b/modules/benchmark/man/get_species_list_standard.Rd @@ -21,7 +21,7 @@ In the second case, must be passable to match_species_id.} get_species_list_standard } \details{ -returns the format type for convience of use with match_species_id +Returns the format type for convience of use with match_species_id } \author{ Tempest McCabe From f714be7f448ad75ea96e402db8a9da1fbdb0a3b6 Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Sun, 17 Sep 2017 22:02:53 -0500 Subject: [PATCH 675/771] Removed broken fileInput portion for release... --- shiny/Data-Ingest/app.R | 55 +++++++++++++++++++++++------------------ 1 file changed, 31 insertions(+), 24 deletions(-) diff --git a/shiny/Data-Ingest/app.R b/shiny/Data-Ingest/app.R index 90cf6998fd6..dfe39b2c21e 100644 --- a/shiny/Data-Ingest/app.R +++ b/shiny/Data-Ingest/app.R @@ -1,18 +1,9 @@ -# -# This is a Shiny web application. You can run the application by clicking -# the 'Run App' button above. -# -# Find out more about building applications with Shiny here: -# -# http://shiny.rstudio.com/ -# - library(shiny) library(PEcAn.data.land) +library(PEcAn.utils) library(shinydashboard) library(dataone) -#stopifnot # Define UI for application @@ -41,13 +32,22 @@ ui <- dashboardPage( box( # https://github.com/rstudio/shiny-examples/blob/master/009-upload/app.R fileInput(inputId = "file", label = h3("Upload Local Files"), accept = NULL, multiple = TRUE, placeholder = "Drag and drop files here"), - p("This isn't linked to the server yet") + p("This is a placeholder and is not yet functional"), + tableOutput("contents") ) ) ), tabItem(tabName = "step2", - h2("dbfiles tab content") + h2("under construction") + ), + + tabItem(tabName = "step3", + h2("under construction") + ), + + tabItem(tabName = "step4", + h2("under construction") ) @@ -58,7 +58,7 @@ ui <- dashboardPage( server <- function(input, output) { options(shiny.maxRequestSize=30*1024^2) #maximum file input size - #path <- PEcAn.utils::read_web_config(config.php) + path <- PEcAn.utils::read_web_config("../../web/config.php") d1d <- eventReactive(input$D1Button, { PEcAn.data.land::dataone_download(input$id, filepath = path) }) #run dataone_download with input from id on click @@ -66,22 +66,29 @@ server <- function(input, output) { d1d() }) - # output$debug <- - - # - - output$upload <- renderTable({ - if(is.null(data())){return()} - input$file - }) +###### FileInput <-- Will add this functionality shortly +# output$contents <- renderTable({ + # input$file1 will be NULL initially. After the user selects + # and uploads a file, it will be a data frame with 'name', + # 'size', 'type', and 'datapath' columns. The 'datapath' + # column will contain the local filenames where the data can + # be found. +# inFile <- input$file + +# if (is.null(inFile)) +# return(NULL) +# read.csv(inFile$datapath, header = TRUE) + +# }) + + + #file.copy(inFile$datapath, header = input$header) - -# file.copy copy from tmp file to - + } # Run the application From 10e33fa29f2943e3e5b9a2c12e2a27b422d66b9d Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Thu, 14 Sep 2017 14:01:43 -0500 Subject: [PATCH 676/771] CMIP5 leap year fixes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit A couple changes to improve the speed of the extraction by only extracting what we need and setting it up to automatically add in leap year if it’s missing. This will *hopefully* solve some of the lingering issues in the PalEON met workflow. --- .../data.atmosphere/R/extract_local_CMIP5.R | 103 +++++++++++------- 1 file changed, 64 insertions(+), 39 deletions(-) diff --git a/modules/data.atmosphere/R/extract_local_CMIP5.R b/modules/data.atmosphere/R/extract_local_CMIP5.R index c3c351c2969..046af3f33e7 100644 --- a/modules/data.atmosphere/R/extract_local_CMIP5.R +++ b/modules/data.atmosphere/R/extract_local_CMIP5.R @@ -42,13 +42,13 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i # Days per month dpm <- lubridate::days_in_month(1:12) - + # Date stuff start_date <- as.POSIXlt(start_date, tz = "GMT") end_date <- as.POSIXlt(end_date, tz = "GMT") start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - + lat.in = as.numeric(lat.in) lon.in = as.numeric(lon.in) # dir.nldas="http://hydro1.sci.gsfc.nasa.gov/thredds/dodsC/NLDAS_FORA0125_H.002" @@ -84,7 +84,7 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i library(car) # having trouble gettins stuff to work otherwise if(!("huss" %in% vars.gcm)) var$DAP.name <- car::recode(var$DAP.name, "'huss'='hus'") if(!("ps" %in% vars.gcm )) var$DAP.name <- car::recode(var$DAP.name, "'ps'='psl'") - + # Making sure we're only trying to grab the variables we have (i.e. don't try sfcWind if we don't have it) var <- var[var$DAP.name %in% vars.gcm,] @@ -98,26 +98,29 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i files.var[[v]] <- list() if(v %in% vars.gcm.day){ # Get a list of file names - files.var[[v]][["files"]] <- dir(file.path(in.path, "day", v)) + files.var[[v]] <- data.frame(file.name=dir(file.path(in.path, "day", v)) ) } else { - files.var[[v]][["files"]] <- dir(file.path(in.path, "month", v)) + files.var[[v]] <- data.frame(file.name=dir(file.path(in.path, "month", v))) } - # Set up an index to help us find out which file we'll need - files.var[[v]][["years"]] <- data.frame(first.year=NA, last.year=NA) - for(i in 1:length(files.var[[v]][["files"]])){ - yr.str <- stringr::str_split(stringr::str_split(files.var[[v]][["files"]][[i]], "_")[[1]][6], "-")[[1]] - + # Set up an index to help us find out which file we'll need + # files.var[[v]][["years"]] <- data.frame(first.year=NA, last.year=NA) + for(i in 1:nrow(files.var[[v]])){ + yr.str <- stringr::str_split(stringr::str_split(files.var[[v]][i,"file.name"], "_")[[1]][6], "-")[[1]] + # Don't bother storing this file if we don't want those years - if(as.numeric(substr(yr.str[1], 1, 4)) > end_year | as.numeric(substr(yr.str[2], 1, 4))< start_year) next - files.var[[v]][["years"]][i, "first.year"] <- as.numeric(substr(yr.str[1], 1, 4)) - files.var[[v]][["years"]][i, "last.year" ] <- as.numeric(substr(yr.str[2], 1, 4)) + files.var[[v]][i, "first.year"] <- as.numeric(substr(yr.str[1], 1, 4)) + files.var[[v]][i, "last.year" ] <- as.numeric(substr(yr.str[2], 1, 4)) - n.file=n.file+1 } # End file loop + + # get rid of files outside of what we actually need + files.var[[v]] <- files.var[[v]][files.var[[v]]$first.year<=end_year & files.var[[v]]$last.year>=start_year,] + # if(as.numeric(substr(yr.str[1], 1, 4)) > end_year | as.numeric(substr(yr.str[2], 1, 4))< start_year) next + n.file=n.file+nrow(files.var[[v]]) + } # end variable loop - - + # Querying large netcdf files 1,000 times is slow. So lets open the connection once and # pull the full time series # Loop through using the files using the first variable; shoudl be tair & should be highest res avail @@ -140,10 +143,10 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i # Figure out what file we need # file.ind <- which(files.var[[var.now]][i]) - for(i in 1:length(files.var[[var.now]]$files)){ + for(i in 1:nrow(files.var[[var.now]])){ setTxtProgressBar(pb, pb.ind) pb.ind=pb.ind+1 - f.now <- files.var[[var.now]]$files[i] + f.now <- files.var[[var.now]][i,"file.name"] # print(f.now) # Open up the file @@ -153,10 +156,31 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i lat_bnd <- ncdf4::ncvar_get(ncT, "lat_bnds") lon_bnd <- ncdf4::ncvar_get(ncT, "lon_bnds") nc.time <- ncdf4::ncvar_get(ncT, "time") - + # splt.ind <- ifelse(GCM %in% c("MPI-ESM-P"), 4, 3) # date.origin <- as.Date(str_split(ncT$dim$time$units, " ")[[1]][splt.ind]) - + nc.date <- as.Date(paste0(files.var[[var.now]][i,"first.year"], "-01-01")) + nc.time + date.leaps <- seq(as.Date(paste0(files.var[[var.now]][i,"first.year"], "-01-01")), as.Date(paste0(files.var[[var.now]][i,"last.year"], "-12-31")), by="day") + # If we're missing leap year, lets adjust our date stamps so we can only pull what we need + if(v.res=="day" & length(nc.date)!=length(date.leaps)){ + cells.bump <- which(lubridate::leap_year(lubridate::year(date.leaps)) & lubridate::month(date.leaps)==02 & lubridate::day(date.leaps)==29) + for(j in 1:length(cells.bump)){ + nc.date[cells.bump[j]:length(nc.date)] <- nc.date[cells.bump[j]:length(nc.date)]+1 + } + } + + # Find our time index + if(v.res=="day"){ + time.ind <- which(lubridate::year(nc.date)>=start_year & lubridate::year(nc.date)<=end_year) + } else { + yr.ind <- rep(files.var[[var.now]][i,"first.year"]:files.var[[var.now]][i,"last.year"], each=12) + time.ind <- which(yr.ind>=start_year & yr.ind<=end_year) + } + + # Subset our dates & times to match our index + nc.date <- nc.date[time.ind] + date.leaps <- date.leaps[which(lubridate::year(date.leaps)>=start_year & lubridate::year(date.leaps)<=end_year)] + # Find the closest grid cell for our site (using harvard as a protoype) ind.lat <- which(lat_bnd[1,]<=lat.in & lat_bnd[2,]>=lat.in) if(max(lon.in)>=180){ @@ -169,23 +193,38 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i if(var.now %in% c("hus", "ua", "va")){ # These have multiple strata; we only want 1 plev <- ncdf4::ncvar_get(ncT, "plev") puse <- which(plev==max(plev)) # Get humidity at the place of highest pressure (closest to surface) - dat.temp <- ncdf4::ncvar_get(ncT, var.now, c(ind.lon, ind.lat, puse, 1), c(1,1,1,length(nc.time))) + dat.temp <- ncdf4::ncvar_get(ncT, var.now, c(ind.lon, ind.lat, puse, time.ind[1]), c(1,1,1,length(time.ind))) # If dat.list has missing values, try the next layer puse.orig <- puse while(is.na(mean(dat.temp))){ if(puse.orig==1) { puse = puse + 1 } else { puse = puse -1 } - dat.temp <- ncdf4::ncvar_get(ncT, var.now, c(ind.lon, ind.lat, puse, 1), c(1,1,1,length(nc.time))) + dat.temp <- ncdf4::ncvar_get(ncT, var.now, c(ind.lon, ind.lat, puse, time.ind[1]), c(1,1,1,length(time.ind))) } } else { - dat.temp <- ncdf4::ncvar_get(ncT, var.now, c(ind.lon, ind.lat, 1), c(1,1,length(nc.time))) + dat.temp <- ncdf4::ncvar_get(ncT, var.now, c(ind.lon, ind.lat, time.ind[1]), c(1,1,length(time.ind))) } + # Add leap year and trick monthly into daily + # Figure out if we're missing leap year + if(v.res=="day" & length(nc.date)!=length(date.leaps)){ + cells.dup <- which(lubridate::leap_year(lubridate::year(date.leaps)) & lubridate::month(date.leaps)==02 & lubridate::day(date.leaps)==28) + for(j in 1:length(cells.dup)){ + dat.temp <- append(dat.temp, dat.temp[cells.dup[j]], cells.dup[j]) + } + } + + # If we have monthly data, lets trick it into being daily if(v.res == "month"){ mo.ind <- rep(1:12, length.out=length(dat.temp)) + yr.ind <- rep(files.var[[var.now]][i,"first.year"]:files.var[[var.now]][i,"last.year"], each=12) dat.trick <- vector() for(j in 1:length(dat.temp)){ - dat.trick <- c(dat.trick, rep(dat.temp[j], dpm[mo.ind[j]])) + if(lubridate::leap_year(yr.ind[j]) & mo.ind[j]==2){ + dat.trick <- c(dat.trick, rep(dat.temp[j], dpm[mo.ind[j]]+1)) + } else { + dat.trick <- c(dat.trick, rep(dat.temp[j], dpm[mo.ind[j]])) + } } dat.temp <- dat.trick } # End leap day trick @@ -195,20 +234,6 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i } # End file loop } # End variable loop - # Dealing with leap-year post-hoc because it was becoming a pain in the ass - # If we have daily data and we're dealing with a model that skips leap year, add it in - dpm <- lubridate::days_in_month(1:12) - yrs.leap <- ylist[leap_year(ylist)] - for(y.now in yrs.leap){ - yr.ind <- which(year(dat.time)==y.now) - if(GCM %in% no.leap & v.res == "day"){ - for(v in 1:length(dat.all)){ - dat.all[[v]] <- append(dat.all[[v]], dat.all[[v]][yr.ind[sum(dpm[1:2])]], sum(yr.ind[dpm[1:2]])) - } - } - } - - print("") print("- Writing to NetCDF: ") @@ -285,7 +310,7 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i ncdf4::ncvar_put(nc=loc, varid=as.character(var$CF.name[j]), vals=dat.list[[j]]) } ncdf4::nc_close(loc) - + results$file[i] <- loc.file # results$host[i] <- fqdn() results$startdate[i] <- paste0(as.Date(paste(y.now, day1, sep="-"), format = "%Y-%j"), " 00:00:00") From a61b2f3399c5c3c2a5193051f241e88264ce8ef4 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Thu, 14 Sep 2017 14:11:46 -0500 Subject: [PATCH 677/771] Add NLDAS extraction script Somewhere along the line, this file got lost, but is critical to the paleon workflow, so adding it back in now --- .../data.atmosphere/R/extract_local_NLDAS.R | 190 ++++++++++++++++++ 1 file changed, 190 insertions(+) create mode 100644 modules/data.atmosphere/R/extract_local_NLDAS.R diff --git a/modules/data.atmosphere/R/extract_local_NLDAS.R b/modules/data.atmosphere/R/extract_local_NLDAS.R new file mode 100644 index 00000000000..728f6767ff4 --- /dev/null +++ b/modules/data.atmosphere/R/extract_local_NLDAS.R @@ -0,0 +1,190 @@ +##' Extract NLDAS from local download +##' Extract NLDAS meteorology for a poimt from a local download of the full grid +# ----------------------------------- +# Description +# ----------------------------------- +##' @title extract.local.NLDAS +##' @family +##' @author Christy Rollinson, +##' @description This function extracts NLDAS data from grids that have been downloaded and stored locally. +##' Once upon a time, you could query these files directly from the internet, but now they're +##' behind a tricky authentication wall. Files are saved as a netCDF file in CF conventions. +##' These files are ready to be used in the general PEcAn workflow or fed into the downscalign +##' workflow. +# ----------------------------------- +# Parameters +# ----------------------------------- +##' @param outfolder - directory where output files will be stored +##' @param in.path - path to the raw full grids +##' @param start_date - first day for which you want to extract met (yyyy-mm-dd) +##' @param end_date - last day for which you want to extract met (yyyy-mm-dd) +##' @param site_id name to associate with extracted files +##' @param lat.in site latitude in decimal degrees +##' @param lon.in site longitude in decimal degrees +##' @param overwrite logical. Download a fresh version even if a local file with the same name already exists? +##' @param verbose logical. Passed on to [ncdf4]{ncvar_def}} and [ncdf4]{nc_create} +##' to control printing of debug info +##' @param ... Other arguments, currently ignored +##' @export +# ----------------------------------- +extract.local.NLDAS <- function(outfolder, in.path, start_date, end_date, site_id, lat.in, lon.in, + overwrite = FALSE, verbose = FALSE, ...){ + library(lubridate) + library(ncdf4) + library(stringr) + + # Date stuff + start_date <- as.POSIXlt(start_date, tz = "GMT") + end_date <- as.POSIXlt(end_date, tz = "GMT") + start_year <- year(start_date) + end_year <- year(end_date) + + lat.in = as.numeric(lat.in) + lon.in = as.numeric(lon.in) + # dir.nldas="http://hydro1.sci.gsfc.nasa.gov/thredds/dodsC/NLDAS_FORA0125_H.002" + dir.create(outfolder, showWarnings=FALSE, recursive=TRUE) + + ylist <- seq(start_year,end_year,by=1) + rows = length(ylist) + results <- data.frame(file=character(rows), host=character(rows), + mimetype=character(rows), formatname=character(rows), + startdate=character(rows), enddate=character(rows), + dbfile.name = "NLDAS", + stringsAsFactors = FALSE + ) + + # I fixed the shortwave radiation parsing script, but haven't pushed those changes, so until NLDAS gets re-formatted, just index it differently + var = data.frame(NLDAS.name = c("air_temperature","surface_downwelling_longwave_flux_in_air","air_pressure","downwelling_shortwave_flux_in_air","eastward_wind","northward_wind","specific_humidity","precipitation_amount"), + CF.name = c("air_temperature","surface_downwelling_longwave_flux_in_air","air_pressure","surface_downwelling_shortwave_flux_in_air","eastward_wind","northward_wind","specific_humidity","precipitation_flux"), + units = c('Kelvin',"W/m2","Pascal","W/m2","m/s","m/s","g/g","kg/m2/s") + ) + + # Progress bar because this can be very slow + for (i in 1:rows){ + y.now = ylist[i] + + # figure out how many days we're working with + if(rows>1 & i!=1 & i!=rows){ # If we have multiple years and we're not in the first or last year, we're taking a whole year + nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + day1 = 1 + day2 = nday + days.use = day1:day2 + } else if(rows==1){ + # if we're working with only 1 year, lets only pull what we need to + nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + day1 <- yday(start_date) + # Now we need to check whether we're ending on the right day + day2 <- yday(end_date) + days.use = day1:day2 + nday=length(days.use) # Update nday + } else if(i==1) { + # If this is the first of many years, we only need to worry about the start date + nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + day1 <- yday(start_date) + day2 = nday + days.use = day1:day2 + nday=length(days.use) # Update nday + } else if(i==rows) { + # If this is the last of many years, we only need to worry about the start date + nday = ifelse(lubridate:: leap_year(y.now), 366, 365) # leap year or not; days per year + day1 = 1 + day2 <- yday(end_date) + days.use = day1:day2 + nday=length(days.use) # Update nday + } + ntime = nday*24 # leap year or not;time slice (hourly) + + loc.file = file.path(outfolder, paste("NLDAS",y.now,"nc",sep=".")) + + ## Create dimensions + dim.lat <- ncdim_def(name='latitude', units='degree_north', vals=lat.in, create_dimvar=TRUE) + dim.lon <- ncdim_def(name='longitude', units='degree_east', vals=lon.in, create_dimvar=TRUE) + dim.time <- ncdim_def(name='time', units="sec", vals=seq((min(days.use)+1-1/24)*24*360, (max(days.use)+1-1/24)*24*360, length.out=ntime), create_dimvar=TRUE, unlim=TRUE) + nc.dim=list(dim.lat,dim.lon,dim.time) + + var.list = list() + dat.list = list() + + # Defining our dimensions up front + for(j in 1:nrow(var)){ + var.list[[j]] = ncvar_def(name=as.character(var$CF.name[j]), units=as.character(var$units[j]), dim=nc.dim, missval=-999, verbose=verbose) + dat.list[[j]] <- array(NA, dim=c(length(lat.in), length(lon.in), ntime)) # Go ahead and make the arrays + } + names(var.list) <- names(dat.list) <- var$CF.name + + + # Progress bar just to help us track what's going on + print("") + print(y.now) + pb <- txtProgressBar(min=1, max=nday, style=3) + pb.index=1 + + ## get data off OpenDAP + for(j in 1:length(days.use)){ + setTxtProgressBar(pb, pb.index) + + date.now <- as.Date(days.use[j], origin=as.Date(paste0(y.now-1,"-12-31"))) + mo.now <- str_pad(month(date.now), 2, pad="0") + day.mo <- str_pad(day(date.now), 2, pad="0") + doy <- str_pad(days.use[j], 3, pad="0") + + # Local netcdf format is 1-file per day + # NLDAS_FORA0125_H.A19790102.nc + dap_file <- nc_open(file.path(in.path,y.now,mo.now,paste0("NLDAS_FORA0125_H.A",y.now, mo.now,day.mo,".nc"))) + + # Query lat/lon + lats <- ncvar_get(dap_file, "lat") + lons <- ncvar_get(dap_file, "lon") + + # Get the average resolution (without hard-coding and possibly making an error) + x.inc <- mean(abs(diff(lons))) + y.inc <- mean(abs(diff(lats))) + + lat.use <- which(lats-y.inc/2<=lat.in & lats+y.inc/2>=lat.in) + lon.use <- which(lons-x.inc/2<=lon.in & lons+x.inc/2>=lon.in) + + # Extracting the variables + for (v in 1:nrow(var)) { + v.nldas <- paste(var$NLDAS.name[v]) + v.cf <- paste(var$CF.name [v]) + + # Variables have different dimensions (which is a pain in the butt) + # so we need to check to see whether we're pulling 4 dimensions or just 3 + if(dap_file$var[[v.nldas]]$ndims == 4){ + dat.list[[v.cf]][,,(j*24-23):(j*24)] <- ncvar_get(dap_file, v.nldas, + start=c(lon.use,lat.use,1,1), + count=c(1,1,1,24) + ) + } else { + dat.list[[v.cf]][,,(j*24-23):(j*24)] <- ncvar_get(dap_file, v.nldas, + start=c(lon.use,lat.use,1), + count=c(1,1,24) + ) + + } + } # end variable loop + + nc_close(dap_file) # close file + pb.index=pb.index+1 # Advance our progress bar + } # end day + + ## change units of precip from kg/m2/hr to kg/m2/s + dat.list[["precipitation_flux"]] = dat.list[["precipitation_flux"]]/(60*60) + + ## put data in new file + loc <- nc_create(filename=loc.file, vars=var.list, verbose=verbose) + for(j in 1:nrow(var)){ + ncvar_put(nc=loc, varid=as.character(var$CF.name[j]), vals=dat.list[[j]]) + } + nc_close(loc) + + results$file[i] <- loc.file + # results$host[i] <- fqdn() + results$startdate[i] <- paste0(as.Date(paste(y.now, day1, sep="-"), format = "%Y-%j"), " 00:00:00") + results$enddate[i] <- paste0(as.Date(paste(y.now, day2, sep="-"), format = "%Y-%j"), " 00:00:00") + results$mimetype[i] <- 'application/x-netcdf' + results$formatname[i] <- 'CF Meteorology' + + } + +} From f0c969db88b905d853a0219a196a1fc6eff9cdee Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Sun, 17 Sep 2017 16:56:56 -0500 Subject: [PATCH 678/771] Fix setting origin of time vector For most cases, p1000 scenarios are referenced off of 850 in all files and historical is referenced off of 1850. MPI-ESM-P seems to be an exception an is referenced off of 850 in all cases. Could probably find a way to soft code this, but I think I tried it once before and found had trouble. --- modules/data.atmosphere/R/extract_local_CMIP5.R | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/modules/data.atmosphere/R/extract_local_CMIP5.R b/modules/data.atmosphere/R/extract_local_CMIP5.R index 046af3f33e7..81c24ceb9e5 100644 --- a/modules/data.atmosphere/R/extract_local_CMIP5.R +++ b/modules/data.atmosphere/R/extract_local_CMIP5.R @@ -40,6 +40,9 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i # Some GCMs don't do leap year; we'll have to deal with this separately no.leap <- c("bcc-csm1-1", "CCSM4") + if(scenario == "p1000" | GCM=="MPI-ESM-P") date.origin=as.Date("850-01-01") + if(scenario == "historical" & GCM!="MPI-ESM-P") date.origin=as.Date("1850-01-01") + # Days per month dpm <- lubridate::days_in_month(1:12) @@ -159,7 +162,7 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i # splt.ind <- ifelse(GCM %in% c("MPI-ESM-P"), 4, 3) # date.origin <- as.Date(str_split(ncT$dim$time$units, " ")[[1]][splt.ind]) - nc.date <- as.Date(paste0(files.var[[var.now]][i,"first.year"], "-01-01")) + nc.time + nc.date <- date.origin + nc.time date.leaps <- seq(as.Date(paste0(files.var[[var.now]][i,"first.year"], "-01-01")), as.Date(paste0(files.var[[var.now]][i,"last.year"], "-12-31")), by="day") # If we're missing leap year, lets adjust our date stamps so we can only pull what we need if(v.res=="day" & length(nc.date)!=length(date.leaps)){ From 653543b7c72c696dd84fef9795f2380e29cef071 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Mon, 18 Sep 2017 10:03:00 -0500 Subject: [PATCH 679/771] Update documentation --- modules/data.atmosphere/NAMESPACE | 1 + .../man/extract.local.NLDAS.Rd | 42 +++++++++++++++++++ 2 files changed, 43 insertions(+) create mode 100644 modules/data.atmosphere/man/extract.local.NLDAS.Rd diff --git a/modules/data.atmosphere/NAMESPACE b/modules/data.atmosphere/NAMESPACE index 82a3283fa04..47c2f36f621 100644 --- a/modules/data.atmosphere/NAMESPACE +++ b/modules/data.atmosphere/NAMESPACE @@ -32,6 +32,7 @@ export(download.PalEON_ENS) export(equation_of_time) export(exner) export(extract.local.CMIP5) +export(extract.local.NLDAS) export(extract.nc) export(gen.subdaily.models) export(get.es) diff --git a/modules/data.atmosphere/man/extract.local.NLDAS.Rd b/modules/data.atmosphere/man/extract.local.NLDAS.Rd new file mode 100644 index 00000000000..e4291992863 --- /dev/null +++ b/modules/data.atmosphere/man/extract.local.NLDAS.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/extract_local_NLDAS.R +\name{extract.local.NLDAS} +\alias{extract.local.NLDAS} +\title{extract.local.NLDAS} +\usage{ +extract.local.NLDAS(outfolder, in.path, start_date, end_date, site_id, lat.in, + lon.in, overwrite = FALSE, verbose = FALSE, ...) +} +\arguments{ +\item{outfolder}{- directory where output files will be stored} + +\item{in.path}{- path to the raw full grids} + +\item{start_date}{- first day for which you want to extract met (yyyy-mm-dd)} + +\item{end_date}{- last day for which you want to extract met (yyyy-mm-dd)} + +\item{site_id}{name to associate with extracted files} + +\item{lat.in}{site latitude in decimal degrees} + +\item{lon.in}{site longitude in decimal degrees} + +\item{overwrite}{logical. Download a fresh version even if a local file with the same name already exists?} + +\item{...}{Other arguments, currently ignored} +} +\description{ +This function extracts NLDAS data from grids that have been downloaded and stored locally. + Once upon a time, you could query these files directly from the internet, but now they're + behind a tricky authentication wall. Files are saved as a netCDF file in CF conventions. + These files are ready to be used in the general PEcAn workflow or fed into the downscalign + workflow. +} +\details{ +Extract NLDAS from local download +Extract NLDAS meteorology for a poimt from a local download of the full grid +} +\author{ +Christy Rollinson, +} From d9bef83d261f8b1f23915c296e880518a97910d2 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Mon, 18 Sep 2017 10:29:57 -0500 Subject: [PATCH 680/771] Add option to specify date.origin and lack of leap year MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Per Ankur’s comments, allow the user to pass along the date of origin for time stamps (if known; and throw and error if no default implemented) and allow the user to specify whether or not leap year should be missing --- .../data.atmosphere/R/extract_local_CMIP5.R | 29 +++++++++++++++---- 1 file changed, 23 insertions(+), 6 deletions(-) diff --git a/modules/data.atmosphere/R/extract_local_CMIP5.R b/modules/data.atmosphere/R/extract_local_CMIP5.R index 81c24ceb9e5..da047fdd400 100644 --- a/modules/data.atmosphere/R/extract_local_CMIP5.R +++ b/modules/data.atmosphere/R/extract_local_CMIP5.R @@ -24,6 +24,12 @@ ##' @param model which GCM to extract data from ##' @param scenario which experiment to pull (p1000, historical, ...) ##' @param ensemble_member which CMIP5 experiment ensemble member +##' @param date.origin (optional) specify the date of origin for timestamps in the files being read. +##' If NULL defaults to 1850 for historical simulations (except MPI-ESM-P) and +##' 850 for p1000 simulations (plus MPI-ESM-P historical). Format: YYYY-MM-DD +##' @param no.leap (optional, logical) if you know your GCM of interest is missing leap year, you can specify it here. +##' otherwise the code will automatically determine if leap year is missing and if it should be +##' added in. ##' @param overwrite logical. Download a fresh version even if a local file with the same name already exists? ##' @param verbose logical. to control printing of debug info ##' @param ... Other arguments, currently ignored @@ -31,17 +37,25 @@ ##' @examples # ----------------------------------- extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_id, lat.in, lon.in, - model , scenario , ensemble_member = "r1i1p1", + model , scenario , ensemble_member = "r1i1p1", date.origin=NULL, no.leap=NULL, overwrite = FALSE, verbose = FALSE, ...){ library(lubridate) library(ncdf4) library(stringr) # Some GCMs don't do leap year; we'll have to deal with this separately - no.leap <- c("bcc-csm1-1", "CCSM4") + # no.leap <- c("bcc-csm1-1", "CCSM4") + + if(is.null(date.origin)){ + if(scenario == "p1000" | GCM=="MPI-ESM-P") { + date.origin=as.Date("850-01-01") + } else if { + if(scenario == "historical" & GCM!="MPI-ESM-P") date.origin=as.Date("1850-01-01") + } else { + logger.error("No date.origin specified and scenario not implemented yet") + } + } - if(scenario == "p1000" | GCM=="MPI-ESM-P") date.origin=as.Date("850-01-01") - if(scenario == "historical" & GCM!="MPI-ESM-P") date.origin=as.Date("1850-01-01") # Days per month dpm <- lubridate::days_in_month(1:12) @@ -164,8 +178,11 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i # date.origin <- as.Date(str_split(ncT$dim$time$units, " ")[[1]][splt.ind]) nc.date <- date.origin + nc.time date.leaps <- seq(as.Date(paste0(files.var[[var.now]][i,"first.year"], "-01-01")), as.Date(paste0(files.var[[var.now]][i,"last.year"], "-12-31")), by="day") + # Figure out if we're missing leap dat + no.leap <- ifelse(is.null(no.leap) & length(nc.date)!=length(date.leaps), TRUE, FALSE) + # If we're missing leap year, lets adjust our date stamps so we can only pull what we need - if(v.res=="day" & length(nc.date)!=length(date.leaps)){ + if(v.res=="day" & no.leap==TRUE){ cells.bump <- which(lubridate::leap_year(lubridate::year(date.leaps)) & lubridate::month(date.leaps)==02 & lubridate::day(date.leaps)==29) for(j in 1:length(cells.bump)){ nc.date[cells.bump[j]:length(nc.date)] <- nc.date[cells.bump[j]:length(nc.date)]+1 @@ -209,7 +226,7 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i # Add leap year and trick monthly into daily # Figure out if we're missing leap year - if(v.res=="day" & length(nc.date)!=length(date.leaps)){ + if(v.res=="day" & no.leap==TRUE){ cells.dup <- which(lubridate::leap_year(lubridate::year(date.leaps)) & lubridate::month(date.leaps)==02 & lubridate::day(date.leaps)==28) for(j in 1:length(cells.dup)){ dat.temp <- append(dat.temp, dat.temp[cells.dup[j]], cells.dup[j]) From 67f78e0e987ba6c189992063810a7d371a1dde44 Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Mon, 18 Sep 2017 10:32:31 -0500 Subject: [PATCH 681/771] Typo fix; update documentation --- modules/data.atmosphere/R/extract_local_CMIP5.R | 4 ++-- modules/data.atmosphere/man/extract.local.CMIP5.Rd | 12 ++++++++++-- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/modules/data.atmosphere/R/extract_local_CMIP5.R b/modules/data.atmosphere/R/extract_local_CMIP5.R index da047fdd400..294376d873b 100644 --- a/modules/data.atmosphere/R/extract_local_CMIP5.R +++ b/modules/data.atmosphere/R/extract_local_CMIP5.R @@ -49,8 +49,8 @@ extract.local.CMIP5 <- function(outfolder, in.path, start_date, end_date, site_i if(is.null(date.origin)){ if(scenario == "p1000" | GCM=="MPI-ESM-P") { date.origin=as.Date("850-01-01") - } else if { - if(scenario == "historical" & GCM!="MPI-ESM-P") date.origin=as.Date("1850-01-01") + } else if(scenario == "historical" & GCM!="MPI-ESM-P") { + date.origin=as.Date("1850-01-01") } else { logger.error("No date.origin specified and scenario not implemented yet") } diff --git a/modules/data.atmosphere/man/extract.local.CMIP5.Rd b/modules/data.atmosphere/man/extract.local.CMIP5.Rd index abfdb852451..13fe0af0b9c 100644 --- a/modules/data.atmosphere/man/extract.local.CMIP5.Rd +++ b/modules/data.atmosphere/man/extract.local.CMIP5.Rd @@ -5,8 +5,8 @@ \title{extract.local.CMIP5} \usage{ extract.local.CMIP5(outfolder, in.path, start_date, end_date, site_id, lat.in, - lon.in, model, scenario, ensemble_member = "r1i1p1", overwrite = FALSE, - verbose = FALSE, ...) + lon.in, model, scenario, ensemble_member = "r1i1p1", date.origin = NULL, + no.leap = NULL, overwrite = FALSE, verbose = FALSE, ...) } \arguments{ \item{outfolder}{- directory where output files will be stored} @@ -29,6 +29,14 @@ extract.local.CMIP5(outfolder, in.path, start_date, end_date, site_id, lat.in, \item{ensemble_member}{which CMIP5 experiment ensemble member} +\item{date.origin}{(optional) specify the date of origin for timestamps in the files being read. +If NULL defaults to 1850 for historical simulations (except MPI-ESM-P) and +850 for p1000 simulations (plus MPI-ESM-P historical). Format: YYYY-MM-DD} + +\item{no.leap}{(optional, logical) if you know your GCM of interest is missing leap year, you can specify it here. +otherwise the code will automatically determine if leap year is missing and if it should be +added in.} + \item{overwrite}{logical. Download a fresh version even if a local file with the same name already exists?} \item{verbose}{logical. to control printing of debug info} From 2ffb64ead861eba0057486a144b228531a4569df Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 18 Sep 2017 14:09:50 -0400 Subject: [PATCH 682/771] fix typos --- modules/assim.batch/R/pda.emulator.R | 4 ++-- modules/assim.batch/R/pda.postprocess.R | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/assim.batch/R/pda.emulator.R b/modules/assim.batch/R/pda.emulator.R index a28a8be0a11..3a96c477c5d 100644 --- a/modules/assim.batch/R/pda.emulator.R +++ b/modules/assim.batch/R/pda.emulator.R @@ -186,8 +186,8 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, if(!is.null(sf)){ load(settings$assim.batch$sf.path) - sf.round.post <- pda.define.prior.fn(post.distns) - rm(post.distns) + sf.round.post <- pda.define.prior.fn(sf.post.distns) + rm(sf.post.distns) n.sf <- length(sf) sf.round.list <- pda.generate.knots(n.post.knots, sf = NULL, probs.sf = NULL, diff --git a/modules/assim.batch/R/pda.postprocess.R b/modules/assim.batch/R/pda.postprocess.R index f42af58cade..04b222dbbf9 100644 --- a/modules/assim.batch/R/pda.postprocess.R +++ b/modules/assim.batch/R/pda.postprocess.R @@ -244,7 +244,7 @@ write_sf_posterior <- function(sf.samp.list, sf.prior, sf.filename){ outdir = dirname(sf.filename), filename.flag = filename.flag) - save(sf.subset, file = file.path(dirname(sf.filename), paste0("samples", filename.flag, ".Rdata"))) + save(sf.subset.list, file = file.path(dirname(sf.filename), paste0("samples", filename.flag, ".Rdata"))) return(sf.post.distns) From d3e8ac9e2325f1f73497a8e73fdefa3a4e0dab90 Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 18 Sep 2017 14:12:59 -0400 Subject: [PATCH 683/771] query files from localhost --- modules/assim.batch/R/pda.utils.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/modules/assim.batch/R/pda.utils.R b/modules/assim.batch/R/pda.utils.R index 7e0dcaa58bc..cce72507e14 100644 --- a/modules/assim.batch/R/pda.utils.R +++ b/modules/assim.batch/R/pda.utils.R @@ -262,11 +262,13 @@ pda.load.priors <- function(settings, con, extension.check = FALSE) { prior.out <- list() prior.paths <- list() + tmp_hostname <- ifelse(!PEcAn.remote::is.localhost(settings$host), PEcAn.utils::fqdn(), settings$host$name) + # now that you filled priorids load the PDA prior objects # if files becomes NULL try loading objects from workflow oft folders for (i in seq_along(settings$pfts)) { - files <- dbfile.check("Posterior", priorids[[i]], con, settings$host$name, return.all = TRUE) + files <- dbfile.check("Posterior", priorids[[i]], con, tmp_hostname, return.all = TRUE) pid <- grep("post.distns.*Rdata", files$file_name) ## is there a posterior file? From 961672c6450438e5ed683fc4da7d8f435d03e87d Mon Sep 17 00:00:00 2001 From: annethomas Date: Mon, 18 Sep 2017 14:44:17 -0400 Subject: [PATCH 684/771] Change labels to easting/northing --- modules/data.remote/inst/modisWSDL.py | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/modules/data.remote/inst/modisWSDL.py b/modules/data.remote/inst/modisWSDL.py index b0033e62946..1d0440481a7 100644 --- a/modules/data.remote/inst/modisWSDL.py +++ b/modules/data.remote/inst/modisWSDL.py @@ -351,8 +351,10 @@ def m_data_to_netCDF(filename, m, k, kmLR, kmAB): rootgrp = netCDF4.Dataset(filename, 'w', format='NETCDF4') nrow = 1 + 2*kmAB ncol = 1 + 2*kmLR - rootgrp.createDimension('nrow', nrow) - rootgrp.createDimension('ncol', ncol) + rootgrp.createDimension('northing', nrow) +# m_north = rootgrp.createVariable('northing', 'i8', ('northing')) +# m_north.units = "km north of lowest point in grid") + rootgrp.createDimension('easting', ncol) rootgrp.createDimension('time', len(m.dateInt)) m_date = rootgrp.createVariable('time', 'i8', ('time')) @@ -361,8 +363,8 @@ def m_data_to_netCDF(filename, m, k, kmLR, kmAB): year = startDate.year m_date.units = 'days since %d-01-01 00:00:00.0'%(year) - m_data = rootgrp.createVariable('LAI', 'f8', ('time', 'nrow', 'ncol')) - m_std = rootgrp.createVariable('LAIStd', 'f8', ('time', 'nrow', 'ncol')) + m_data = rootgrp.createVariable('LAI', 'f8', ('time', 'northing', 'easting')) + m_std = rootgrp.createVariable('LAIStd', 'f8', ('time', 'northing', 'easting')) str_dates = [str(d) for d in m.dateInt] datetimes = [(datetime.datetime.strptime(d, '%Y%j')- datetime.datetime(year,1,1)).days+1 for d in str_dates] From e38b8540cef5dc310c6427e2bbeb03824e3a9237 Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 18 Sep 2017 15:20:00 -0400 Subject: [PATCH 685/771] fix function args --- modules/data.land/R/ic_process.R | 2 +- modules/data.land/R/put.veg.module.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/modules/data.land/R/ic_process.R b/modules/data.land/R/ic_process.R index 2a9e4784f0c..7be34213afc 100644 --- a/modules/data.land/R/ic_process.R +++ b/modules/data.land/R/ic_process.R @@ -114,7 +114,7 @@ ic_process <- function(settings, input, dir, overwrite = FALSE){ if (!is.null(getveg.id) & is.null(putveg.id) & input$output %in% vegIC) { # probably need a more sophisticated check here - putveg.id <- .put.veg.module(getveg.id = getveg.id, bety = bety, + putveg.id <- .put.veg.module(getveg.id = getveg.id, dbparms = dbparms, input_veg = input, pfts = settings$pfts, outfolder = outfolder, dir = dir, machine = machine, model = model, diff --git a/modules/data.land/R/put.veg.module.R b/modules/data.land/R/put.veg.module.R index 779303fa5c6..e402bcc72b0 100644 --- a/modules/data.land/R/put.veg.module.R +++ b/modules/data.land/R/put.veg.module.R @@ -1,4 +1,4 @@ -.put.veg.module <- function(getveg.id, bety, +.put.veg.module <- function(getveg.id, dbparms, input_veg, pfts, outfolder, dir, machine, model, From 9b86f532b26e5ee878451efb6a24ce41ba2a3a4f Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 18 Sep 2017 15:20:56 -0400 Subject: [PATCH 686/771] remote namespace calls --- modules/data.land/R/ic_process.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/modules/data.land/R/ic_process.R b/modules/data.land/R/ic_process.R index 7be34213afc..875ed5cedc2 100644 --- a/modules/data.land/R/ic_process.R +++ b/modules/data.land/R/ic_process.R @@ -152,17 +152,17 @@ ic_process <- function(settings, input, dir, overwrite = FALSE){ # copies css css_file <- basename(settings$run$inputs[["css"]][['path']]) - PEcAn.utils::remote.copy.update(putveg.id, remote_dir, remote_file_name = css_file, settings$host, con) + PEcAn.remote::remote.copy.update(putveg.id, remote_dir, remote_file_name = css_file, settings$host, con) settings$run$inputs[["css"]][['path']] <- file.path(remote_dir, css_file) # pss pss_file <- basename(settings$run$inputs[["pss"]][['path']]) - PEcAn.utils::remote.copy.update(putveg.id, remote_dir, remote_file_name = pss_file, settings$host, con) + PEcAn.remote::remote.copy.update(putveg.id, remote_dir, remote_file_name = pss_file, settings$host, con) settings$run$inputs[["pss"]][['path']] <- file.path(remote_dir, pss_file) # site site_file <- basename(settings$run$inputs[["site"]][['path']]) - PEcAn.utils::remote.copy.update(putveg.id, remote_dir, remote_file_name = site_file, settings$host, con) + PEcAn.remote::remote.copy.update(putveg.id, remote_dir, remote_file_name = site_file, settings$host, con) settings$run$inputs[["site"]][['path']] <- file.path(remote_dir, site_file) } From f28775ca1ada646be66ec76d175c6a943eabb8cf Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Mon, 18 Sep 2017 13:19:30 -0500 Subject: [PATCH 687/771] Consistent usage of hour MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Rather than as.factor, as.ordered because there IS an order to our hours. This commit must’ve gotten lost somewhere along the way. --- modules/data.atmosphere/R/tdm_model_train.R | 42 ++++++++++----------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/modules/data.atmosphere/R/tdm_model_train.R b/modules/data.atmosphere/R/tdm_model_train.R index 505e47c742e..c18c9eb69bc 100644 --- a/modules/data.atmosphere/R/tdm_model_train.R +++ b/modules/data.atmosphere/R/tdm_model_train.R @@ -56,9 +56,9 @@ model.train <- function(dat.subset, v, n.beta, resids = resids, threshold = NULL threshold, "hour"]) mod.doy <- lm(surface_downwelling_shortwave_flux_in_air ~ - as.factor(hour) * surface_downwelling_shortwave_flux_in_air.day - + as.ordered(hour) * surface_downwelling_shortwave_flux_in_air.day - 1 - surface_downwelling_shortwave_flux_in_air.day - - as.factor(hour), data = dat.subset[dat.subset$hour %in% + as.ordered(hour), data = dat.subset[dat.subset$hour %in% hrs.day, ]) ### # If we can't estimate the covariance matrix, double our data and try @@ -68,18 +68,18 @@ model.train <- function(dat.subset, v, n.beta, resids = resids, threshold = NULL unique(dat.subset$doy))) dat.subset <- rbind(dat.subset, dat.subset) mod.doy <- lm(surface_downwelling_shortwave_flux_in_air ~ - as.factor(hour) * surface_downwelling_shortwave_flux_in_air.day - + as.ordered(hour) * surface_downwelling_shortwave_flux_in_air.day - 1 - surface_downwelling_shortwave_flux_in_air.day - - as.factor(hour), data = dat.subset[dat.subset$hour %in% + as.ordered(hour), data = dat.subset[dat.subset$hour %in% hrs.day, ]) ### } } if (v == "surface_downwelling_longwave_flux_in_air") { mod.doy <- lm(sqrt(surface_downwelling_longwave_flux_in_air) ~ - as.factor(hour) * surface_downwelling_longwave_flux_in_air.day * + as.ordered(hour) * surface_downwelling_longwave_flux_in_air.day * (lag.surface_downwelling_longwave_flux_in_air + next.surface_downwelling_longwave_flux_in_air) - - as.factor(hour) - 1 - lag.surface_downwelling_longwave_flux_in_air - + as.ordered(hour) - 1 - lag.surface_downwelling_longwave_flux_in_air - next.surface_downwelling_longwave_flux_in_air - surface_downwelling_longwave_flux_in_air.day - surface_downwelling_longwave_flux_in_air.day * lag.surface_downwelling_longwave_flux_in_air - surface_downwelling_longwave_flux_in_air.day * next.surface_downwelling_longwave_flux_in_air, @@ -94,27 +94,27 @@ model.train <- function(dat.subset, v, n.beta, resids = resids, threshold = NULL # probability distribution of rain occuring in a given hour dat.subset$rain.prop <- dat.subset$precipitation_flux/(dat.subset$precipitation_flux.day * 24) - mod.doy <- lm(rain.prop ~ as.factor(hour) * precipitation_flux.day - - 1 - as.factor(hour) - precipitation_flux.day, data = dat.subset) + mod.doy <- lm(rain.prop ~ as.ordered(hour) * precipitation_flux.day - + 1 - as.ordered(hour) - precipitation_flux.day, data = dat.subset) } if (v == "air_pressure") { - mod.doy <- lm(air_pressure ~ as.factor(hour) * (air_pressure.day + - lag.air_pressure + next.air_pressure) - as.factor(hour) - + mod.doy <- lm(air_pressure ~ as.ordered(hour) * (air_pressure.day + + lag.air_pressure + next.air_pressure) - as.ordered(hour) - 1 - air_pressure.day - lag.air_pressure - next.air_pressure, data = dat.subset) } if (v == "specific_humidity") { - mod.doy <- lm(log(specific_humidity) ~ as.factor(hour) * + mod.doy <- lm(log(specific_humidity) ~ as.ordered(hour) * specific_humidity.day * (lag.specific_humidity + next.specific_humidity + - air_temperature_max.day) - as.factor(hour) - 1 - air_temperature_max.day, + air_temperature_max.day) - as.ordered(hour) - 1 - air_temperature_max.day, data = dat.subset) } if (v == "wind_speed") { - mod.doy <- lm(sqrt(wind_speed) ~ as.factor(hour) * wind_speed.day * - (lag.wind_speed + next.wind_speed) - as.factor(hour) - + mod.doy <- lm(sqrt(wind_speed) ~ as.ordered(hour) * wind_speed.day * + (lag.wind_speed + next.wind_speed) - as.ordered(hour) - 1 - wind_speed.day - lag.wind_speed - next.wind_speed - wind_speed.day * lag.wind_speed - wind_speed.day * next.wind_speed, data = dat.subset) @@ -145,14 +145,14 @@ model.train <- function(dat.subset, v, n.beta, resids = resids, threshold = NULL if (v == "air_temperature") { dat.subset[!is.na(dat.subset$lag.air_temperature) & !is.na(dat.subset$next.air_temperature_max), "resid"] <- resid(mod.doy) - resid.model <- lm(resid ~ as.factor(hour) * (air_temperature_max.day * + resid.model <- lm(resid ~ as.ordered(hour) * (air_temperature_max.day * air_temperature_min.day) - 1, data = dat.subset[!is.na(dat.subset$lag.air_temperature), ]) } if (v == "surface_downwelling_shortwave_flux_in_air") { dat.subset[dat.subset$hour %in% hrs.day, "resid"] <- resid(mod.doy) - resid.model <- lm(resid ~ as.factor(hour) * surface_downwelling_shortwave_flux_in_air.day - + resid.model <- lm(resid ~ as.ordered(hour) * surface_downwelling_shortwave_flux_in_air.day - 1, data = dat.subset[dat.subset$hour %in% hrs.day, ]) } @@ -161,34 +161,34 @@ model.train <- function(dat.subset, v, n.beta, resids = resids, threshold = NULL dat.subset[!is.na(dat.subset$lag.surface_downwelling_longwave_flux_in_air) & !is.na(dat.subset$next.surface_downwelling_longwave_flux_in_air), "resid"] <- resid(mod.doy) - resid.model <- lm(resid ~ as.factor(hour) * surface_downwelling_longwave_flux_in_air.day - + resid.model <- lm(resid ~ as.ordered(hour) * surface_downwelling_longwave_flux_in_air.day - 1, data = dat.subset[, ]) } if (v == "precipitation_flux") { dat.subset[, "resid"] <- resid(mod.doy) - resid.model <- lm(resid ~ as.factor(hour) * precipitation_flux.day - + resid.model <- lm(resid ~ as.ordered(hour) * precipitation_flux.day - 1, data = dat.subset[, ]) } if (v == "air_pressure") { dat.subset[!is.na(dat.subset$lag.air_pressure) & !is.na(dat.subset$next.air_pressure), "resid"] <- resid(mod.doy) - resid.model <- lm(resid ~ as.factor(hour) * air_pressure.day - + resid.model <- lm(resid ~ as.ordered(hour) * air_pressure.day - 1, data = dat.subset[, ]) } if (v == "specific_humidity") { dat.subset[!is.na(dat.subset$lag.specific_humidity) & !is.na(dat.subset$next.specific_humidity), "resid"] <- resid(mod.doy) - resid.model <- lm(resid ~ as.factor(hour) * specific_humidity.day - + resid.model <- lm(resid ~ as.ordered(hour) * specific_humidity.day - 1, data = dat.subset[, ]) } if (v == "wind_speed") { dat.subset[!is.na(dat.subset$lag.wind_speed) & !is.na(dat.subset$next.wind_speed), "resid"] <- resid(mod.doy) - resid.model <- lm(resid ~ as.factor(hour) * wind_speed.day - + resid.model <- lm(resid ~ as.ordered(hour) * wind_speed.day - 1, data = dat.subset[, ]) } From dca05097c1c6bb79b4ac6046116e9eab4b104572 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Mon, 18 Sep 2017 17:31:11 -0400 Subject: [PATCH 688/771] add pool and soil --- .../basic_users_guide/Choosing-soils.Rmd | 25 +------- .../Adding-an-Input-Converter.Rmd | 64 ++++++++++++++++--- book_source/workflow/inputs_conversions.Rmd | 3 +- 3 files changed, 57 insertions(+), 35 deletions(-) diff --git a/book_source/basic_users_guide/Choosing-soils.Rmd b/book_source/basic_users_guide/Choosing-soils.Rmd index 5d310652c63..13531cc4f0d 100755 --- a/book_source/basic_users_guide/Choosing-soils.Rmd +++ b/book_source/basic_users_guide/Choosing-soils.Rmd @@ -8,32 +8,11 @@ As with [[Choosing initial vegetation]], we eventually hope to develop data stan A PEcAn-standard netCDF file format exists for soil texture, depth, and physical parameters, using PEcAn standard names that are largely a direct extention of the CF standard. A table of standard names and units can be listed using ```PEcAn.data.land::soil.units()``` with no arguements. -```{r} +```{r,echo=FALSE} knitr::kable(PEcAn.data.land::soil.units()) ``` - -Local data that has the correct names and units can easily be written out in PEcAn standard using the function soil2netcdf. - -``` -soil.data <- list(volume_fraction_of_sand_in_soil = c(0.3,0.4,0.5), - volume_fraction_of_clay_in_soil = c(0.3,0.3,0.3), - soil_depth = c(0.2,0.5,1.0)) - -soil2netcdf(soil.data,"soil.nc") -``` - -At the moment this file would need to be inserted into Inputs manually. By default, this function also calls soil_params, which will estimate a number of hydraulic and thermal parameters from texture. Be aware that at the moment not all model couplers are yet set up to read this file and/or convert it to model-specific formats. - -In addition to location-specific soil data, PEcAn can extract soil texture information from the PalEON regional soil product, which itself is a subset of the MsTMIP Unified North American Soil Map. If this product is installed on your machine, the appropriate step in the do_conversions workflow is enabled by adding the following tag under `````` in your pecan.xml - -``` - - 1000012896 - -``` - -In the future we aim to extend this extraction to a wider range of soil products. +More detailed information on how PEcAn processes inputs can be found on our [Input Conversion] page. ## Other model inputs diff --git a/book_source/developers_guide/Adding-an-Input-Converter.Rmd b/book_source/developers_guide/Adding-an-Input-Converter.Rmd index df6e34646fb..4bc1f83a27b 100755 --- a/book_source/developers_guide/Adding-an-Input-Converter.Rmd +++ b/book_source/developers_guide/Adding-an-Input-Converter.Rmd @@ -97,14 +97,16 @@ bety <- dplyr::src_postgres(dbname = 'bety', con <- bety$con ``` + Next you will set up the arguments for the function + ``` in.path <- '.' in.prefix <- raw.file$dbfile.name outfolder <- '.' format.id <- 5000000002 format <- PEcAn.DB::query.format.vars(format.id=format.id,bety = bety) -lon <- 105.54 +lon <- -105.54 lat <- 40.03 format$time_zone <- "America/Chicago" ``` @@ -136,7 +138,6 @@ If your data is in a csv formate you can use the `met2CF.csv`function to convert Open a connection with BETY. You may need to change the host name depending on what mahcine you are hosting BETY. You can find the hostname listed in the machines table of BETY. ``` - bety <- dplyr::src_postgres(dbname = 'bety', host ='localhost', user = "bety", @@ -169,7 +170,7 @@ PEcAn.data.atmosphere::met2CF.csv(in.path = in.path, end_date = end_date, lat= lat, lon = lon, - + format = format) ``` @@ -179,7 +180,7 @@ Vegetation data will be required to parameterize your model. In these examples w The main function to process cohort data is the `ic.process.R` function. As of now however, if you require pool data you will run a seperate function, `pool_ic_list2netcdf.R`. -Example 1: Raw data from a database +#### Example 1: Raw data from a database If your data is coming from a datbase (ex.FIA) the section of your pecan.xml will need to look like the following: ``` @@ -187,17 +188,20 @@ paste inputs section here ``` From here you read in the pecan.xml to obtain a settings object ``` -settings<- - +settings <- PEcAn.settings::read.settings("pecan.xml") +settings <- PEcAn.settings::prepare.settings(settings, force=FALSE) ``` You can then execute the `ic.process` function to convert data into a standard Rds file: ``` +settings <- PEcAn.settings::read.settings("pecan.xml") +settings <- PEcAn.settings::prepare.settings(settings, force=FALSE) + ic.process(settings, input, dir, overwrite = FALSE) ``` -Example 2: Raw data in hand +#### Example 2: Raw data in hand You will first need to update the BETY database with the appropriate records. A file record with location of the raw file, a format record with requisite meta data information about the structure of the file, and then an input record what has the file and format record assiciated with it. Instructions on how to do that can be found here [How to Insert new Input Data]. @@ -213,19 +217,59 @@ ic.process(settings, input, dir, overwrite = FALSE) ``` - - +#### Example 3 Pool Initial Condition files If you have pool vegetation data, you'll need the [`pool_ic_list2netcdf.R`](https://github.com/PecanProject/pecan/blob/develop/modules/data.land/R/pool_ic_list2netcdf.R) function to convert the pool data into PEcAn standard. +The function stands alone and requires that you provide a named list of netcdf dimensions and values, and a named list of variables and values. Names and units need to match the standard_vars.csv table found [here](https://github.com/PecanProject/pecan/blob/develop/base/utils/data/standard_vars.csv). + ``` +#Create a list object with necessary dimensions for your site +input<-list() +dims<- list(lat=-115,lon=45, time= 1) +variables<- list(SoilResp=8,TotLivBiom=295) +input$dims <- dims +input$vals <- variables +``` +Once this is done, set `outdir` to where you'd like the file to write out to and a siteid. Siteid in this can be used as an file name identifier. Once part of the automated workflow siteid will reflect the site id within the BET db. +``` +outdir <- "." +siteid <- 772 +pool_ic_list2netcdf(input = input, outdir = outdir, siteid = siteid) ``` +You should now have a netcdf file with initial conditions. + ## Soil Data -In order to process Soil Data +#### Example 1: Converting Data in hand + +Local data that has the correct names and units can easily be written out in PEcAn standard using the function soil2netcdf. + +``` +soil.data <- list(volume_fraction_of_sand_in_soil = c(0.3,0.4,0.5), + volume_fraction_of_clay_in_soil = c(0.3,0.3,0.3), + soil_depth = c(0.2,0.5,1.0)) + +soil2netcdf(soil.data,"soil.nc") +``` + +At the moment this file would need to be inserted into Inputs manually. By default, this function also calls soil_params, which will estimate a number of hydraulic and thermal parameters from texture. Be aware that at the moment not all model couplers are yet set up to read this file and/or convert it to model-specific formats. + + +#### Example 2: Converting PalEON data + +In addition to location-specific soil data, PEcAn can extract soil texture information from the PalEON regional soil product, which itself is a subset of the MsTMIP Unified North American Soil Map. If this product is installed on your machine, the appropriate step in the do_conversions workflow is enabled by adding the following tag under `````` in your pecan.xml + +``` + + 1000012896 + +``` + +In the future we aim to extend this extraction to a wider range of soil products. diff --git a/book_source/workflow/inputs_conversions.Rmd b/book_source/workflow/inputs_conversions.Rmd index f6121d0aea8..dd666f4a74e 100644 --- a/book_source/workflow/inputs_conversions.Rmd +++ b/book_source/workflow/inputs_conversions.Rmd @@ -8,7 +8,7 @@ Within the PEcAn repository, code pertaining to input conversion is in the MODUL To convert meterological data into the PEcAn Standard and then into model formats we follow four main steps: 1. Downloading raw data - - Currently supported products + - [Currently supported products]() - Example Code 2. Converting raw data into a CF standard - Example Code @@ -24,4 +24,3 @@ How do I use PEcAn to convert Met data outide the workflow? ## Initial Conditions - - COMING SOON \ No newline at end of file From 71e412d3ef0f6147d9245b561d004a90802109fb Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 19 Sep 2017 10:06:57 -0500 Subject: [PATCH 689/771] Slight tweak to file path to facilitate parallelization; consistent direction naming MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Previously, the way file paths were passed, trying to run things is parallel (or at least the way I do it) got a little tricky. It didn’t seem much sense to have some redundant file paths, at least with my file structure, so I think it’ll be okay. Also, I inconsistently labeled things backward/backwards, so I made it consistent and inserted a check to make sure we’re using one or the other and not dropping/adding an “s” somewhere. --- .../R/tdm_generate_subdaily_models.R | 12 +++--- .../data.atmosphere/R/tdm_lm_ensemble_sims.R | 6 +-- .../R/tdm_predict_subdaily_met.R | 41 ++++++++++--------- 3 files changed, 31 insertions(+), 28 deletions(-) diff --git a/modules/data.atmosphere/R/tdm_generate_subdaily_models.R b/modules/data.atmosphere/R/tdm_generate_subdaily_models.R index 38f8ed23fdf..b6b5f029218 100644 --- a/modules/data.atmosphere/R/tdm_generate_subdaily_models.R +++ b/modules/data.atmosphere/R/tdm_generate_subdaily_models.R @@ -22,8 +22,8 @@ ##' @param path.train - path to CF/PEcAn style training data where each year is in a separate file. ##' @param yrs.train - which years of the training data should be used for to generate the model for ##' the subdaily cycle. If NULL, will default to all years -##' @param direction.filter - Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") -##' (PalEON will go backwards, anybody interested in the future will go forwards) +##' @param direction.filter - Whether the model will be filtered backward or forward in time. options = c("backward", "forward") +##' (PalEON will go backward, anybody interested in the future will go forward) ##' @param in.prefix ##' @param n.beta - number of betas to save from linear regression model ##' @param resids - logical stating whether to pass on residual data or not (this increases both memory & storage requirements) @@ -43,7 +43,7 @@ #---------------------------------------------------------------------- -gen.subdaily.models <- function(outfolder, path.train, yrs.train, direction.filter, in.prefix, +gen.subdaily.models <- function(outfolder, path.train, yrs.train, direction.filter="forward", in.prefix, n.beta, day.window, seed=Sys.time(), resids = FALSE, parallel = FALSE, n.cores = NULL, overwrite = TRUE, verbose = FALSE, print.progress=FALSE) { @@ -130,9 +130,9 @@ gen.subdaily.models <- function(outfolder, path.train, yrs.train, direction.filt # Specifying what hour we want to lag # Note: For forward filtering, we want to associate today with tomorrow (+1 day) using the last observation of today - # For backwards filtering, we want to associate today with yesterday (-1 day) using the first obs of today - met.lag <- ifelse(direction.filter=="backwards", -1, +1) - lag.time <- ifelse(direction.filter=="backwards", min(dat.train$hour), max(dat.train$hour)) + # For backward filtering, we want to associate today with yesterday (-1 day) using the first obs of today + met.lag <- ifelse(direction.filter=="backward", -1, +1) + lag.time <- ifelse(direction.filter=="backward", min(dat.train$hour), max(dat.train$hour)) lag.day <- dat.train[dat.train$hour == lag.time, c("year", "doy", "sim.day", vars.hour)] names(lag.day)[4:ncol(lag.day)] <- vars.lag diff --git a/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R b/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R index ac1e7a8a5ac..41fc50a0b26 100644 --- a/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R +++ b/modules/data.atmosphere/R/tdm_lm_ensemble_sims.R @@ -17,8 +17,8 @@ ##' @param dat.mod - dataframe to be predicted at the time step of the training data ##' @param n.ens - number of hourly ensemble members to generate ##' @param path.model - path to where the training model & betas is stored -##' @param direction.filter - Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") -##' (PalEON will go backwards, anybody interested in the future will go forwards) +##' @param direction.filter - Whether the model will be filtered backward or forward in time. options = c("backward", "forward") +##' (PalEON will go backward, anybody interested in the future will go forward) ##' @param lags.init - a data frame of initialization parameters to match the data in dat.mod ##' @param dat.train - the training data used to fit the model; needed for night/day in ##' surface_downwelling_shortwave_flux_in_air @@ -37,7 +37,7 @@ lm_ensemble_sims <- function(dat.mod, n.ens, path.model, direction.filter, lags. set.seed(seed) # Setting our our time indexes - if(direction.filter=="backwards"){ + if(direction.filter=="backward"){ days.sim <- max(dat.mod$sim.day):min(dat.mod$sim.day) lag.time <- min(dat.mod$hour) } else { diff --git a/modules/data.atmosphere/R/tdm_predict_subdaily_met.R b/modules/data.atmosphere/R/tdm_predict_subdaily_met.R index 51741f68631..b99a6a0eb37 100644 --- a/modules/data.atmosphere/R/tdm_predict_subdaily_met.R +++ b/modules/data.atmosphere/R/tdm_predict_subdaily_met.R @@ -18,19 +18,18 @@ # Parameters # ----------------------------------- ##' @param outfolder - directory where output file will be stored -##' @param in.path - path to model dataset you wish to temporally downscale +##' @param in.path - base path to dataset you wish to temporally downscale; Note: in order for parallelization +##' to work, the in.prefix will need to be appended as the final level of the file structure. +##' For example, if prefix is GFDL.CM3.rcp45.r1i1p1, there should be a directory with that title in in.path. ##' @param in.prefix - prefix of model dataset, i.e. if file is GFDL.CM3.rcp45.r1i1p1.2006 the prefix is 'GFDL.CM3.rcp45.r1i1p1' ##' @param path.train - path to CF/PEcAn style training data where each year is in a separate file. -##' @param direction.filter - Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") -##' (PalEON will go backwards, anybody interested in the future will go forwards) +##' @param direction.filter - Whether the model will be filtered backward or forwards in time. options = c("backward", "forwards") +##' (default is forward; PalEON will go backward, anybody interested in the future will go forwards) ##' @param lm.models.base - path to linear regression model folders generated using gen.subdaily.models ##' @param yrs.predict - years for which you want to generate met. if NULL, all years in in.path will be done ##' @param ens.labs - vector containing the labels (suffixes) for each ensemble member; this allows you to add to your ##' ensemble rather than overwriting with a default naming scheme ##' @param resids - logical stating whether to pass on residual data or not -##' @param parallel - logical stating whether to run temporal_downscale_functions.R in parallel -##' @param cores.max - 12 -##' @param n.cores - deals with parallelization ##' @param overwrite ##' @param verbose ##' @param print.progress - print the progress bar? @@ -53,11 +52,12 @@ # Begin Script #---------------------------------------------------------------------- -predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, direction.filter, lm.models.base, +predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, direction.filter="forward", lm.models.base, yrs.predict=NULL, ens.labs = 1:3, resids = FALSE, - parallel = FALSE, cores.max = 12, n.cores = NULL, overwrite = FALSE, verbose = FALSE, seed=format(Sys.time(), "%m%d"), print.progress=FALSE, ...) { + if(!direction.filter %in% c("backward", "forward")) logger.severe("Invalid direction.filter") + vars.hour <- c("air_temperature", "precipitation_flux", "surface_downwelling_shortwave_flux_in_air", "surface_downwelling_longwave_flux_in_air", "air_pressure", "specific_humidity", "wind_speed") @@ -67,6 +67,9 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire n.ens <- length(ens.labs) + # Update in.path with our prefix (seems silly, but helps with parallelization) + in.path <- file.path(in.path, in.prefix) + # Extract the lat/lon info from the first of the source files fnow <- dir(in.path, ".nc")[1] ncT <- ncdf4::nc_open(file.path(in.path, fnow)) @@ -87,12 +90,12 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire } # make sure files and years are ordered in the direction we want to go - if(direction.filter=="backwards"){ + if(direction.filter=="backward"){ yrs.tdm <- yrs.tdm[order(yrs.tdm, decreasing = T)] files.tdm <- files.tdm[order(files.tdm, decreasing = T)] } - met.lag <- ifelse(direction.filter=="backwards", -1, +1) + met.lag <- ifelse(direction.filter=="backward", -1, +1) # Create wind speed variable if it doesn't exist # if (all(is.na(dat.train$wind_speed) == TRUE)) { @@ -113,7 +116,7 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire # ---------------------------------- # Set progress bar # pb.index <- 1 - if(print.progress==TRUE) pb <- txtProgressBar(min = 1, max = length(yrs.tdm), style = 3) + if(print.progress==TRUE) pb <- txtProgressBar(min = 0, max = length(yrs.tdm), style = 3) # setTxtProgressBar(pb, pb.index) for (y in 1:length(yrs.tdm)) { @@ -154,17 +157,17 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire # Set up our simulation time variables; it *should* be okay that this resets each year since it's really only doy that matters dat.ens$sim.hr <- trunc(as.numeric(difftime(dat.ens$date, min(dat.ens$date), tz = "GMT", units = "hour")))+1 dat.ens$sim.day <- trunc(as.numeric(difftime(dat.ens$date, min(dat.ens$date), tz = "GMT", units = "day")))+1 - # lag.time <- ifelse(direction.filter=="backwards", min(dat.train$hour), max(dat.train$hour)) + # lag.time <- ifelse(direction.filter=="backward", min(dat.train$hour), max(dat.train$hour)) # ------------------------------ # If this is our first time through, we need to initalize our lags; # we can do so with the data we extracted with met.out # ------------------------------ # Figure out whether we want to use the first or last value to initalize our lags - # Note: Data should be ordered Jan 1 -> Dec 31; If we're moving backwards, we start with + # Note: Data should be ordered Jan 1 -> Dec 31; If we're moving backward, we start with # Dec 31 and we'll want to pull Jan 1. If we're going forward, we want the opposite if(y == 1){ - lag.use <- ifelse(direction.filter=="backwards", 1, nrow(met.out$dat.source$time)) + lag.use <- ifelse(direction.filter=="backward", 1, nrow(met.out$dat.source$time)) lags.init <- list() lags.init[["air_temperature"]] <- data.frame(array(mean(met.out$dat.source$air_temperature_maximum[lag.use], met.out$dat.source$air_temperature_minimum[lag.use]), dim=c(1, n.ens))) @@ -201,8 +204,8 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire next.specific_humidity = met.nxt$dat.train$specific_humidity, next.wind_speed = met.nxt$dat.train$wind_speed) - if(direction.filter=="backwards"){ - # If we're filtering BACKWARDS, and starting with Dec. 31 of yrs.tdm[1] the first "next" is Dec. 30 (doy - 1) + if(direction.filter=="backward"){ + # If we're filtering backward, and starting with Dec. 31 of yrs.tdm[1] the first "next" is Dec. 30 (doy - 1) # Jan 1 then needs the "next" pulled from the LAST row of yrs.tdm[2] row.last <- nrow(met.nxt$dat.source$time) dat.nxt2 <- data.frame(year = met.nxt$dat.train$time$Year[1], @@ -242,8 +245,6 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire # ----------------------------------- # 2. Predict met vars for each ensemble member - # Note: Right now this is only set up to do members sequentially, but there is - # potential to parallelize # ----------------------------------- ens.sims <- lm_ensemble_sims(dat.mod = dat.ens, n.ens = n.ens, @@ -258,7 +259,7 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire # Set up the lags for the next year # ----------------------------------- for(v in names(ens.sims)) { - lag.use <- ifelse(direction.filter=="backwards", 1, nrow(ens.sims[[v]])) + lag.use <- ifelse(direction.filter=="backward", 1, nrow(ens.sims[[v]])) lags.init[[v]] <- data.frame(ens.sims[[v]][lag.use,]) } # ----------------------------------- @@ -324,4 +325,6 @@ predict_subdaily_met <- function(outfolder, in.path, in.prefix, path.train, dire # ----------------------------------- } # End year loop + msg.done <- paste("Temporal Downscaling Complete:", in.prefix, min(yrs.tdm), "-", max(yrs.tdm), sep=" ") + return(msg.done) } # End function From fa7682e0b3af6ece731ed1454b850342d77f52ee Mon Sep 17 00:00:00 2001 From: Christy Rollinson Date: Tue, 19 Sep 2017 10:54:00 -0500 Subject: [PATCH 690/771] Clean up documentation --- .../man/gen.subdaily.models.Rd | 12 +++++------ .../data.atmosphere/man/lm_ensemble_sims.Rd | 4 ++-- .../man/predict_subdaily_met.Rd | 21 +++++++------------ 3 files changed, 16 insertions(+), 21 deletions(-) diff --git a/modules/data.atmosphere/man/gen.subdaily.models.Rd b/modules/data.atmosphere/man/gen.subdaily.models.Rd index 6683b42616f..c22e7e6c819 100644 --- a/modules/data.atmosphere/man/gen.subdaily.models.Rd +++ b/modules/data.atmosphere/man/gen.subdaily.models.Rd @@ -4,10 +4,10 @@ \alias{gen.subdaily.models} \title{gen.subdaily.models} \usage{ -gen.subdaily.models(outfolder, path.train, yrs.train, direction.filter, - in.prefix, n.beta, day.window, seed = Sys.time(), resids = FALSE, - parallel = FALSE, n.cores = NULL, overwrite = TRUE, verbose = FALSE, - print.progress = FALSE) +gen.subdaily.models(outfolder, path.train, yrs.train, + direction.filter = "forward", in.prefix, n.beta, day.window, + seed = Sys.time(), resids = FALSE, parallel = FALSE, n.cores = NULL, + overwrite = TRUE, verbose = FALSE, print.progress = FALSE) } \arguments{ \item{outfolder}{- directory where models will be stored *** storage required varies by size of training dataset, but prepare for >10 GB} @@ -17,8 +17,8 @@ gen.subdaily.models(outfolder, path.train, yrs.train, direction.filter, \item{yrs.train}{- which years of the training data should be used for to generate the model for the subdaily cycle. If NULL, will default to all years} -\item{direction.filter}{- Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") -(PalEON will go backwards, anybody interested in the future will go forwards)} +\item{direction.filter}{- Whether the model will be filtered backward or forward in time. options = c("backward", "forward") +(PalEON will go backward, anybody interested in the future will go forward)} \item{in.prefix}{} diff --git a/modules/data.atmosphere/man/lm_ensemble_sims.Rd b/modules/data.atmosphere/man/lm_ensemble_sims.Rd index 369dfa161d5..b617e016048 100644 --- a/modules/data.atmosphere/man/lm_ensemble_sims.Rd +++ b/modules/data.atmosphere/man/lm_ensemble_sims.Rd @@ -15,8 +15,8 @@ lm_ensemble_sims(dat.mod, n.ens, path.model, direction.filter, \item{path.model}{- path to where the training model & betas is stored} -\item{direction.filter}{- Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") -(PalEON will go backwards, anybody interested in the future will go forwards)} +\item{direction.filter}{- Whether the model will be filtered backward or forward in time. options = c("backward", "forward") +(PalEON will go backward, anybody interested in the future will go forward)} \item{lags.init}{- a data frame of initialization parameters to match the data in dat.mod} diff --git a/modules/data.atmosphere/man/predict_subdaily_met.Rd b/modules/data.atmosphere/man/predict_subdaily_met.Rd index 1dab917388b..ad85e5395dd 100644 --- a/modules/data.atmosphere/man/predict_subdaily_met.Rd +++ b/modules/data.atmosphere/man/predict_subdaily_met.Rd @@ -5,22 +5,23 @@ \title{predict_subdaily_met} \usage{ predict_subdaily_met(outfolder, in.path, in.prefix, path.train, - direction.filter, lm.models.base, yrs.predict = NULL, ens.labs = 1:3, - resids = FALSE, parallel = FALSE, cores.max = 12, n.cores = NULL, - overwrite = FALSE, verbose = FALSE, seed = format(Sys.time(), "\%m\%d"), - print.progress = FALSE, ...) + direction.filter = "forward", lm.models.base, yrs.predict = NULL, + ens.labs = 1:3, resids = FALSE, overwrite = FALSE, verbose = FALSE, + seed = format(Sys.time(), "\%m\%d"), print.progress = FALSE, ...) } \arguments{ \item{outfolder}{- directory where output file will be stored} -\item{in.path}{- path to model dataset you wish to temporally downscale} +\item{in.path}{- base path to dataset you wish to temporally downscale; Note: in order for parallelization +to work, the in.prefix will need to be appended as the final level of the file structure. +For example, if prefix is GFDL.CM3.rcp45.r1i1p1, there should be a directory with that title in in.path.} \item{in.prefix}{- prefix of model dataset, i.e. if file is GFDL.CM3.rcp45.r1i1p1.2006 the prefix is 'GFDL.CM3.rcp45.r1i1p1'} \item{path.train}{- path to CF/PEcAn style training data where each year is in a separate file.} -\item{direction.filter}{- Whether the model will be filtered backwards or forwards in time. options = c("backward", "forward") -(PalEON will go backwards, anybody interested in the future will go forwards)} +\item{direction.filter}{- Whether the model will be filtered backward or forwards in time. options = c("backward", "forwards") +(default is forward; PalEON will go backward, anybody interested in the future will go forwards)} \item{lm.models.base}{- path to linear regression model folders generated using gen.subdaily.models} @@ -31,12 +32,6 @@ ensemble rather than overwriting with a default naming scheme} \item{resids}{- logical stating whether to pass on residual data or not} -\item{parallel}{- logical stating whether to run temporal_downscale_functions.R in parallel} - -\item{cores.max}{- 12} - -\item{n.cores}{- deals with parallelization} - \item{seed}{- manually set seed for results to be reproducible} \item{print.progress}{- print the progress bar?} From 3091d1b180424c35a79ecc868b427cc3bd70d0fe Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 19 Sep 2017 11:49:13 -0500 Subject: [PATCH 691/771] Removed import.data.php --- web/import.data.php | 38 -------------------------------------- 1 file changed, 38 deletions(-) delete mode 100644 web/import.data.php diff --git a/web/import.data.php b/web/import.data.php deleted file mode 100644 index ba1df552e1d..00000000000 --- a/web/import.data.php +++ /dev/null @@ -1,38 +0,0 @@ - - - - Import Data - - - -

    Import Data

    -

    Either download data from DataONE or drag and drop locally stored files

    - - - - - - \ No newline at end of file From 77b76e4032435f365a429a27b875ccb7d52ebf7d Mon Sep 17 00:00:00 2001 From: LiamBurke24 Date: Tue, 19 Sep 2017 11:50:40 -0500 Subject: [PATCH 692/771] changelog --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 588eaddf549..9eed053c26e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,7 +6,7 @@ section for the next release. For more information about this file see also [Keep a Changelog](http://keepachangelog.com/) . ## [Unreleased] -- Defined Min_upload_level=3 +- Created new (and very rudimentary) web interface for downloading data from the dataone federation into the PEcAn database. More updates to come. ### Fixes - Show workflowid in the URL when run is finshed and user clicks results (#1659) From 681c4ec00960f4bf8747cf911238d3e4d97e4230 Mon Sep 17 00:00:00 2001 From: Michael Dietze Date: Tue, 19 Sep 2017 14:22:29 -0400 Subject: [PATCH 693/771] reworked read_web_config to return more results and to handle the substitution of output_folder into dbfiles_folder, which is what we need returned for file ingest Shiny --- base/utils/R/read_web_config.R | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/base/utils/R/read_web_config.R b/base/utils/R/read_web_config.R index 919eb7d9ffb..5f84caedaf0 100644 --- a/base/utils/R/read_web_config.R +++ b/base/utils/R/read_web_config.R @@ -12,13 +12,31 @@ read_web_config = function(php.config = "../../web/config.php") { ## Read PHP config file for webserver config <- scan(php.config, what = "character", sep = "\n") config <- config[grep("^\\$", config)] ## find lines that begin with $ (variables) + + ## replacements config <- sub("$", "", config, fixed = TRUE) ## remove $ config <- sub(";", "", config, fixed = TRUE) ## remove ; config <- sub("false", "FALSE", config, fixed = TRUE) ## Boolean capitalization config <- sub("true", "TRUE", config, fixed = TRUE) ## Boolean capitalization - config <- config[-grep("$", config, fixed = TRUE)] ## lines with variable references fail + config <- gsub(pattern = "DIRECTORY_SEPARATOR",replacement = "/",config) + + ## subsetting config <- config[-grep("exec", config, fixed = TRUE)] ## lines 'exec' fail - config.list <- eval(parse(text = paste("list(", paste0(config[1:14], collapse = ","), ")"))) + config <- config[-grep("dirname", config, fixed = TRUE)] ## lines 'dirname' fail + config <- config[-grep("array", config, fixed = TRUE)] ## lines 'array' fail + + ##references + ref <- grep("$", config, fixed = TRUE) + refsplit = strsplit(config[ref],split = " . ",fixed=TRUE)[[1]] + refsplit = sub(pattern = '\"',replacement = "",x = refsplit) + refsplit = sub(pattern = '$',replacement = '\"',refsplit,fixed=TRUE) + config[ref] <- paste0(refsplit,collapse = "") ## lines with variable references fail + + ## convert to list + config.list <- eval(parse(text = paste("list(", paste0(config, collapse = ","), ")"))) + + ## replacements + config.list <- lapply(X = config.list,FUN = sub,pattern="output_folder",replacement=config.list$output_folder,fixed=TRUE) return(config.list) } \ No newline at end of file From 572e827564e7750767cff5a1d2f6877e5f585376 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Tue, 19 Sep 2017 15:20:35 -0400 Subject: [PATCH 694/771] more examples --- .../Choosing-initial-vegetation.Rmd | 7 +- .../Choosing-meteorology.Rmd | 2 + .../Adding-an-Input-Converter.Rmd | 77 ++++++++++++++----- .../How-to-insert-new-Input-data.Rmd | 2 +- 4 files changed, 65 insertions(+), 23 deletions(-) diff --git a/book_source/basic_users_guide/Choosing-initial-vegetation.Rmd b/book_source/basic_users_guide/Choosing-initial-vegetation.Rmd index 806a78b08a7..bb37824363e 100644 --- a/book_source/basic_users_guide/Choosing-initial-vegetation.Rmd +++ b/book_source/basic_users_guide/Choosing-initial-vegetation.Rmd @@ -6,7 +6,7 @@ At the moment, PEcAn has two cases for initial conditions and they only exist as If files already exist in the database, they can simply be selected from the menu. For ED2, there are 3 different veg files (site, pss, css) and it is important that you select a complete set, not mix and match. -If files don't exist they can be uploaded following the instructions on [How to insert new Input data](../developers_guide/How-to-insert-new-Input-data.html). Information on the ED2-specific format is located [here](../../ED-configuration.md) +If files don't exist they can be uploaded following the instructions on [How to insert new Input data](../developers_guide/How-to-insert-new-Input-data.html). Two additional options are in development: @@ -31,6 +31,9 @@ As with meteorology, PEcAn is working to develop a model-agnostic workflow for c At the moment, what is functional is a model-specific workflow for the ED2 model that can query the USFS Forest Inventory and Analysis and then construct initial condition files for ED2. This tool works with an internal copy of the FIA that is uploaded to a postGRES database along side BETY, however for space reasons this database does not ship with the PEcAn VM. To turn this feature on: -1. [Download and Install the FIA database](../../developers_guide/Installing-PEcAn-Data.md) +1. [Download and Install the FIA database](../../developers_guide/Installing-PEcAn-Data.Rmd) 2. For web-base runs, specify the database settings in the [config.php](https://github.com/PecanProject/pecan/blob/master/web/config.example.php) 3. For R-based runs, specify the database settings in the [pecan.xml](../advanced_users_guide/PEcAn-Configuration.md#database-access) + +More detailed information on how PEcAn processes inputs can be found on our [Input Conversion] page. + diff --git a/book_source/basic_users_guide/Choosing-meteorology.Rmd b/book_source/basic_users_guide/Choosing-meteorology.Rmd index d9d7cd769cd..d4f38666d0e 100644 --- a/book_source/basic_users_guide/Choosing-meteorology.Rmd +++ b/book_source/basic_users_guide/Choosing-meteorology.Rmd @@ -19,6 +19,8 @@ Consider a generic met data product named MET for simplicity. PEcAn will use a f Once data is in the standard format and processed, it will be converted to the model-specific format using a met2model.MODEL function (located in that MODEL's module). +More detailed information on how PEcAn processes inputs can be found on our [Input Conversion] page. + ### Troubleshooting meteorological conversions At the current moment (PEcAn 1.4.0), most of the issues below address possible errors that the Ameriflux meteorology workflow might report diff --git a/book_source/developers_guide/Adding-an-Input-Converter.Rmd b/book_source/developers_guide/Adding-an-Input-Converter.Rmd index 4bc1f83a27b..46aedc14570 100755 --- a/book_source/developers_guide/Adding-an-Input-Converter.Rmd +++ b/book_source/developers_guide/Adding-an-Input-Converter.Rmd @@ -180,13 +180,63 @@ Vegetation data will be required to parameterize your model. In these examples w The main function to process cohort data is the `ic.process.R` function. As of now however, if you require pool data you will run a seperate function, `pool_ic_list2netcdf.R`. -#### Example 1: Raw data from a database +#### Example 1: Processing Veg data from data in hand. -If your data is coming from a datbase (ex.FIA) the section of your pecan.xml will need to look like the following: +In the following example we will process vegetation data that you have in hand using PEcAn. + +First, you'll need to create a input record in BETY that will have a file record and format record reflecting the location and format of your file. Instructions can be found in our [How to Insert new Input Data] page. + +Once you have created an input record you must take note of the input id of your record. An easy way to take note of this is in the URL of the BETY webpage that shows your input record. In this example we use an input record with the id `1000013064` which can be found at this url: https://psql-pecan.bu.edu/bety/inputs/1000013064# . Note that this is the Boston University BETY database. If you are on a different mahcine, your url will be different. + +With the input id in hand you can now edit a pean xml so that the PEcAn functoin `ic.process` will know where to look in order to process your data. The `inputs` section of your pecan xml will look like this. As of now ic.process is set up to work with the ED2 model so we will use ED2 settings and then grab the intermediary Rds data file that is created as the standard PEcAn file. For your Inputs section you will need to input your input id wherever you see the `source.ic` flag. ``` -paste inputs section here + + + FFT + css + pecan + 1000013064 + TRUE + + 1 + 70 + + + + FFT + pss + pecan + 1000013064 + TRUE + + + FFT + site + pecan + 1000013064 + TRUE + + + CRUNCEP + ED2 + + + 294 + + + 297 + + + 295 + + + 296 + + ``` -From here you read in the pecan.xml to obtain a settings object + +Once you edit your PEcAn.xml you can than create a settings object using PEcAn functions. Your `pecan.xml` must be in your working directory. + ``` settings <- PEcAn.settings::read.settings("pecan.xml") settings <- PEcAn.settings::prepare.settings(settings, force=FALSE) @@ -194,27 +244,14 @@ settings <- PEcAn.settings::prepare.settings(settings, force=FALSE) You can then execute the `ic.process` function to convert data into a standard Rds file: ``` -settings <- PEcAn.settings::read.settings("pecan.xml") -settings <- PEcAn.settings::prepare.settings(settings, force=FALSE) - +input <- settings$run$inputs +dir <- "." ic.process(settings, input, dir, overwrite = FALSE) - ``` -#### Example 2: Raw data in hand +Note that the argument `dir` is set to the current directory. You will find the final ED2 file there. More importantly though you will find the `.Rds ` file within thie same directory. -You will first need to update the BETY database with the appropriate records. A file record with location of the raw file, a format record with requisite meta data information about the structure of the file, and then an input record what has the file and format record assiciated with it. Instructions on how to do that can be found here [How to Insert new Input Data]. -Once that part is complete, you will need that input id in the pecan.xml. Edit your xml to look like this: - -``` -``` -Read in settings - -``` -ic.process(settings, input, dir, overwrite = FALSE) - -``` #### Example 3 Pool Initial Condition files diff --git a/book_source/developers_guide/How-to-insert-new-Input-data.Rmd b/book_source/developers_guide/How-to-insert-new-Input-data.Rmd index d733cb69c4d..810fc56bcd6 100755 --- a/book_source/developers_guide/How-to-insert-new-Input-data.Rmd +++ b/book_source/developers_guide/How-to-insert-new-Input-data.Rmd @@ -30,7 +30,7 @@ From your BETY interface: ## Create a Format Record -Creating a Format Record allow PEcAn to levereage Meta-data about your data in order to properly handle. It allows you to define what type of file it is by defining it's mimetype (i.e. text, netcdf,rds, etc.), define what information is hel in the header of your file, and how many lines need to be skipped within the file to get to ge to the header. To create a format record +Creating a Format Record allow PEcAn to levereage Meta-data about your data in order to properly handle it. It allows you to define what type of file it is by defining it's mimetype (i.e. text, netcdf,rds, etc.), define what information is hel in the header of your file, and how many lines need to be skipped within the file to get to ge to the header. To create a format record * Navigate to the Formats table in BETY under the RUNS tab. * Click "New Format" From b7fd3c83583ae70acd13fa611614fb03e90e3298 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Tue, 19 Sep 2017 15:24:10 -0400 Subject: [PATCH 695/771] drop some words --- book_source/developers_guide/How-to-insert-new-Input-data.Rmd | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/book_source/developers_guide/How-to-insert-new-Input-data.Rmd b/book_source/developers_guide/How-to-insert-new-Input-data.Rmd index 810fc56bcd6..84eec381e34 100755 --- a/book_source/developers_guide/How-to-insert-new-Input-data.Rmd +++ b/book_source/developers_guide/How-to-insert-new-Input-data.Rmd @@ -1,6 +1,6 @@ # How to Insert new Input Data -To upload model driver data or any other model input data or data used for model calibration/validation... +To upload model input data or data used for model calibration/validation... From your BETY interface: @@ -30,7 +30,7 @@ From your BETY interface: ## Create a Format Record -Creating a Format Record allow PEcAn to levereage Meta-data about your data in order to properly handle it. It allows you to define what type of file it is by defining it's mimetype (i.e. text, netcdf,rds, etc.), define what information is hel in the header of your file, and how many lines need to be skipped within the file to get to ge to the header. To create a format record +Creating a Format Record allows PEcAn to levereage Meta-data about your data in order to properly handle it. It allows you to define what type of file it is by defining it's mimetype (i.e. text, netcdf,rds, etc.), define what information is hel in the header of your file, and how many lines need to be skipped within the file to get to ge to the header. To create a format record * Navigate to the Formats table in BETY under the RUNS tab. * Click "New Format" From 0a0157a4d2195195f866b2f1203877acbbb47651 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Tue, 19 Sep 2017 15:35:52 -0400 Subject: [PATCH 696/771] spell check --- .../Adding-an-Input-Converter.Rmd | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/book_source/developers_guide/Adding-an-Input-Converter.Rmd b/book_source/developers_guide/Adding-an-Input-Converter.Rmd index 46aedc14570..0ff508ef264 100755 --- a/book_source/developers_guide/Adding-an-Input-Converter.Rmd +++ b/book_source/developers_guide/Adding-an-Input-Converter.Rmd @@ -11,7 +11,7 @@ Downloading raw data function are named `download..R`. These functions a Conversion function from raw to standard are named `met2CF..R`. These functions are stored within the PEcAn directory: [`/modules/data.atmosphere/R`](https://github.com/PecanProject/pecan/tree/develop/modules/data.atmosphere/R). -Current Meteorological products that are coupled to PEcAn can be found in our [Available Meterological Drivers] page. +Current Meteorological products that are coupled to PEcAn can be found in our [Available Meteorological Drivers] page. Note: Unless you are also adding a new model, you will not need to write a script to convert from PEcAn standard to PEcAn models. Those conversion scripts are written when a model is added and can be found within each model's PEcAn directory. @@ -86,7 +86,7 @@ raw.file <-PEcAn.data.atmosphere::download.AmerifluxLBL(sitename = "US-NR1", Using the information returned as the object `raw.file` you will then convert the raw files into a standard file. -Open a connection with BETY. You may need to change the host name depending on what mahcine you are hosting BETY. You can find the hostname listed in the machines table of BETY. +Open a connection with BETY. You may need to change the host name depending on what machine you are hosting BETY. You can find the hostname listed in the machines table of BETY. ``` @@ -133,9 +133,9 @@ If you have Met data already in hand and you would like to convert into the PEcA Update BETY with file record, format record and input record according to this page [How to Insert new Input Data] -If your data is in a csv formate you can use the `met2CF.csv`function to convert your data into a PEcAn standard file. +If your data is in a csv format you can use the `met2CF.csv`function to convert your data into a PEcAn standard file. -Open a connection with BETY. You may need to change the host name depending on what mahcine you are hosting BETY. You can find the hostname listed in the machines table of BETY. +Open a connection with BETY. You may need to change the host name depending on what machine you are hosting BETY. You can find the hostname listed in the machines table of BETY. ``` bety <- dplyr::src_postgres(dbname = 'bety', @@ -178,7 +178,7 @@ PEcAn.data.atmosphere::met2CF.csv(in.path = in.path, Vegetation data will be required to parameterize your model. In these examples we will go over how to produce a standard initial condition file. -The main function to process cohort data is the `ic.process.R` function. As of now however, if you require pool data you will run a seperate function, `pool_ic_list2netcdf.R`. +The main function to process cohort data is the `ic.process.R` function. As of now however, if you require pool data you will run a separate function, `pool_ic_list2netcdf.R`. #### Example 1: Processing Veg data from data in hand. @@ -186,9 +186,9 @@ In the following example we will process vegetation data that you have in hand u First, you'll need to create a input record in BETY that will have a file record and format record reflecting the location and format of your file. Instructions can be found in our [How to Insert new Input Data] page. -Once you have created an input record you must take note of the input id of your record. An easy way to take note of this is in the URL of the BETY webpage that shows your input record. In this example we use an input record with the id `1000013064` which can be found at this url: https://psql-pecan.bu.edu/bety/inputs/1000013064# . Note that this is the Boston University BETY database. If you are on a different mahcine, your url will be different. +Once you have created an input record you must take note of the input id of your record. An easy way to take note of this is in the URL of the BETY webpage that shows your input record. In this example we use an input record with the id `1000013064` which can be found at this url: https://psql-pecan.bu.edu/bety/inputs/1000013064# . Note that this is the Boston University BETY database. If you are on a different machine, your url will be different. -With the input id in hand you can now edit a pean xml so that the PEcAn functoin `ic.process` will know where to look in order to process your data. The `inputs` section of your pecan xml will look like this. As of now ic.process is set up to work with the ED2 model so we will use ED2 settings and then grab the intermediary Rds data file that is created as the standard PEcAn file. For your Inputs section you will need to input your input id wherever you see the `source.ic` flag. +With the input id in hand you can now edit a pecan XML so that the PEcAn function `ic.process` will know where to look in order to process your data. The `inputs` section of your pecan XML will look like this. As of now ic.process is set up to work with the ED2 model so we will use ED2 settings and then grab the intermediary Rds data file that is created as the standard PEcAn file. For your Inputs section you will need to input your input id wherever you see the `source.ic` flag. ``` @@ -249,7 +249,7 @@ dir <- "." ic.process(settings, input, dir, overwrite = FALSE) ``` -Note that the argument `dir` is set to the current directory. You will find the final ED2 file there. More importantly though you will find the `.Rds ` file within thie same directory. +Note that the argument `dir` is set to the current directory. You will find the final ED2 file there. More importantly though you will find the `.Rds ` file within the same directory. From 32ad625f0683a91090490d5995542254c280c4cd Mon Sep 17 00:00:00 2001 From: David LeBauer Date: Wed, 20 Sep 2017 17:38:25 -0500 Subject: [PATCH 697/771] Added BETYdb to list of publications --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index 9c8470b2fa2..87de5117cdf 100644 --- a/README.md +++ b/README.md @@ -46,6 +46,7 @@ The demo instance only allows for runs at pecan.ncsa.illinois.edu. Once you have * Dietze, Michael C., Shawn P. Serbin, Carl Davidson, Ankur R. Desai, Xiaohui Feng, Ryan Kelly, Rob Kooper et al. "A quantitative assessment of a terrestrial biosphere model's data needs across North American biomes." Journal of Geophysical Research: Biogeosciences 119, no. 3 (2014): 286-300. * Viskari, Toni, Brady Hardiman, Ankur R. Desai, and Michael C. Dietze. "Model-data assimilation of multiple phenological observations to constrain and predict leaf area index." (2015) [doi:10.1890/14-0497.1](http://dx.doi.org/10.1890/14-0497.1) * Shiklomanov. A, MC Dietze, T Viskari, PA Townsend, SP Serbin. 2016 "Quantifying the influences of spectral resolution on uncertainty in leaf trait estimates through a Bayesian approach to RTM inversion" Remote Sensing of the Environment 183: 226-238 +* LeBauer, David, Rob Kooper, Patrick Mulrooney, Scott Rohde, Dan Wang, Stephen P. Long, and Michael C. Dietze. "BETYdb: a yield, trait, and ecosystem service database applied to second‐generation bioenergy feedstock production." GCB Bioenergy (2017). ## Acknowledgements From c4567dd72ba518cbfa31e4cb49aa86863fb84450 Mon Sep 17 00:00:00 2001 From: Rob Kooper Date: Thu, 21 Sep 2017 09:51:23 -0500 Subject: [PATCH 698/771] fix circular dependency --- base/remote/DESCRIPTION | 1 - base/remote/R/is.localhost.R | 7 +++++-- base/remote/R/remote.execute.R.R | 2 +- base/remote/R/remote.execute.cmd.R | 2 +- 4 files changed, 7 insertions(+), 5 deletions(-) diff --git a/base/remote/DESCRIPTION b/base/remote/DESCRIPTION index c585810b73d..62133b1b525 100644 --- a/base/remote/DESCRIPTION +++ b/base/remote/DESCRIPTION @@ -7,7 +7,6 @@ Maintainer: Alexey Shiklomanov Description: This package contains utilities for communicating with and executing code on local and remote hosts. In particular, it has PEcAn-specific utilities for starting ecosystem model runs. Imports: - PEcAn.utils, PEcAn.logger Suggests: tools, diff --git a/base/remote/R/is.localhost.R b/base/remote/R/is.localhost.R index 8b32c190f56..32da1b4b533 100644 --- a/base/remote/R/is.localhost.R +++ b/base/remote/R/is.localhost.R @@ -11,10 +11,13 @@ #' @examples #' is.localhost(fqdn()) is.localhost <- function(host) { + # PEcAn.utils::fqdn() would result in a circular dependency. + fqdn <- system2("hostname", "-f", stdout = TRUE) + if (is.character(host)) { - return((host == "localhost") || (host == PEcAn.utils::fqdn())) + return((host == "localhost") || (host == fqdn)) } else if (is.list(host)) { - return((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) + return((host$name == "localhost") || (host$name == fqdn)) } else { return(FALSE) } diff --git a/base/remote/R/remote.execute.R.R b/base/remote/R/remote.execute.R.R index 12bb3b95e5e..36c104d86a7 100644 --- a/base/remote/R/remote.execute.R.R +++ b/base/remote/R/remote.execute.R.R @@ -32,7 +32,7 @@ remote.execute.R <- function(script, host = "localhost", user = NA, verbose = FA paste0("ign <- serialize(remoteout, fp)"), "close(fp)") verbose <- ifelse(as.logical(verbose), "", FALSE) - if ((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) { + if (is.localhost(host)) { if (R == "R") { Rbinary <- file.path(Sys.getenv("R_HOME"), "bin", "R") if (file.exists(Rbinary)) { diff --git a/base/remote/R/remote.execute.cmd.R b/base/remote/R/remote.execute.cmd.R index fbfa5c11630..3ee63401fa9 100644 --- a/base/remote/R/remote.execute.cmd.R +++ b/base/remote/R/remote.execute.cmd.R @@ -22,7 +22,7 @@ remote.execute.cmd <- function(host, cmd, args = character(), stderr = FALSE) { host <- list(name = host) } - if ((host$name == "localhost") || (host$name == PEcAn.utils::fqdn())) { + if (is.localhost(host)) { PEcAn.logger::logger.debug(paste(c(cmd, args), collapse = ' ')) system2(cmd, args, stdout = TRUE, stderr = as.logical(stderr)) } else { From c2e17905b5d42f23a7d5896153d10b92fadd4128 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 21 Sep 2017 22:34:02 -0400 Subject: [PATCH 699/771] fix wood_carbon_content assignment --- modules/data.land/R/prepare_pools.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.land/R/prepare_pools.R b/modules/data.land/R/prepare_pools.R index 0838dee7558..5adae3f2cd1 100644 --- a/modules/data.land/R/prepare_pools.R +++ b/modules/data.land/R/prepare_pools.R @@ -22,7 +22,7 @@ prepare_pools <- function(nc.path, constants = NULL){ TotLivBiom <- IC.list$vals$TotLivBiom leaf <- IC.list$vals$leaf_carbon_content LAI <- IC.list$vals$LAI - wood <- wood_carbon_content + wood <- IC.list$vals$wood_carbon_content AbvGrndWood <- IC.list$vals$AbvGrndWood roots <- IC.list$vals$root_carbon_content fine.roots <- IC.list$vals$fine_root_carbon_content From 54a861e9ef434037814d0daf5a9534e486715c80 Mon Sep 17 00:00:00 2001 From: annethomas Date: Thu, 21 Sep 2017 22:40:28 -0400 Subject: [PATCH 700/771] missing colon --- models/sipnet/R/write.configs.SIPNET.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/sipnet/R/write.configs.SIPNET.R b/models/sipnet/R/write.configs.SIPNET.R index 73fbd9d7956..a106e6991c3 100644 --- a/models/sipnet/R/write.configs.SIPNET.R +++ b/models/sipnet/R/write.configs.SIPNET.R @@ -367,7 +367,7 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs IC.nc <- ncdf4::nc_open(IC.path) #for additional variables specific to SIPNET ## plantWoodInit gC/m2 if ("wood" %in% names(IC.pools)) { - param[which(param[, 1] == "plantWoodInit"), 2] <- udunits2:ud.convert(IC.pools$wood, "kg m-2", "g m-2") + param[which(param[, 1] == "plantWoodInit"), 2] <- udunits2::ud.convert(IC.pools$wood, "kg m-2", "g m-2") } ## laiInit m2/m2 lai <- try(ncdf4::ncvar_get(IC.nc,"LAI"),silent = TRUE) From 843394630430fb2ec290b993bc70d313b963ca28 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 14 Sep 2017 14:55:47 -0400 Subject: [PATCH 701/771] remove PEcAn.utils::model2netcdf ...which has been deprecated since 1.3.7 --- base/utils/NAMESPACE | 1 - base/utils/R/read.output.R | 61 ------------------------------- base/utils/man/model2netcdf.Rd | 37 ------------------- base/utils/man/model2netcdfdep.Rd | 37 ------------------- 4 files changed, 136 deletions(-) delete mode 100644 base/utils/man/model2netcdf.Rd delete mode 100644 base/utils/man/model2netcdfdep.Rd diff --git a/base/utils/NAMESPACE b/base/utils/NAMESPACE index 3cf5c48a44c..feb6f012f6a 100644 --- a/base/utils/NAMESPACE +++ b/base/utils/NAMESPACE @@ -50,7 +50,6 @@ export(logger.warn) export(mcmc.list2init) export(misc.are.convertible) export(misc.convert) -export(model2netcdf) export(mstmipvar) export(n_leap_day) export(paste.stats) diff --git a/base/utils/R/read.output.R b/base/utils/R/read.output.R index 44f72d02ab4..cf19465e5a2 100644 --- a/base/utils/R/read.output.R +++ b/base/utils/R/read.output.R @@ -7,67 +7,6 @@ # http://opensource.ncsa.illinois.edu/license.html #------------------------------------------------------------------------------- -##' Convert output for a single model run to NetCDF -##' -##' DEPRECATED this function will be removed in future versions, please update -##' your workflow. -##' -##' This function is a wrapper for model-specific conversion functions, -##' e.g. \code{model2netcdf.ED2}, \code{model2netcdf.BIOCRO}. -##' @title Convert model output to NetCDF -##' @param runid -##' @param outdir -##' @param model name of simulation model currently accepts ('ED2', 'SIPNET', 'BIOCRO') -##' @param lat Latitude of the site -##' @param lon Longitude of the site -##' @param start_date Start time of the simulation -##' @param end_date End time of the simulation -##' @return vector of filenames created, converts model output to netcdf as a side effect -##' @author Mike Dietze, David LeBauer -model2netcdfdep <- function(runid, outdir, model, lat, lon, start_date, end_date) { - ## load model-specific PEcAn module - do.call(require, list(paste0("PEcAn.", model))) - - model2nc <- paste("model2netcdf", model, sep = ".") - if (!exists(model2nc)) { - PEcAn.logger::logger.warn("File conversion function model2netcdf does not exist for", model) - return(NA) - } - - do.call(model2nc, list(outdir, lat, lon, start_date, end_date)) - - print(paste("Output from run", runid, "has been converted to netCDF")) - ncfiles <- list.files(path = outdir, pattern = "\\.nc$", full.names = TRUE) - if (length(ncfiles) == 0) { - PEcAn.logger::logger.severe("Conversion of model files to netCDF unsuccessful") - } - return(ncfiles) -} # model2netcdfdep - - -##' Convert output for a single model run to NetCDF -##' -##' DEPRECATED this function will be removed in future versions, please update -##' your workflow. -##' -##' This function is a wrapper for model-specific conversion functions, -##' e.g. \code{model2netcdf.ED2}, \code{model2netcdf.BIOCRO}. -##' @title Convert model output to NetCDF -##' @param runid -##' @param outdir -##' @param model name of simulation model currently accepts ('ED2', 'SIPNET', 'BIOCRO') -##' @param lat Latitude of the site -##' @param lon Longitude of the site -##' @param start_date Start time of the simulation -##' @param end_date End time of the simulation -##' @export -##' @return vector of filenames created, converts model output to netcdf as a side effect -##' @author Mike Dietze, David LeBauer -model2netcdf <- function(runid, outdir, model, lat, lon, start_date, end_date) { - PEcAn.logger::logger.severe("model2netcdf will be removed in future versions, plase update your worklow") -} # model2netcdf - - ##' Reads the output of a single model run ##' ##' Generic function to convert model output from model-specific format to diff --git a/base/utils/man/model2netcdf.Rd b/base/utils/man/model2netcdf.Rd deleted file mode 100644 index 95b586fa891..00000000000 --- a/base/utils/man/model2netcdf.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/read.output.R -\name{model2netcdf} -\alias{model2netcdf} -\title{Convert model output to NetCDF} -\usage{ -model2netcdf(runid, outdir, model, lat, lon, start_date, end_date) -} -\arguments{ -\item{runid}{} - -\item{model}{name of simulation model currently accepts ('ED2', 'SIPNET', 'BIOCRO')} - -\item{lat}{Latitude of the site} - -\item{lon}{Longitude of the site} - -\item{start_date}{Start time of the simulation} - -\item{end_date}{End time of the simulation} -} -\value{ -vector of filenames created, converts model output to netcdf as a side effect -} -\description{ -Convert output for a single model run to NetCDF -} -\details{ -DEPRECATED this function will be removed in future versions, please update -your workflow. - -This function is a wrapper for model-specific conversion functions, -e.g. \code{model2netcdf.ED2}, \code{model2netcdf.BIOCRO}. -} -\author{ -Mike Dietze, David LeBauer -} diff --git a/base/utils/man/model2netcdfdep.Rd b/base/utils/man/model2netcdfdep.Rd deleted file mode 100644 index fff1d16e86e..00000000000 --- a/base/utils/man/model2netcdfdep.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/read.output.R -\name{model2netcdfdep} -\alias{model2netcdfdep} -\title{Convert model output to NetCDF} -\usage{ -model2netcdfdep(runid, outdir, model, lat, lon, start_date, end_date) -} -\arguments{ -\item{runid}{} - -\item{model}{name of simulation model currently accepts ('ED2', 'SIPNET', 'BIOCRO')} - -\item{lat}{Latitude of the site} - -\item{lon}{Longitude of the site} - -\item{start_date}{Start time of the simulation} - -\item{end_date}{End time of the simulation} -} -\value{ -vector of filenames created, converts model output to netcdf as a side effect -} -\description{ -Convert output for a single model run to NetCDF -} -\details{ -DEPRECATED this function will be removed in future versions, please update -your workflow. - -This function is a wrapper for model-specific conversion functions, -e.g. \code{model2netcdf.ED2}, \code{model2netcdf.BIOCRO}. -} -\author{ -Mike Dietze, David LeBauer -} From 31fcb4852785b0ff7f158e6a00f08785bd33db04 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 14 Sep 2017 18:21:46 -0400 Subject: [PATCH 702/771] use :: for all namespaces --- base/utils/DESCRIPTION | 27 +++++++++++----- base/utils/NAMESPACE | 1 - base/utils/R/SafeList.R | 4 +-- base/utils/R/convert.input.R | 47 ++++++++++++++-------------- base/utils/R/download.url.R | 6 ++-- base/utils/R/ensemble.R | 29 +++++++++-------- base/utils/R/get.parameter.samples.R | 3 +- base/utils/R/get.results.R | 6 ++-- base/utils/R/mcmc.list2init.R | 2 +- base/utils/R/plots.R | 46 +++++++++++++-------------- base/utils/R/r2bugs.distributions.R | 5 ++- base/utils/R/read.output.R | 9 +++--- base/utils/R/regrid.R | 18 +++++------ base/utils/R/run.write.configs.R | 12 +++---- base/utils/R/sensitivity.R | 22 ++++++------- base/utils/R/status.R | 2 +- base/utils/R/transformstats.R | 8 ++--- base/utils/R/utils.R | 18 +++++------ base/utils/R/write.config.utils.R | 4 +-- base/utils/man/dhist.Rd | 5 +-- 20 files changed, 140 insertions(+), 134 deletions(-) diff --git a/base/utils/DESCRIPTION b/base/utils/DESCRIPTION index 4866536f945..9ed342bd7a6 100644 --- a/base/utils/DESCRIPTION +++ b/base/utils/DESCRIPTION @@ -14,15 +14,28 @@ Description: The Predictive Ecosystem Carbon Analyzer PEcAn is to streamline the interaction between data and models, and to improve the efficacy of scientific investigation. -Depends: - XML, - ggplot2, - randtoolbox, - abind, - RCurl Imports: + assertthat, + data.table, + getPass, + ggplot2, + methods, + PEcAn.data.atmosphere, + PEcAn.data.land, + PEcAn.DB, + PEcAn.emulator, PEcAn.logger, + PEcAn.priors, PEcAn.remote, + PEcAn.settings, + randtoolbox, + raster, + RCurl, + rjags, + sp, + stringi, + xtable, + XML, abind (>= 1.4.5), coda (>= 0.18), lubridate (>= 1.6.0), @@ -31,9 +44,7 @@ Imports: PeriodicTable, udunits2 (>= 0.11) Suggests: - coda, MASS, - ncdf4, testthat License: FreeBSD + file LICENSE Copyright: Authors diff --git a/base/utils/NAMESPACE b/base/utils/NAMESPACE index feb6f012f6a..c56d99f9ad1 100644 --- a/base/utils/NAMESPACE +++ b/base/utils/NAMESPACE @@ -85,7 +85,6 @@ export(vecpaste) export(write.ensemble.configs) export(write.sa.configs) export(zero.truncate) -import(randtoolbox) importFrom(PEcAn.logger,logger.debug) importFrom(PEcAn.logger,logger.error) importFrom(PEcAn.logger,logger.getLevel) diff --git a/base/utils/R/SafeList.R b/base/utils/R/SafeList.R index ce52192ed30..547f123c8dc 100644 --- a/base/utils/R/SafeList.R +++ b/base/utils/R/SafeList.R @@ -26,7 +26,7 @@ SafeList <- function(...) { result <- list(...) if (length(result) == 1) { - if (is(result[[1]], "SafeList")) { + if (methods::is(result[[1]], "SafeList")) { return(result[[1]]) } else if (is.list(result[[1]])) { result <- result[[1]] @@ -46,7 +46,7 @@ as.SafeList <- function(x) { ##' @export is.SafeList <- function(x) { - return(is(x, "SafeList")) + return(methods::is(x, "SafeList")) } # is.SafeList diff --git a/base/utils/R/convert.input.R b/base/utils/R/convert.input.R index 710f861e0a8..42ad6b7e1e5 100644 --- a/base/utils/R/convert.input.R +++ b/base/utils/R/convert.input.R @@ -23,7 +23,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st outfolder <- paste0(outfolder, "/") } - outname <- tail(unlist(strsplit(outfolder, "/")), n = 1) + outname <- utils::tail(unlist(strsplit(outfolder, "/")), n = 1) PEcAn.logger::logger.info(paste("start CHECK Convert.Inputs", fcn, input.id, host$name, outfolder, formatname, mimetype, site.id, start_date, end_date)) @@ -35,7 +35,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st # Find Existing input with exact dates. - existing.dbfile <- dbfile.input.check(siteid = site.id, + existing.dbfile <- PEcAn.DB::dbfile.input.check(siteid = site.id, mimetype = mimetype, formatname = formatname, parentid = input.id, @@ -59,7 +59,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st if (nrow(existing.dbfile) > 0) { - existing.input <- db.query(paste0("SELECT * FROM inputs WHERE id=", existing.dbfile[["container_id"]]),con) + existing.input <- PEcAn.DB::db.query(paste0("SELECT * FROM inputs WHERE id=", existing.dbfile[["container_id"]]),con) # Convert dates to Date objects and strip all time zones # (DB values are timezone-free) @@ -103,12 +103,12 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st #Grab machine info of file that exists - existing.machine <- db.query(paste0("SELECT * from machines where id = '", + existing.machine <- PEcAn.DB::db.query(paste0("SELECT * from machines where id = '", existing.dbfile$machine_id, "'"), con) #Grab machine info of host machine machine.host <- ifelse(host$name == "localhost", PEcAn.utils::fqdn(), host$name) - machine <- db.query(paste0("SELECT * from machines where hostname = '", + machine <- PEcAn.DB::db.query(paste0("SELECT * from machines where hostname = '", machine.host, "'"), con) if (existing.machine$id != machine$id) { @@ -134,7 +134,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st } else { - existing.dbfile <- dbfile.input.check(siteid = site.id, + existing.dbfile <- PEcAn.DB::dbfile.input.check(siteid = site.id, mimetype = mimetype, formatname = formatname, parentid = input.id, @@ -155,7 +155,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st if (nrow(existing.dbfile) > 0) { - existing.input <- db.query(paste0("SELECT * FROM inputs WHERE id=", existing.dbfile[["container_id"]]),con) + existing.input <- PEcAn.DB::db.query(paste0("SELECT * FROM inputs WHERE id=", existing.dbfile[["container_id"]]),con) # Convert dates to Date objects and strip all time zones @@ -201,12 +201,12 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st (end_date <= existing.input$end_date)) { #Grab machine info of file that exists - existing.machine <- db.query(paste0("SELECT * from machines where id = '", + existing.machine <- PEcAn.DB::db.query(paste0("SELECT * from machines where id = '", existing.dbfile$machine_id, "'"), con) #Grab machine info of machine.host <- ifelse(host$name == "localhost", PEcAn.utils::fqdn(), host$name) - machine <- db.query(paste0("SELECT * from machines where hostname = '", + machine <- PEcAn.DB::db.query(paste0("SELECT * from machines where hostname = '", machine.host, "'"), con) if(existing.machine$id != machine$id){ @@ -251,7 +251,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st # Get machine information machine.host <- ifelse(host$name == "localhost", PEcAn.utils::fqdn(), host$name) - machine <- db.query(paste0("SELECT * from machines where hostname = '", + machine <- PEcAn.DB::db.query(paste0("SELECT * from machines where hostname = '", machine.host, "'"), con) if (nrow(machine) == 0) { @@ -262,13 +262,13 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st if (missing(input.id) || is.na(input.id) || is.null(input.id)) { input <- dbfile <- NULL } else { - input <- db.query(paste("SELECT * from inputs where id =", input.id), con) + input <- PEcAn.DB::db.query(paste("SELECT * from inputs where id =", input.id), con) if (nrow(input) == 0) { PEcAn.logger::logger.error("input not found", input.id) return(NULL) } - dbfile <- db.query(paste("SELECT * from dbfiles where container_id =", input.id, + dbfile <- PEcAn.DB::db.query(paste("SELECT * from dbfiles where container_id =", input.id, " and container_type = 'Input' and machine_id =", machine$id), con) if (nrow(dbfile) == 0) { PEcAn.logger::logger.error("dbfile not found", input.id) @@ -286,7 +286,6 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st if (!is.null(browndog) && host$name == "localhost") { # perform conversions with Brown Dog - only works locally right now - library(RCurl) # Determine outputtype using formatname and mimetype of output file Add issue to # github that extension of formats table to include outputtype Convert to netcdf @@ -317,7 +316,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st curloptions <- c(curloptions, followlocation = TRUE) # check if we can do conversion - out.html <- getURL(paste0("http://dap-dev.ncsa.illinois.edu:8184/inputs/", + out.html <- RCurl::getURL(paste0("http://dap-dev.ncsa.illinois.edu:8184/inputs/", browndog$inputtype), .opts = curloptions) if (outputtype %in% unlist(strsplit(out.html, "\n"))) { PEcAn.logger::logger.info(paste("Conversion from", browndog$inputtype, "to", outputtype, @@ -342,8 +341,8 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st } # post zipped file to Brown Dog - html <- postForm(url, fileData = fileUpload(zipfile), .opts = curloptions) - link <- getHTMLLinks(html) + html <- RCurl::postForm(url, fileData = RCurl::fileUpload(zipfile), .opts = curloptions) + link <- XML::getHTMLLinks(html) file.remove(zipfile) # download converted file @@ -352,9 +351,9 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st # unzip downloaded file if necessary if (file.exists(outfile)) { - if (tail(unlist(strsplit(outfile, "[.]")), 1) == "zip") { - fname <- unzip(outfile, list = TRUE)$Name - unzip(outfile, files = fname, exdir = outfolder, overwrite = TRUE) + if (utils::tail(unlist(strsplit(outfile, "[.]")), 1) == "zip") { + fname <- utils::unzip(outfile, list = TRUE)$Name + utils::unzip(outfile, files = fname, exdir = outfolder, overwrite = TRUE) file.remove(outfile) } else { fname <- list.files(outfolder) @@ -425,7 +424,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st if (exists("existing.input") && nrow(existing.input) > 0 && (existing.input$start_date != start_date || existing.input$end_date != end_date)) { # Updating record with new dates - db.query(paste0("UPDATE inputs SET start_date='", start_date, "', end_date='", + PEcAn.DB::db.query(paste0("UPDATE inputs SET start_date='", start_date, "', end_date='", end_date, "' WHERE id=", existing.input$id), con) #Record has been updated and file downloaded so just return existing dbfile and input pair @@ -436,11 +435,11 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st # A bit hacky, but need to make sure that all fields are updated to expected # values (i.e., what they'd be if convert.input was creating a new record) if (exists("existing.input") && nrow(existing.input) > 0) { - db.query(paste0("UPDATE inputs SET name='", basename(dirname(result$file[1])), + PEcAn.DB::db.query(paste0("UPDATE inputs SET name='", basename(dirname(result$file[1])), "' WHERE id=", existing.input$id), con) } if (exists("existing.dbfile") && nrow(existing.dbfile) > 0) { - db.query(paste0("UPDATE dbfiles SET file_path='", dirname(result$file[1]), + PEcAn.DB::db.query(paste0("UPDATE dbfiles SET file_path='", dirname(result$file[1]), "', ", "file_name='", result$dbfile.name[1], "' WHERE id=", existing.dbfile$id), con) } @@ -453,7 +452,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st } if (insert.new.file) { - dbfile.id <- dbfile.insert(in.path = dirname(result$file[1]), + dbfile.id <- PEcAn.DB::dbfile.insert(in.path = dirname(result$file[1]), in.prefix = result$dbfile.name[1], 'Input', existing.input$id, con, reuse=TRUE, hostname = machine$hostname) @@ -461,7 +460,7 @@ convert.input <- function(input.id, outfolder, formatname, mimetype, site.id, st newinput$input.id <- existing.input$id newinput$dbfile.id <- dbfile.id } else { - newinput <- dbfile.input.insert(in.path = dirname(result$file[1]), + newinput <- PEcAn.DB::dbfile.input.insert(in.path = dirname(result$file[1]), in.prefix = result$dbfile.name[1], siteid = site.id, startdate = start_date, diff --git a/base/utils/R/download.url.R b/base/utils/R/download.url.R index e11a51d5250..e99b31b8d04 100644 --- a/base/utils/R/download.url.R +++ b/base/utils/R/download.url.R @@ -23,15 +23,15 @@ download.url <- function(url, file, timeout = 600, .opts = list(), retry404 = TRUE) { dir.create(basename(file), recursive = TRUE) count <- 0 - while (!url.exists(url, .opts = .opts) && count < timeout) { + while (!RCurl::url.exists(url, .opts = .opts) && count < timeout) { count <- count + 1 Sys.sleep(1) } if (count >= timeout) { return(NA) } - f <- CFILE(file, mode = "wb") - curlPerform(url = url, writedata = f@ref, .opts = .opts) + f <- RCurl::CFILE(file, mode = "wb") + RCurl::curlPerform(url = url, writedata = f@ref, .opts = .opts) RCurl::close(f) return(file) diff --git a/base/utils/R/ensemble.R b/base/utils/R/ensemble.R index 08bb77ba93e..960a248bfbf 100644 --- a/base/utils/R/ensemble.R +++ b/base/utils/R/ensemble.R @@ -72,7 +72,6 @@ read.ensemble.output <- function(ensemble.size, pecandir, outdir, start.year, en ##' @param method the method used to generate the ensemble samples. Random generators: uniform, uniform with latin hypercube permutation. Quasi-random generators: halton, sobol, torus. Random generation draws random variates whereas quasi-random generation is deterministic but well equidistributed. Default is uniform. For small ensemble size with relatively large parameter number (e.g ensemble size < 5 and # of traits > 5) use methods other than halton. ##' @return matrix of (quasi-)random samples from trait distributions ##' @export -##' @import randtoolbox ##' @author David LeBauer get.ensemble.samples <- function(ensemble.size, pft.samples, env.samples, method = "uniform", ...) { @@ -101,32 +100,32 @@ get.ensemble.samples <- function(ensemble.size, pft.samples, env.samples, if (method == "halton") { PEcAn.logger::logger.info("Using ", method, "method for sampling") - random.samples <- halton(n = ensemble.size, dim = total.sample.num, ...) + random.samples <- randtoolbox::halton(n = ensemble.size, dim = total.sample.num, ...) ## force as a matrix in case length(samples)=1 random.samples <- as.matrix(random.samples) } else if (method == "sobol") { PEcAn.logger::logger.info("Using ", method, "method for sampling") - random.samples <- sobol(n = ensemble.size, dim = total.sample.num, ...) + random.samples <- randtoolbox::sobol(n = ensemble.size, dim = total.sample.num, ...) ## force as a matrix in case length(samples)=1 random.samples <- as.matrix(random.samples) } else if (method == "torus") { PEcAn.logger::logger.info("Using ", method, "method for sampling") - random.samples <- torus(n = ensemble.size, dim = total.sample.num, ...) + random.samples <- randtoolbox::torus(n = ensemble.size, dim = total.sample.num, ...) ## force as a matrix in case length(samples)=1 random.samples <- as.matrix(random.samples) } else if (method == "lhc") { PEcAn.logger::logger.info("Using ", method, "method for sampling") - random.samples <- lhc(t(matrix(0:1, ncol = total.sample.num, nrow = 2)), ensemble.size) + random.samples <- PEcAn.emulator::lhc(t(matrix(0:1, ncol = total.sample.num, nrow = 2)), ensemble.size) } else if (method == "uniform") { PEcAn.logger::logger.info("Using ", method, "random sampling") # uniform random - random.samples <- matrix(runif(ensemble.size * total.sample.num), + random.samples <- matrix(stats::runif(ensemble.size * total.sample.num), ensemble.size, total.sample.num) } else { PEcAn.logger::logger.info("Method ", method, " has not been implemented yet, using uniform random sampling") # uniform random - random.samples <- matrix(runif(ensemble.size * total.sample.num), + random.samples <- matrix(stats::runif(ensemble.size * total.sample.num), ensemble.size, total.sample.num) } @@ -138,7 +137,7 @@ get.ensemble.samples <- function(ensemble.size, pft.samples, env.samples, ensemble.samples[[pft.i]] <- matrix(nrow = ensemble.size, ncol = length(pft.samples[[pft.i]])) for (trait.i in seq(pft.samples[[pft.i]])) { col.i <- col.i + 1 - ensemble.samples[[pft.i]][, trait.i] <- quantile(pft.samples[[pft.i]][[trait.i]], + ensemble.samples[[pft.i]][, trait.i] <- stats::quantile(pft.samples[[pft.i]][[trait.i]], random.samples[, col.i]) } # end trait ensemble.samples[[pft.i]] <- as.data.frame(ensemble.samples[[pft.i]]) @@ -176,11 +175,11 @@ write.ensemble.configs <- function(defaults, ensemble.samples, settings, model, # Open connection to database so we can store all run/ensemble information if (write.to.db) { - con <- try(db.open(settings$database$bety), silent = TRUE) - if (is(con, "try-error")) { + con <- try(PEcAn.DB::db.open(settings$database$bety), silent = TRUE) + if (methods::is(con, "try-error")) { con <- NULL } else { - on.exit(db.close(con)) + on.exit(PEcAn.DB::db.close(con)) } } else { con <- NULL @@ -196,13 +195,13 @@ write.ensemble.configs <- function(defaults, ensemble.samples, settings, model, # create an ensemble id if (!is.null(con)) { # write ensemble first - ensemble.id <- db.query(paste0( + ensemble.id <- PEcAn.DB::db.query(paste0( "INSERT INTO ensembles (runtype, workflow_id) ", "VALUES ('ensemble', ", format(workflow.id, scientific = FALSE), ")", "RETURNING id"), con = con)[['id']] for (pft in defaults) { - db.query(paste0( + PEcAn.DB::db.query(paste0( "INSERT INTO posteriors_ensembles (posterior_id, ensemble_id) ", "values (", pft$posteriorid, ", ", ensemble.id, ")"), con = con) } @@ -219,7 +218,7 @@ write.ensemble.configs <- function(defaults, ensemble.samples, settings, model, for (counter in seq_len(settings$ensemble$size)) { if (!is.null(con)) { paramlist <- paste("ensemble=", counter, sep = "") - run.id <- db.query(paste0( + run.id <- PEcAn.DB::db.query(paste0( "INSERT INTO runs (model_id, site_id, start_time, finish_time, outdir, ensemble_id, parameter_list) ", "values ('", settings$model$id, "', '", @@ -234,7 +233,7 @@ write.ensemble.configs <- function(defaults, ensemble.samples, settings, model, # associate inputs with runs if (!is.null(inputs)) { for (x in inputs) { - db.query(paste0("INSERT INTO inputs_runs (input_id, run_id) ", + PEcAn.DB::db.query(paste0("INSERT INTO inputs_runs (input_id, run_id) ", "values (", settings$run$inputs[[x]], ", ", run.id, ")"), con = con) } diff --git a/base/utils/R/get.parameter.samples.R b/base/utils/R/get.parameter.samples.R index 08e6cf06271..0e5c6f70eff 100644 --- a/base/utils/R/get.parameter.samples.R +++ b/base/utils/R/get.parameter.samples.R @@ -11,7 +11,6 @@ get.parameter.samples <- function(settings, posterior.files = rep(NA, length(settings$pfts)), ens.sample.method = "uniform") { - library(PEcAn.priors) pfts <- settings$pfts num.pfts <- length(settings$pfts) pft.names <- list() @@ -95,7 +94,7 @@ get.parameter.samples <- function(settings, if (prior %in% ma.traits) { samples <- as.matrix(trait.mcmc[[prior]][, "beta.o"]) } else { - samples <- get.sample(prior.distns[prior, ], samples.num) + samples <- PEcAn.priors::get.sample(prior.distns[prior, ], samples.num) } trait.samples[[pft.name]][[prior]] <- samples } diff --git a/base/utils/R/get.results.R b/base/utils/R/get.results.R index c5933bfa992..a0e5601390e 100644 --- a/base/utils/R/get.results.R +++ b/base/utils/R/get.results.R @@ -225,9 +225,9 @@ get.results <- function(settings, sa.ensemble.id = NULL, ens.ensemble.id = NULL, ##' @export runModule.get.results <- function(settings) { - if (is.MultiSettings(settings)) { - return(papply(settings, runModule.get.results)) - } else if (is.Settings(settings)) { + if (PEcAn.settings::is.MultiSettings(settings)) { + return(PEcAn.settings::papply(settings, runModule.get.results)) + } else if (PEcAn.settings::is.Settings(settings)) { return(get.results(settings)) } else { stop("runModule.get.results only works with Settings or MultiSettings") diff --git a/base/utils/R/mcmc.list2init.R b/base/utils/R/mcmc.list2init.R index 965c52215fb..1cabcccfb28 100644 --- a/base/utils/R/mcmc.list2init.R +++ b/base/utils/R/mcmc.list2init.R @@ -31,7 +31,7 @@ mcmc.list2init <- function(dat) { ## define variables ic <- list() n <- nrow(dat[[1]]) - nc <- nchain(dat) + nc <- coda::nchain(dat) for(c in seq_len(nc)) ic[[c]] <- list() for(v in seq_along(uname)){ diff --git a/base/utils/R/plots.R b/base/utils/R/plots.R index a2b5fc03fa8..3e099fbab2d 100644 --- a/base/utils/R/plots.R +++ b/base/utils/R/plots.R @@ -27,14 +27,14 @@ ##' @return list with two elements, heights of length n and breaks of length n+1 indicating the heights and break points of the histogram bars. ##' @author Lorraine Denby, Colin Mallows ##' @references Lorraine Denby, Colin Mallows. Journal of Computational and Graphical Statistics. March 1, 2009, 18(1): 21-31. doi:10.1198/jcgs.2009.0002. -dhist <- function(x, a = 5 * iqr(x), nbins = nclass.Sturges(x), rx = range(x, na.rm = TRUE), +dhist <- function(x, a = 5 * iqr(x), nbins = grDevices::nclass.Sturges(x), rx = range(x, na.rm = TRUE), eps = 0.15, xlab = "x", plot = TRUE, lab.spikes = TRUE) { if (is.character(nbins)) { nbins <- switch(casefold(nbins), - sturges = nclass.Sturges(x), - fd = nclass.FD(x), - scott = nclass.scott(x), + sturges = grDevices::nclass.Sturges(x), + fd = grDevices::nclass.FD(x), + scott = grDevices::nclass.scott(x), stop("Nclass method not recognized")) } else { if (is.function(nbins)) { @@ -115,14 +115,14 @@ dhist <- function(x, a = 5 * iqr(x), nbins = nclass.Sturges(x), rx = range(x, na } bin.size <- length(x) / nbins cut.pt <- unique(c(min(x) - abs(min(x)) / 1000, - approx(seq(length(x)), x, seq_len(nbins - 1) * bin.size, rule = 2)$y, max(x))) - aa <- hist(x, breaks = cut.pt, plot = FALSE, probability = TRUE) + stats::approx(seq(length(x)), x, seq_len(nbins - 1) * bin.size, rule = 2)$y, max(x))) + aa <- graphics::hist(x, breaks = cut.pt, plot = FALSE, probability = TRUE) if (a == Inf) { heights <- aa$counts xbr <- aa$breaks } amt.height <- 3 - q75 <- quantile(heights, 0.75) + q75 <- stats::quantile(heights, 0.75) if (sum(flag.vec) != 0) { amt <- max(heights[!flag.vec]) ylim.height <- amt * amt.height @@ -133,15 +133,15 @@ dhist <- function(x, a = 5 * iqr(x), nbins = nclass.Sturges(x), rx = range(x, na amt.txt <- 0 end.y <- (-10000) if (plot) { - barplot(heights, abs(diff(xbr)), + graphics::barplot(heights, abs(diff(xbr)), space = 0, density = -1, xlab = xlab, plot = TRUE, xaxt = "n", yaxt = "n") at <- pretty(xbr) - axis(1, at = at - xbr[1], labels = as.character(at)) + graphics::axis(1, at = at - xbr[1], labels = as.character(at)) if (lab.spikes) { if (sum(flag.vec) >= 1) { - usr <- par("usr") + usr <- graphics::par("usr") for (i in seq(length(xbr) - 1)) { if (!flag.vec[i]) { amt.txt <- 0 @@ -150,13 +150,13 @@ dhist <- function(x, a = 5 * iqr(x), nbins = nclass.Sturges(x), rx = range(x, na } } else { amt.txt <- amt.txt + 1 - end.y <- xbr[i] - xbr[1] + 3 * par("cxy")[1] + end.y <- xbr[i] - xbr[1] + 3 * graphics::par("cxy")[1] } if (flag.vec[i]) { txt <- paste0(" ", format(round(counts[i]/sum(counts) * 100)), "%") - par(xpd = TRUE) - text(xbr[i + 1] - xbr[1], - ylim.height - par("cxy")[2] * (amt.txt -1), txt, adj = 0) + graphics::par(xpd = TRUE) + graphics::text(xbr[i + 1] - xbr[1], + ylim.height - graphics::par("cxy")[2] * (amt.txt -1), txt, adj = 0) } } } else print("no spikes or more than one spike") @@ -177,7 +177,7 @@ dhist <- function(x, a = 5 * iqr(x), nbins = nclass.Sturges(x), rx = range(x, na ##' @param x vector ##' @return numeric vector of length 2, with the 25th and 75th quantiles of input vector x. iqr <- function(x) { - return(diff(quantile(x, c(0.25, 0.75), na.rm = TRUE))) + return(diff(stats::quantile(x, c(0.25, 0.75), na.rm = TRUE))) } # iqr @@ -192,7 +192,7 @@ iqr <- function(x) { ##' @export ##' @author David LeBauer create.base.plot <- function() { - base.plot <- ggplot() + base.plot <- ggplot2::ggplot() return(base.plot) } # create.base.plot @@ -241,11 +241,11 @@ plot_data <- function(trait.data, base.plot = NULL, ymax, color = "black") { se = trait.data$se, control = !trait.data$trt == 1 & trait.data$ghs == 1) new.plot <- base.plot + - geom_point(data = plot.data, aes(x = x, y = y, color = control)) + - geom_segment(data = plot.data, - aes(x = x - se, y = y, xend = x + se, yend = y, color = control)) + - scale_color_manual(values = c("black", "grey")) + - theme(legend.position = "none") + ggplot2::geom_point(data = plot.data, ggplot2::aes(x = x, y = y, color = control)) + + ggplot2::geom_segment(data = plot.data, + ggplot2::aes(x = x - se, y = y, xend = x + se, yend = y, color = control)) + + ggplot2::scale_color_manual(values = c("black", "grey")) + + ggplot2::theme(legend.position = "none") return(new.plot) } # plot_data @@ -302,10 +302,10 @@ theme_border <- function(type = c("left", "right", "bottom", "top", "none"), ylist <- append(ylist, c(y, y + height)) idlist <- append(idlist, c(4, 4)) } - polylineGrob(x = xlist, y = ylist, + grid::polylineGrob(x = xlist, y = ylist, id = idlist, ..., default.units = "npc", - gp = gpar(lwd = size, + gp = grid::gpar(lwd = size, col = colour, lty = linetype), ) }, class = "theme", type = "box", call = match.call()) diff --git a/base/utils/R/r2bugs.distributions.R b/base/utils/R/r2bugs.distributions.R index b4c2e4ab49f..a349a0b0674 100644 --- a/base/utils/R/r2bugs.distributions.R +++ b/base/utils/R/r2bugs.distributions.R @@ -89,7 +89,6 @@ bugs2r.distributions <- function(..., direction = "bugs2r") { ##' @author David LeBauer bugs.rdist <- function(prior = data.frame(distn = "norm", parama = 0, paramb = 1), n.iter = 1e+05, n = NULL) { - library(rjags) if (!grepl("chisq", prior$distn)) { model.string <- paste0("model{Y ~ d", prior$distn, "(", prior$parama, ", ", prior$paramb, ")\n a <- x}") } else if (grepl("chisq", prior$distn)) { @@ -99,8 +98,8 @@ bugs.rdist <- function(prior = data.frame(distn = "norm", parama = 0, paramb = 1 } writeLines(model.string, con = "test.bug") - j.model <- jags.model(file = "test.bug", data = list(x = 1)) - mcmc.object <- window(coda.samples(model = j.model, + j.model <- rjags::jags.model(file = "test.bug", data = list(x = 1)) + mcmc.object <- stats::window(rjags::coda.samples(model = j.model, variable.names = c("Y"), n.iter = n.iter, thin = 2), start = n.iter / 2) diff --git a/base/utils/R/read.output.R b/base/utils/R/read.output.R index cf19465e5a2..aae51abd634 100644 --- a/base/utils/R/read.output.R +++ b/base/utils/R/read.output.R @@ -94,9 +94,10 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables result <- lapply(variables, function(x) NA) } - PEcAn.logger::logger.info(variables, "Mean:", - lapply(result, function(x) signif(mean(x, na.rm = TRUE), 3)), "Median:", - lapply(result, function(x) signif(median(x, na.rm = TRUE), 3))) + PEcAn.logger::logger.info( + variables, + "Mean:", lapply(result, function(x) signif(mean(x, na.rm = TRUE), 3)), + "Median:", lapply(result, function(x) signif(stats::median(x, na.rm = TRUE), 3))) if(dataframe==FALSE){ return(result) @@ -122,7 +123,7 @@ read.output <- function(runid, outdir, start.year = NA, end.year = NA, variables if(length(time_breaks) == 0 & length(years)>1){ model$posix <- as.POSIXct(model$time*86400,origin= origin,tz="UTC") - model$year <- year(model$posix) + model$year <- lubridate::year(model$posix) return(model) } else { N <- c(0,time_breaks, length(model$time)) diff --git a/base/utils/R/regrid.R b/base/utils/R/regrid.R index c29745d6871..39622a5d55f 100644 --- a/base/utils/R/regrid.R +++ b/base/utils/R/regrid.R @@ -5,19 +5,17 @@ ##' @return dataframe with regridded data ##' @author David LeBauer regrid <- function(latlon.data) { - library(raster) - library(sp) ## from http://stackoverflow.com/a/15351169/513006 - spdf <- SpatialPointsDataFrame(data.frame(x = latlon.data$lon, y = latlon.data$lat), + spdf <- sp::SpatialPointsDataFrame(data.frame(x = latlon.data$lon, y = latlon.data$lat), data = data.frame(z = latlon.data$yield)) ## Make evenly spaced raster, same extent as original data - e <- extent(spdf) + e <- raster::extent(spdf) ## Determine ratio between x and y dimensions ratio <- (e@xmax - e@xmin) / (e@ymax - e@ymin) ## Create template raster to sample to - r <- raster(nrows = 56, ncols = floor(56 * ratio), ext = extent(spdf)) - rf <- rasterize(spdf, r, field = "z", fun = mean) + r <- raster::raster(nrows = 56, ncols = floor(56 * ratio), ext = raster::extent(spdf)) + rf <- raster::rasterize(spdf, r, field = "z", fun = mean) # rdf <- data.frame( rasterToPoints( rf ) ) colnames(rdf) <- # colnames(latlon.data) @@ -40,12 +38,12 @@ grid2netcdf <- function(gdata, date = "9999-09-09", outfile = "out.nc") { lats <- unique(gdata$lat) lons <- unique(gdata$lon) dates <- unique(gdata$date) - latlons <- data.table(expand.grid(lat = lats, lon = lons, date = dates)) + latlons <- data.table::data.table(expand.grid(lat = lats, lon = lons, date = dates)) grid.data <- merge(latlons, gdata, by = c("lat", "lon", "date"), all.x = TRUE) lat <- ncdf4::ncdim_def("lat", "degrees_east", vals = lats, longname = "station_latitude") lon <- ncdf4::ncdim_def("lon", "degrees_north", vals = lons, longname = "station_longitude") time <- ncdf4::ncdim_def(name = "time", units = paste0("days since 1700-01-01"), - vals = as.numeric(ymd(paste0(years, "01-01")) - ymd("1700-01-01")), + vals = as.numeric(lubridate::ymd(paste0(years, "01-01")) - lubridate::ymd("1700-01-01")), calendar = "standard", unlim = TRUE) @@ -53,8 +51,8 @@ grid2netcdf <- function(gdata, date = "9999-09-09", outfile = "out.nc") { nc <- ncdf4::nc_create(filename = outfile, vars = list(CropYield = yieldvar)) ## Output netCDF data - # ncvar_put(nc, varid = yieldvar, vals = grid.data[order(lat, lon, order(ymd(date )))]$yield) - # ncvar_put(nc, varid = yieldvar, vals = grid.data[order(order(ymd(date), lat, lon))]$yield) + # ncvar_put(nc, varid = yieldvar, vals = grid.data[order(lat, lon, order(lubridate::ymd(date )))]$yield) + # ncvar_put(nc, varid = yieldvar, vals = grid.data[order(order(lubridate::ymd(date), lat, lon))]$yield) ncdf4::ncvar_put(nc, varid = yieldvar, vals = yieldarray) ncdf4::ncatt_put(nc, 0, "description", "put description here") diff --git a/base/utils/R/run.write.configs.R b/base/utils/R/run.write.configs.R index b4cad2c2598..3e4cda644bf 100644 --- a/base/utils/R/run.write.configs.R +++ b/base/utils/R/run.write.configs.R @@ -29,8 +29,8 @@ run.write.configs <- function(settings, write = TRUE, ens.sample.method = "unifo posterior.files = rep(NA, length(settings$pfts)), overwrite = TRUE) { - con <- db.open(settings$database$bety) - on.exit(db.close(con)) + con <- PEcAn.DB::db.open(settings$database$bety) + on.exit(PEcAn.DB::db.close(con)) ## Which posterior to use? for (i in seq_along(settings$pfts)) { @@ -38,7 +38,7 @@ run.write.configs <- function(settings, write = TRUE, ens.sample.method = "unifo if (is.na(posterior.files[i])) { ## otherwise, check to see if posteriorid exists if (!is.null(settings$pfts[[i]]$posteriorid)) { - files <- dbfile.check("Posterior", + files <- PEcAn.DB::dbfile.check("Posterior", settings$pfts[[i]]$posteriorid, con, settings$host$name) pid <- grep("post.distns.*Rdata", files$file_name) ## is there a posterior file? @@ -153,13 +153,13 @@ run.write.configs <- function(settings, write = TRUE, ens.sample.method = "unifo ##' @export runModule.run.write.configs <- function(settings, overwrite = TRUE) { - if (is.MultiSettings(settings)) { + if (PEcAn.settings::is.MultiSettings(settings)) { if (overwrite && file.exists(file.path(settings$rundir, "runs.txt"))) { PEcAn.logger::logger.warn("Existing runs.txt file will be removed.") unlink(file.path(settings$rundir, "runs.txt")) } - return(papply(settings, runModule.run.write.configs, overwrite = FALSE)) - } else if (is.Settings(settings)) { + return(PEcAn.settings::papply(settings, runModule.run.write.configs, overwrite = FALSE)) + } else if (PEcAn.settings::is.Settings(settings)) { write <- settings$database$bety$write ens.sample.method <- settings$ensemble$method return(run.write.configs(settings, write, ens.sample.method, overwrite = overwrite)) diff --git a/base/utils/R/sensitivity.R b/base/utils/R/sensitivity.R index 7cb44e9ee0a..e2dedc4bda0 100644 --- a/base/utils/R/sensitivity.R +++ b/base/utils/R/sensitivity.R @@ -89,11 +89,11 @@ write.sa.configs <- function(defaults, quantile.samples, settings, model, my.write.config <- paste("write.config.", model, sep = "") if (write.to.db) { - con <- try(db.open(settings$database$bety), silent = TRUE) - if (is(con, "try-error")) { + con <- try(PEcAn.DB::db.open(settings$database$bety), silent = TRUE) + if (methods::is(con, "try-error")) { con <- NULL } else { - on.exit(db.close(con)) + on.exit(PEcAn.DB::db.close(con)) } } else { con <- NULL @@ -121,14 +121,14 @@ write.sa.configs <- function(defaults, quantile.samples, settings, model, names(median.samples) <- names(quantile.samples) if (!is.null(con)) { - ensemble.id <- db.query(paste0( + ensemble.id <- PEcAn.DB::db.query(paste0( "INSERT INTO ensembles (runtype, workflow_id) ", "VALUES ('sensitivity analysis', ", format(workflow.id, scientific = FALSE), ") ", "RETURNING id"), con = con)[['id']] paramlist <- paste0("quantile=MEDIAN,trait=all,pft=", paste(lapply(settings$pfts, function(x) x[["name"]]), sep = ",")) - run.id <- db.query(paste0("INSERT INTO runs ", + run.id <- PEcAn.DB::db.query(paste0("INSERT INTO runs ", "(model_id, site_id, start_time, finish_time, outdir, ensemble_id, parameter_list) ", "values ('", settings$model$id, "', '", @@ -142,7 +142,7 @@ write.sa.configs <- function(defaults, quantile.samples, settings, model, # associate posteriors with ensembles for (pft in defaults) { - db.query(paste0( + PEcAn.DB::db.query(paste0( "INSERT INTO posteriors_ensembles (posterior_id, ensemble_id) ", "values (", pft$posteriorid, ", ", ensemble.id, ")"), con = con) } @@ -150,7 +150,7 @@ write.sa.configs <- function(defaults, quantile.samples, settings, model, # associate inputs with runs if (!is.null(inputs)) { for (x in inputs) { - db.query(paste0( + PEcAn.DB::db.query(paste0( "INSERT INTO inputs_runs (input_id, run_id) ", "values (", settings$run$inputs[[x]], ", ", run.id, ")"), con = con) } @@ -222,7 +222,7 @@ write.sa.configs <- function(defaults, quantile.samples, settings, model, if (!is.null(con)) { now <- format(Sys.time(), "%Y-%m-%d %H:%M:%S") paramlist <- paste0("quantile=", quantile.str, ",trait=", trait, ",pft=", pftname) - db.query(paste0("INSERT INTO runs (model_id, site_id, start_time, finish_time, outdir, created_at, ensemble_id, parameter_list) values ('", + PEcAn.DB::db.query(paste0("INSERT INTO runs (model_id, site_id, start_time, finish_time, outdir, created_at, ensemble_id, parameter_list) values ('", settings$model$id, "', '", settings$run$site$id, "', '", settings$run$start.date, "', '", @@ -231,12 +231,12 @@ write.sa.configs <- function(defaults, quantile.samples, settings, model, now, "', ", ensemble.id, ", '", paramlist, "')"), con = con) - run.id <- db.query(paste0("SELECT id FROM runs WHERE created_at='", + run.id <- PEcAn.DB::db.query(paste0("SELECT id FROM runs WHERE created_at='", now, "' AND parameter_list='", paramlist, "'"), con = con)[["id"]] # associate posteriors with ensembles for (pft in defaults) { - db.query(paste0("INSERT INTO posteriors_ensembles (posterior_id, ensemble_id, created_at, updated_at) values (", + PEcAn.DB::db.query(paste0("INSERT INTO posteriors_ensembles (posterior_id, ensemble_id, created_at, updated_at) values (", pft$posteriorid, ", ", ensemble.id, ", '", now, "', '", now, @@ -246,7 +246,7 @@ write.sa.configs <- function(defaults, quantile.samples, settings, model, # associate inputs with runs if (!is.null(inputs)) { for (x in inputs) { - db.query(paste0("INSERT INTO inputs_runs (input_id, run_id, created_at) ", + PEcAn.DB::db.query(paste0("INSERT INTO inputs_runs (input_id, run_id, created_at) ", "values (", settings$run$inputs[[x]], ", ", run.id, ", NOW());"), con = con) } diff --git a/base/utils/R/status.R b/base/utils/R/status.R index 12223d783cd..b28b7685dce 100644 --- a/base/utils/R/status.R +++ b/base/utils/R/status.R @@ -53,7 +53,7 @@ status.check <- function(name) { if (!file.exists(status.file)) { return(0) } - status.data <- read.table(status.file, row.names = 1, header = FALSE, sep = "\t", + status.data <- utils::read.table(status.file, row.names = 1, header = FALSE, sep = "\t", quote = "", fill = TRUE) if (!name %in% row.names(status.data)) { return(0) diff --git a/base/utils/R/transformstats.R b/base/utils/R/transformstats.R index eaca5dd4d5d..a2423440ee3 100644 --- a/base/utils/R/transformstats.R +++ b/base/utils/R/transformstats.R @@ -33,14 +33,14 @@ transformstats <- function(data) { ## 95%CI measured from mean to upper or lower CI SE = CI/t if ("95%CI" %in% data$statname) { cii <- which(data$statname == "95%CI") - data$stat[cii] <- data$stat[cii]/qt(0.975, data$n[cii]) + data$stat[cii] <- data$stat[cii]/stats::qt(0.975, data$n[cii]) data$statname[cii] <- "SE" } ## Fisher's Least Significant Difference (LSD) ## conservatively assume no within block replication if ("LSD" %in% data$statname) { lsdi <- which(data$statname == "LSD") - data$stat[lsdi] <- data$stat[lsdi]/(qt(0.975, data$n[lsdi]) * sqrt((2 * data$n[lsdi]))) + data$stat[lsdi] <- data$stat[lsdi]/(stats::qt(0.975, data$n[lsdi]) * sqrt((2 * data$n[lsdi]))) data$statname[lsdi] <- "SE" } ## Tukey's Honestly Significant Difference (HSD), @@ -49,7 +49,7 @@ transformstats <- function(data) { hsdi <- which(data$statname == "HSD") n <- data$n[hsdi] n[is.na(n)] <- 2 ## minimum n that can be used if NA - data$stat[hsdi] <- data$stat[hsdi]/(qtukey(0.975, n, df = 2)) + data$stat[hsdi] <- data$stat[hsdi]/(stats::qtukey(0.975, n, df = 2)) data$statname[hsdi] <- "SE" data$n[hsdi] <- n } @@ -58,7 +58,7 @@ transformstats <- function(data) { ## SE = MSD*n/(t*sqrt(2)) if ("MSD" %in% data$statname) { msdi <- which(data$statname == "MSD") - data$stat[msdi] <- data$stat[msdi] * data$n[msdi] / (qt(0.975, 2 * data$n[msdi] - 2) * sqrt(2)) + data$stat[msdi] <- data$stat[msdi] * data$n[msdi] / (stats::qt(0.975, 2 * data$n[msdi] - 2) * sqrt(2)) data$statname[msdi] <- "SE" } if (FALSE %in% c("SE", "none") %in% data$statname) { diff --git a/base/utils/R/utils.R b/base/utils/R/utils.R index ec447d9bc68..997f95f5cc7 100644 --- a/base/utils/R/utils.R +++ b/base/utils/R/utils.R @@ -244,7 +244,7 @@ listToXml.default <- function(item, tag) { ##' @references M. P. Wand, J. S. Marron and D. Ruppert, 1991. Transformations in Density Estimation. Journal of the American Statistical Association. 86(414):343-353 \url{http://www.jstor.org/stable/2290569} zero.bounded.density <- function(x, bw = "SJ", n = 1001) { y <- log(x) - g <- density(y, bw = bw, n = n) + g <- stats::density(y, bw = bw, n = n) xgrid <- exp(g$x) g$y <- c(0, g$y / xgrid) g$x <- c(0, xgrid) @@ -267,7 +267,7 @@ summarize.result <- function(result) { plyr::summarise, n = length(n), mean = mean(mean), statname = ifelse(length(n) == 1, "none", "SE"), - stat = sd(mean) / sqrt(length(n))) + stat = stats::sd(mean) / sqrt(length(n))) ans2 <- result[result$n != 1, colnames(ans1)] return(rbind(ans1, ans2)) } # summarize.result @@ -349,7 +349,7 @@ pdf.stats <- function(distn, A, B) { distn <- as.character(distn) mean <- switch(distn, gamma = A/B, lnorm = exp(A + 1/2 * B^2), beta = A/(A + B), weibull = B * gamma(1 + 1/A), norm = A, f = ifelse(B > 2, B/(B - 2), - mean(rf(10000, A, B)))) + mean(stats::rf(10000, A, B)))) var <- switch(distn, gamma = A/B^2, lnorm = exp(2 * A + B ^ 2) * (exp(B ^ 2) - 1), beta = A * B/((A + B) ^ 2 * (A + B + 1)), @@ -357,7 +357,7 @@ pdf.stats <- function(distn, A, B) { gamma(1 + 1 / A) ^ 2), norm = B ^ 2, f = ifelse(B > 4, 2 * B^2 * (A + B - 2) / (A * (B - 2) ^ 2 * (B - 4)), - var(rf(1e+05, A, B)))) + var(stats::rf(1e+05, A, B)))) qci <- get(paste0("q", distn)) ci <- qci(c(0.025, 0.975), A, B) lcl <- ci[1] @@ -472,7 +472,7 @@ isFALSE <- function(x) !isTRUE(x) ##' @author David LeBauer newxtable <- function(x, environment = "table", table.placement = "ht", label = NULL, caption = NULL, caption.placement = NULL, align = NULL) { - print(xtable(x, label = label, caption = caption, align = align), + print(xtable::xtable(x, label = label, caption = caption, align = align), floating.environment = environment, table.placement = table.placement, caption.placement = caption.placement, @@ -577,8 +577,8 @@ tryl <- function(FUN) { ##' @author David LeBauer load.modelpkg <- function(model) { pecan.modelpkg <- paste0("PEcAn.", model) - if (!pecan.modelpkg %in% names(sessionInfo()$otherPkgs)) { - if (pecan.modelpkg %in% rownames(installed.packages())) { + if (!pecan.modelpkg %in% names(utils::sessionInfo()$otherPkgs)) { + if (pecan.modelpkg %in% rownames(utils::installed.packages())) { do.call(require, args = list(pecan.modelpkg)) } else { PEcAn.logger::logger.error("I can't find a package for the ", model, @@ -752,12 +752,12 @@ retry.func <- function(expr, isError=function(x) "try-error" %in% class(x), maxE while (isError(retval)) { attempts = attempts + 1 if (attempts >= maxErrors) { - msg = sprintf("retry: too many retries [[%s]]", capture.output(str(retval))) + msg = sprintf("retry: too many retries [[%s]]", utils::capture.output(utils::str(retval))) PEcAn.logger::logger.warn(msg) stop(msg) } else { msg = sprintf("retry: error in attempt %i/%i [[%s]]", attempts, maxErrors, - capture.output(str(retval))) + utils::capture.output(utils::str(retval))) PEcAn.logger::logger.warn(msg) #warning(msg) } diff --git a/base/utils/R/write.config.utils.R b/base/utils/R/write.config.utils.R index 2056ed460c9..9c17292b730 100644 --- a/base/utils/R/write.config.utils.R +++ b/base/utils/R/write.config.utils.R @@ -26,10 +26,10 @@ get.quantiles <- function(quantiles.tag) { } if (!is.null(quantiles.tag$sigma)) { sigmas <- as.numeric(quantiles.tag[names(quantiles.tag) == "sigma"]) - quantiles <- append(quantiles, 1 - pnorm(sigmas)) + quantiles <- append(quantiles, 1 - stats::pnorm(sigmas)) } if (length(quantiles) == 0) { - quantiles <- 1 - pnorm(-3:3) #default + quantiles <- 1 - stats::pnorm(-3:3) #default } if (!0.5 %in% quantiles) { quantiles <- append(quantiles, 0.5) diff --git a/base/utils/man/dhist.Rd b/base/utils/man/dhist.Rd index da8ccb668ab..e3131f4981e 100644 --- a/base/utils/man/dhist.Rd +++ b/base/utils/man/dhist.Rd @@ -4,8 +4,9 @@ \alias{dhist} \title{Diagonally Cut Histogram} \usage{ -dhist(x, a = 5 * iqr(x), nbins = nclass.Sturges(x), rx = range(x, na.rm = - TRUE), eps = 0.15, xlab = "x", plot = TRUE, lab.spikes = TRUE) +dhist(x, a = 5 * iqr(x), nbins = grDevices::nclass.Sturges(x), + rx = range(x, na.rm = TRUE), eps = 0.15, xlab = "x", plot = TRUE, + lab.spikes = TRUE) } \arguments{ \item{x}{is a numeric vector (the data)} From 14b680363a4b4a44a03e1c7fc38bdc1bc1d05648 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 14 Sep 2017 19:04:46 -0400 Subject: [PATCH 703/771] line wrapping --- base/utils/R/to_nc.R | 2 +- base/utils/R/utils.R | 40 +++++++++++++++++++++------------ base/utils/man/download.file.Rd | 4 +++- base/utils/man/retry.func.Rd | 6 +++-- 4 files changed, 34 insertions(+), 18 deletions(-) diff --git a/base/utils/R/to_nc.R b/base/utils/R/to_nc.R index a03ef8b80ab..53b2b3976e2 100644 --- a/base/utils/R/to_nc.R +++ b/base/utils/R/to_nc.R @@ -61,4 +61,4 @@ to_ncvar <- function(varname,dims){ ncvar <- ncdf4::ncvar_def(name = varname, units = units, longname = longname, dim = dim, -999, prec = "double") return(ncvar) -} #to_ncvar \ No newline at end of file +} #to_ncvar diff --git a/base/utils/R/utils.R b/base/utils/R/utils.R index 997f95f5cc7..2ceb3471a35 100644 --- a/base/utils/R/utils.R +++ b/base/utils/R/utils.R @@ -347,17 +347,25 @@ get.parameter.stat <- function(mcmc.summary, parameter) { ## in future, perhaps create S3 functions: get.stats.pdf <- pdf.stats pdf.stats <- function(distn, A, B) { distn <- as.character(distn) - mean <- switch(distn, gamma = A/B, lnorm = exp(A + 1/2 * B^2), beta = A/(A + - B), weibull = B * gamma(1 + 1/A), norm = A, f = ifelse(B > 2, B/(B - 2), - mean(stats::rf(10000, A, B)))) - var <- switch(distn, gamma = A/B^2, - lnorm = exp(2 * A + B ^ 2) * (exp(B ^ 2) - 1), - beta = A * B/((A + B) ^ 2 * (A + B + 1)), - weibull = B ^ 2 * (gamma(1 + 2 / A) - - gamma(1 + 1 / A) ^ 2), - norm = B ^ 2, f = ifelse(B > 4, - 2 * B^2 * (A + B - 2) / (A * (B - 2) ^ 2 * (B - 4)), - var(stats::rf(1e+05, A, B)))) + mean <- switch(distn, + gamma = A/B, + lnorm = exp(A + 1/2 * B^2), + beta = A/(A + B), + weibull = B * gamma(1 + 1/A), + norm = A, + f = ifelse(B > 2, + B/(B - 2), + mean(stats::rf(10000, A, B)))) + var <- switch(distn, + gamma = A/B^2, + lnorm = exp(2 * A + B ^ 2) * (exp(B ^ 2) - 1), + beta = A * B/((A + B) ^ 2 * (A + B + 1)), + weibull = B ^ 2 * (gamma(1 + 2 / A) - + gamma(1 + 1 / A) ^ 2), + norm = B ^ 2, + f = ifelse(B > 4, + 2 * B^2 * (A + B - 2) / (A * (B - 2) ^ 2 * (B - 4)), + var(stats::rf(1e+05, A, B)))) qci <- get(paste0("q", distn)) ci <- qci(c(0.025, 0.975), A, B) lcl <- ci[1] @@ -701,7 +709,9 @@ convert.expr <- function(expression) { ##' ##' @examples ##' \dontrun{ -##' download.file("ftp://ftp.cdc.noaa.gov/Datasets/NARR/monolevel/pres.sfc.2000.nc", "~/pres.sfc.2000.nc") +##' download.file(" +##' ftp://ftp.cdc.noaa.gov/Datasets/NARR/monolevel/pres.sfc.2000.nc", +##' "~/pres.sfc.2000.nc") ##' } ##' ##' @export @@ -739,8 +749,10 @@ download.file <- function(url, filename, method) { ##' ##' @examples ##' \dontrun{ -##' dap <- retry.func(ncdf4::nc_open('https://thredds.daac.ornl.gov/thredds/dodsC/ornldaac/1220/mstmip_driver_global_hd_climate_lwdown_1999_v1.nc4'), -##' maxErrors=10, sleep=2) +##' dap <- retry.func( +##' ncdf4::nc_open('https://thredds.daac.ornl.gov/thredds/dodsC/ornldaac/1220/mstmip_driver_global_hd_climate_lwdown_1999_v1.nc4'), +##' maxErrors=10, +##' sleep=2) ##' } ##' ##' @export diff --git a/base/utils/man/download.file.Rd b/base/utils/man/download.file.Rd index 027e177593e..25b8843430d 100644 --- a/base/utils/man/download.file.Rd +++ b/base/utils/man/download.file.Rd @@ -23,7 +23,9 @@ home directory download.file("http://lib.stat.cmu.edu/datasets/csb/ch11b.txt","~/test.download.txt") \dontrun{ -download.file("ftp://ftp.cdc.noaa.gov/Datasets/NARR/monolevel/pres.sfc.2000.nc", "~/pres.sfc.2000.nc") +download.file(" + ftp://ftp.cdc.noaa.gov/Datasets/NARR/monolevel/pres.sfc.2000.nc", + "~/pres.sfc.2000.nc") } } diff --git a/base/utils/man/retry.func.Rd b/base/utils/man/retry.func.Rd index f24e5416c72..4bf50ee5511 100644 --- a/base/utils/man/retry.func.Rd +++ b/base/utils/man/retry.func.Rd @@ -25,8 +25,10 @@ Retry function X times before stopping in error } \examples{ \dontrun{ -dap <- retry.func(ncdf4::nc_open('https://thredds.daac.ornl.gov/thredds/dodsC/ornldaac/1220/mstmip_driver_global_hd_climate_lwdown_1999_v1.nc4'), -maxErrors=10, sleep=2) +dap <- retry.func( + ncdf4::nc_open('https://thredds.daac.ornl.gov/thredds/dodsC/ornldaac/1220/mstmip_driver_global_hd_climate_lwdown_1999_v1.nc4'), + maxErrors=10, + sleep=2) } } From 22ccdd53de1f09fed3ca465e974c64fcd8ab30d2 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 14 Sep 2017 21:21:55 -0400 Subject: [PATCH 704/771] typos --- base/utils/R/ensemble.R | 2 +- base/utils/R/get.results.R | 2 +- base/utils/R/write.config.utils.R | 2 +- base/utils/man/get.sa.samples.Rd | 2 +- base/utils/man/read.ensemble.output.Rd | 2 +- 5 files changed, 5 insertions(+), 5 deletions(-) diff --git a/base/utils/R/ensemble.R b/base/utils/R/ensemble.R index 960a248bfbf..984937330d0 100644 --- a/base/utils/R/ensemble.R +++ b/base/utils/R/ensemble.R @@ -18,7 +18,7 @@ ##' @param outdir directory with model output to use in ensemble analysis ##' @param start.year first year to include in ensemble analysis ##' @param end.year last year to include in ensemble analysis -##' @param variables targe variables for ensemble analysis +##' @param variables target variables for ensemble analysis ##' @export ##' @author Ryan Kelly, David LeBauer, Rob Kooper #--------------------------------------------------------------------------------------------------# diff --git a/base/utils/R/get.results.R b/base/utils/R/get.results.R index a0e5601390e..0539706e26d 100644 --- a/base/utils/R/get.results.R +++ b/base/utils/R/get.results.R @@ -188,7 +188,7 @@ get.results <- function(settings, sa.ensemble.id = NULL, ens.ensemble.id = NULL, } if (is.null(variable.ens)) - PEcAn.logger::logger.sever("No variables for ensemble analysis!") + PEcAn.logger::logger.severe("No variables for ensemble analysis!") # Only handling one variable at a time for now if (length(variable.ens) > 1) { diff --git a/base/utils/R/write.config.utils.R b/base/utils/R/write.config.utils.R index 9c17292b730..f26887ddb9b 100644 --- a/base/utils/R/write.config.utils.R +++ b/base/utils/R/write.config.utils.R @@ -63,7 +63,7 @@ get.sa.sample.list <- function(pft, env, quantiles) { ##' ##' Samples from long (>2000) vectors that represent random samples from a trait distribution. ##' Samples are either the MCMC chains output from the Bayesian meta-analysis or are randomly sampled from -##' the closed-form distribution of the parameter probabiolity distribution function. +##' the closed-form distribution of the parameter probability distribution function. ##' The list is indexed first by trait, then by quantile. ##' @title get sensitivity analysis samples ##' @param samples random samples from trait distribution diff --git a/base/utils/man/get.sa.samples.Rd b/base/utils/man/get.sa.samples.Rd index 7ed32d604b5..74aa70f1e81 100644 --- a/base/utils/man/get.sa.samples.Rd +++ b/base/utils/man/get.sa.samples.Rd @@ -20,7 +20,7 @@ Samples parameters for a model run at specified quantiles. \details{ Samples from long (>2000) vectors that represent random samples from a trait distribution. Samples are either the MCMC chains output from the Bayesian meta-analysis or are randomly sampled from -the closed-form distribution of the parameter probabiolity distribution function. +the closed-form distribution of the parameter probability distribution function. The list is indexed first by trait, then by quantile. } \author{ diff --git a/base/utils/man/read.ensemble.output.Rd b/base/utils/man/read.ensemble.output.Rd index 8cbdfd579b6..53015f9c223 100644 --- a/base/utils/man/read.ensemble.output.Rd +++ b/base/utils/man/read.ensemble.output.Rd @@ -18,7 +18,7 @@ read.ensemble.output(ensemble.size, pecandir, outdir, start.year, end.year, \item{end.year}{last year to include in ensemble analysis} -\item{variables}{targe variables for ensemble analysis} +\item{variables}{target variables for ensemble analysis} } \value{ a list of ensemble model output From 9194ec945ff35354e93b3333a9dab7e939d34938 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 14 Sep 2017 21:25:51 -0400 Subject: [PATCH 705/771] replace non-ascii space characters in standard_var descriptions --- base/utils/data/mstmip_vars.csv | 10 +++++----- base/utils/data/standard_vars.csv | 10 +++++----- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/base/utils/data/mstmip_vars.csv b/base/utils/data/mstmip_vars.csv index fbacb7bc8db..e7702c0bf50 100644 --- a/base/utils/data/mstmip_vars.csv +++ b/base/utils/data/mstmip_vars.csv @@ -6,7 +6,7 @@ Num;Group;order;Saveit;Variable.Name;standard_name;Units;Long.name;Priority;Cate 5;2;1;Yes;time;time;days since 1700-01-01 00:00:00 UTC;Time middle averaging period;0;Time;Yes;Yes;double;1;time;na;na;na;julian days days since 1700-01-01 00:00:00 UTC for middle of time averaging period Proleptic_Gregorianc calendar 6;2;2;Yes;time_bnds;;days since 1700-01-01 00:00:00 UTC;Time beginning-end bounds;0;Time;Yes;Yes;double;2;nbnds;time;na;na;(julian days days since 1700-01-01 beginning time ave period, julian days days since 1700-01-01 end time ave period) 7;2;3;Yes;dec_date;;yr;Decimal date middle averaging period;0;Time;Yes;Yes;double;1;time;na;na;na;decimal date in fractional years for middle of time averaging period -8;2;4;Yes;dec_date_bnds;;yr;Decimal date beginning-end bounds;0;Time;Yes;Yes;double;2;nbnds;time;na;na;(decimal date beginningᅠᅠtime ave period, decimal date end time ave period) +8;2;4;Yes;dec_date_bnds;;yr;Decimal date beginning-end bounds;0;Time;Yes;Yes;double;2;nbnds;time;na;na;(decimal date beginning time ave period, decimal date end time ave period) 9;2;5;Yes;cal_date_mid;;yr, mon, day, hr, min, sec;Calender date middle averaging period;0;Time;Yes;Yes;integer;2;ncal;time;na;na;calender date middle of time ave period: year, month, day, hour, minute, second for UTC time zone 10;2;6;Yes;cal_date_beg;;yr, mon, day, hr, min, sec;Calender date beginning averaging period;0;Time;Yes;Yes;integer;2;ncal;time;na;na;calender date beginning of time ave period: year, month, day, hour, minute, second for UTC time zone 11;2;7;Yes;cal_date_end;;yr, mon, day, hr, min, sec;Calender date end averaging period;0;Time;Yes;Yes;integer;2;ncal;time;na;na;calender date end of time ave period: year, month, day, hour, minute, second for UTC time zone @@ -30,14 +30,14 @@ Num;Group;order;Saveit;Variable.Name;standard_name;Units;Long.name;Priority;Cate 30;5;4;Yes;TVeg;;kg m-2 s-1;Transpiration;1;Energy Fluxes;No;Yes;real;3;lon;lat;time;na;Total Plant transpiration (always positive) 31;5;5;Yes;LW_albedo;;(-);Longwave Albedo;1;Energy Fluxes;No;Yes;real;3;lon;lat;time;na;Longwave Albedo 32;5;6;Yes;SW_albedo;;(-);Shortwave Albedo;1;Energy Fluxes;No;Yes;real;3;lon;lat;time;na;Shortwave albedo -33;5;7;Yes;Lwnet;;W m-2;Net Longwave Radiation;1;Energy Fluxes;No;Yes;real;3;lon;lat;time;na;Incident longwave radiation minusᅠᅠsimulated outgoing longwave radiation (positive into grnd) -34;5;8;Yes;SWnet;;W m-2;Net shortwave radiation;1;Energy Fluxes;No;Yes;real;3;lon;lat;time;na;Incident shortwave radiation minusᅠᅠsimulated outgoing shortwave radiation (positive into grnd) +33;5;7;Yes;Lwnet;;W m-2;Net Longwave Radiation;1;Energy Fluxes;No;Yes;real;3;lon;lat;time;na;Incident longwave radiation minus simulated outgoing longwave radiation (positive into grnd) +34;5;8;Yes;SWnet;;W m-2;Net shortwave radiation;1;Energy Fluxes;No;Yes;real;3;lon;lat;time;na;Incident shortwave radiation minus simulated outgoing shortwave radiation (positive into grnd) 35;5;9;Yes;fPAR;;(-);Absorbed fraction incoming PAR;1;Energy Fluxes;No;Yes;real;3;lon;lat;time;na;absorbed fraction incoming photosyntetically active radiation 37;6;2;Yes;z_top;;m;Soil Layer Top Depth;1;Physical Variables;No;Yes;real;1;nsoil;na;na;na;Depth from soil surface to top of soil layer 38;6;3;Yes;z_node;;m;Soil Layer Node Depth;1;Physical Variables;No;Yes;real;1;nsoil;na;na;na;"Depth from soil surface to layer prognostic variables; typically center of soil layer" 39;6;4;Yes;z_bottom;;m;Soil Layer Bottom Depth;1;Physical Variables;No;Yes;real;1;nsoil;na;na;na;Depth from soil surface to bottom of soil layer -40;6;5;Yes;SoilMoist;;kg m-2;Average Layer Soil Moisture;1;Physical Variables;No;Yes;real;4;lon;lat;nsoil;time;Soil water content in each soil layer, includingᅠᅠliquid, vapor and ice -41;6;5;Yes;SoilMoistFrac;;(-);Average Layer Fraction of Saturation;1;Physical Variables;No;Yes;real;4;lon;lat;nsoil;time;Fraction of saturation of soil water in each soil layer, includingᅠᅠliquid and ice +40;6;5;Yes;SoilMoist;;kg m-2;Average Layer Soil Moisture;1;Physical Variables;No;Yes;real;4;lon;lat;nsoil;time;Soil water content in each soil layer, including liquid, vapor and ice +41;6;5;Yes;SoilMoistFrac;;(-);Average Layer Fraction of Saturation;1;Physical Variables;No;Yes;real;4;lon;lat;nsoil;time;Fraction of saturation of soil water in each soil layer, including liquid and ice 42;6;6;Yes;SoilWet;;(-);Total Soil Wetness;1;Physical Variables;No;Yes;real;3;lon;lat;time;na;Vertically integrated soil moisture divided by maximum allowable soil moisture above wilting point 43;6;7;Yes;Qs;;kg m-2 s-1;Surface runoff;1;Physical Variables;No;Yes;real;3;lon;lat;time;na;Runoff from the landsurface and/or subsurface stormflow 44;6;8;Yes;Qsb;;kg m-2 s-1;Subsurface runoff;1;Physical Variables;No;Yes;real;3;lon;lat;time;na;Gravity soil water drainage and/or soil water lateral flow diff --git a/base/utils/data/standard_vars.csv b/base/utils/data/standard_vars.csv index 01cbdfd02e5..8ee20bf6094 100755 --- a/base/utils/data/standard_vars.csv +++ b/base/utils/data/standard_vars.csv @@ -10,7 +10,7 @@ "lat_bnds",NA,"degrees_north","Latitude south-north bounds","Deprecated","real","nbnds","lat",NA,NA,"(south boundary of grid cell, north boundary of grid cell)" "time_bnds",NA,"days since 1700-01-01 00:00:00 UTC","Time beginning-end bounds","Deprecated","double","nbnds","time",NA,NA,"(julian days days since 1700-01-01 beginning time ave period, julian days days since 1700-01-01 end time ave period)" "dec_date",NA,"yr","Decimal date middle averaging period","Deprecated","double","time",NA,NA,NA,"decimal date in fractional years for middle of time averaging period" -"dec_date_bnds",NA,"yr","Decimal date beginning-end bounds","Deprecated","double","nbnds","time",NA,NA,"(decimal date beginningᅠᅠtime ave period, decimal date end time ave period)" +"dec_date_bnds",NA,"yr","Decimal date beginning-end bounds","Deprecated","double","nbnds","time",NA,NA,"(decimal date beginning time ave period, decimal date end time ave period)" "cal_date_mid",NA,"yr, mon, day, hr, min, sec","Calender date middle averaging period","Deprecated","integer","ncal","time",NA,NA,"calender date middle of time ave period: year, month, day, hour, minute, second for UTC time zone" "cal_date_beg",NA,"yr, mon, day, hr, min, sec","Calender date beginning averaging period","Deprecated","integer","ncal","time",NA,NA,"calender date beginning of time ave period: year, month, day, hour, minute, second for UTC time zone" "cal_date_end",NA,"yr, mon, day, hr, min, sec","Calender date end averaging period","Deprecated","integer","ncal","time",NA,NA,"calender date end of time ave period: year, month, day, hour, minute, second for UTC time zone" @@ -69,14 +69,14 @@ Root carbon content, optionally by size class; alternatively specify fine_ and c "Transp",NA,"kg m-2 s-1","Total transpiration","Energy Fluxes","real","lon","lat","time","pft","Total transpiration of each PFT within each grid cell" "LW_albedo",NA,"(-)","Longwave Albedo","Energy Fluxes","real","lon","lat","time",NA,"Longwave Albedo" "SW_albedo",NA,"(-)","Shortwave Albedo","Energy Fluxes","real","lon","lat","time",NA,"Shortwave albedo" -"Lwnet",NA,"W m-2","Net Longwave Radiation","Energy Fluxes","real","lon","lat","time",NA,"Incident longwave radiation minusᅠᅠsimulated outgoing longwave radiation (positive into grnd)" -"SWnet",NA,"W m-2","Net shortwave radiation","Energy Fluxes","real","lon","lat","time",NA,"Incident shortwave radiation minusᅠᅠsimulated outgoing shortwave radiation (positive into grnd)" +"Lwnet",NA,"W m-2","Net Longwave Radiation","Energy Fluxes","real","lon","lat","time",NA,"Incident longwave radiation minus simulated outgoing longwave radiation (positive into grnd)" +"SWnet",NA,"W m-2","Net shortwave radiation","Energy Fluxes","real","lon","lat","time",NA,"Incident shortwave radiation minus simulated outgoing shortwave radiation (positive into grnd)" "fPAR",NA,"(-)","Absorbed fraction incoming PAR","Energy Fluxes","real","lon","lat","time",NA,"absorbed fraction incoming photosyntetically active radiation" "z_top",NA,"m","Soil Layer Top Depth","Deprecated","real","depth",NA,NA,NA,"Depth from soil surface to top of soil layer" "z_node",NA,"m","Soil Layer Node Depth","Deprecated","real","depth",NA,NA,NA,"Depth from soil surface to layer prognostic variables, typically center of soil layer" "z_bottom",NA,"m","Soil Layer Bottom Depth","Deprecated","real","depth",NA,NA,NA,"Depth from soil surface to bottom of soil layer" -"SoilMoist",NA,"kg m-2","Average Layer Soil Moisture","Physical Variables","real","lon","lat","depth","time","Soil water content in each soil layer, includingᅠᅠliquid, vapor and ice" -"SoilMoistFrac",NA,"(-)","Average Layer Fraction of Saturation","Physical Variables","real","lon","lat","depth","time","Fraction of saturation of soil water in each soil layer, includingᅠᅠliquid and ice,,,,,,,,," +"SoilMoist",NA,"kg m-2","Average Layer Soil Moisture","Physical Variables","real","lon","lat","depth","time","Soil water content in each soil layer, including liquid, vapor and ice" +"SoilMoistFrac",NA,"(-)","Average Layer Fraction of Saturation","Physical Variables","real","lon","lat","depth","time","Fraction of saturation of soil water in each soil layer, including liquid and ice" "SoilWet",NA,"(-)","Total Soil Wetness","Physical Variables","real","lon","lat","time",NA,"Vertically integrated soil moisture divided by maximum allowable soil moisture above wilting point" "Qs",NA,"kg m-2 s-1","Surface runoff","Physical Variables","real","lon","lat","time",NA,"Runoff from the landsurface and/or subsurface stormflow" "Qsb",NA,"kg m-2 s-1","Subsurface runoff","Physical Variables","real","lon","lat","time",NA,"Gravity soil water drainage and/or soil water lateral flow" From 83b8d8790e4e0371baca5272e8dbf0353ae2ba79 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Fri, 15 Sep 2017 00:08:18 -0400 Subject: [PATCH 706/771] lazy-load data --- base/utils/DESCRIPTION | 3 +-- base/utils/R/datasets.R | 27 +++++++++++++++++++++++++++ base/utils/R/to_nc.R | 8 ++------ base/utils/R/utils.R | 17 ++++------------- base/utils/data/standard_vars.R | 4 ++++ base/utils/man/standard_vars.Rd | 30 ++++++++++++++++++++++++++++++ 6 files changed, 68 insertions(+), 21 deletions(-) create mode 100644 base/utils/R/datasets.R create mode 100644 base/utils/data/standard_vars.R create mode 100644 base/utils/man/standard_vars.Rd diff --git a/base/utils/DESCRIPTION b/base/utils/DESCRIPTION index 9ed342bd7a6..0a38c30a782 100644 --- a/base/utils/DESCRIPTION +++ b/base/utils/DESCRIPTION @@ -48,7 +48,6 @@ Suggests: testthat License: FreeBSD + file LICENSE Copyright: Authors -LazyLoad: yes -LazyData: FALSE +LazyData: true Require: hdf5, plyr RoxygenNote: 6.0.1 diff --git a/base/utils/R/datasets.R b/base/utils/R/datasets.R new file mode 100644 index 00000000000..384e0f1ba86 --- /dev/null +++ b/base/utils/R/datasets.R @@ -0,0 +1,27 @@ + +#' Standardized variable names and units for PEcAn +#' +#' A lookup table giving standard names, units and descriptions for variables in PEcAn input/output files. +#' Originally based on the \href{https://nacp.ornl.gov/MsTMIP_variables.shtml}{MsTMIP} standards, +#' with additions to accomodate a wider range of model inputs and outputs. +#' The standard_vars table replaces both \code{mstmip_vars} and \code{mstmip_local}, +#' both of which are now deprecated. +#' +#' @name standard_vars +#' @docType data +#' @keywords datasets +#' @format data frame, all columns character +#' \describe{ +#' \item{Variable.Name}{Short name suitable for programming with} +#' \item{standard_name}{Name used in the NetCDF \href{http://cfconventions.org/standard-names.html}{CF metadata conventions} } +#' \item{Units}{Standard units for this variable. Do not call variables by these names if they are in different units. +#' See \code{\link[udunits2]{udunits}} for conversions to and from non-standard units} +#' \item{Long.Name}{Human-readable variable name, suitable for e.g. axis labels} +#' \item{Category}{What kind of variable is it? (Carbon pool, N flux, dimension, input driver, etc)} +#' \item{var_type}{Storage type (character, integer, etc)} +#' \item{dim1,dim2,dim3,dim4}{Dimensions across which is this variable allowed to vary. +#' Dimension names are themselves standard vars and must be present in the table with category "Dimension"} +#' \item{Description}{Further details. For composite measures, list the variables it is calculated from} +#'} +#' +"standard_vars" diff --git a/base/utils/R/to_nc.R b/base/utils/R/to_nc.R index 53b2b3976e2..bf82e8c05a9 100644 --- a/base/utils/R/to_nc.R +++ b/base/utils/R/to_nc.R @@ -7,9 +7,7 @@ ##' @return ncdim defined according to standard_vars ##' @author Anne Thomas to_ncdim <- function(dimname,vals){ - standard_vars <- read.csv(system.file("data/standard_vars.csv",package="PEcAn.utils"),stringsAsFactors = FALSE) - - dim <- standard_vars[which(standard_vars$Variable.Name == dimname),] + dim <- PEcAn.utils::standard_vars[which(PEcAn.utils::standard_vars$Variable.Name == dimname),] #check dim exists if(nrow(dim) == 0){ PEcAn.logger::logger.severe(paste("Dimension",dimname,"not in standard_vars")) @@ -40,9 +38,7 @@ to_ncdim <- function(dimname,vals){ ##' @return ncvar defined according to standard_vars ##' @author Anne Thomas to_ncvar <- function(varname,dims){ - standard_vars <- read.csv(system.file("data/standard_vars.csv",package="PEcAn.utils"),stringsAsFactors = FALSE) - - var <- standard_vars[which(standard_vars$Variable.Name == varname),] + var <- PEcAn.utils::standard_vars[which(PEcAn.utils::standard_vars$Variable.Name == varname),] #check var exists if(nrow(var)==0){ PEcAn.logger::logger.severe(paste("Variable",varname,"not in standard_vars")) diff --git a/base/utils/R/utils.R b/base/utils/R/utils.R index 2ceb3471a35..2a04c02fccb 100644 --- a/base/utils/R/utils.R +++ b/base/utils/R/utils.R @@ -27,13 +27,11 @@ ##' @return ncvar based on MstMIP definition ##' @author Rob Kooper mstmipvar <- function(name, lat = NA, lon = NA, time = NA, nsoil = NA, silent = FALSE) { - data(mstmip_vars, package = "PEcAn.utils") - var <- mstmip_vars[mstmip_vars$Variable.Name == name, ] + var <- PEcAn.utils::mstmip_vars[PEcAn.utils::mstmip_vars$Variable.Name == name, ] dims <- list() if (nrow(var) == 0) { - data(mstmip_local, package = "PEcAn.utils") - var <- mstmip_local[mstmip_local$Variable.Name == name, ] + var <- PEcAn.utils::mstmip_local[PEcAn.utils::mstmip_local$Variable.Name == name, ] if (nrow(var) == 0) { if (!silent) { PEcAn.logger::logger.info("Don't know about variable", name, " in mstmip_vars in PEcAn.utils") @@ -395,17 +393,10 @@ pdf.stats <- function(distn, A, B) { ##' trait.lookup()[,c('figid', 'units')] ##' } trait.lookup <- function(traits = NULL) { - # HACK: shameless hack Ultimately we'll want this to be read once at the start of - # run time This could also be represented in the database, but because it is used - # to determine which parameters to feed to the model, it could be argued that - # it's conceptually model specific - data(trait.dictionary) if (is.null(traits)) { - trait.defs <- trait.dictionary - } else { - trait.defs <- trait.dictionary[match(traits, trait.dictionary$id), ] + return(PEcAn.utils::trait.dictionary) } - return(trait.defs) + PEcAn.utils::trait.dictionary[match(traits, PEcAn.utils::trait.dictionary$id), ] } # trait.lookup diff --git a/base/utils/data/standard_vars.R b/base/utils/data/standard_vars.R new file mode 100644 index 00000000000..c324394b849 --- /dev/null +++ b/base/utils/data/standard_vars.R @@ -0,0 +1,4 @@ + +standard_vars <- utils::read.csv( + file = "standard_vars.csv", + colClasses = "character") diff --git a/base/utils/man/standard_vars.Rd b/base/utils/man/standard_vars.Rd new file mode 100644 index 00000000000..d311595e987 --- /dev/null +++ b/base/utils/man/standard_vars.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/datasets.R +\docType{data} +\name{standard_vars} +\alias{standard_vars} +\title{Standardized variable names and units for PEcAn} +\format{data frame, all columns character +\describe{ + \item{Variable.Name}{Short name suitable for programming with} + \item{standard_name}{Name used in the NetCDF \href{http://cfconventions.org/standard-names.html}{CF metadata conventions} } + \item{Units}{Standard units for this variable. Do not call variables by these names if they are in different units. + See \code{\link[udunits2]{udunits}} for conversions to and from non-standard units} + \item{Long.Name}{Human-readable variable name, suitable for e.g. axis labels} + \item{Category}{What kind of variable is it? (Carbon pool, N flux, dimension, input driver, etc)} + \item{var_type}{Storage type (character, integer, etc)} + \item{dim1,dim2,dim3,dim4}{Dimensions across which is this variable allowed to vary. + Dimension names are themselves standard vars and must be present in the table with category "Dimension"} + \item{Description}{Further details. For composite measures, list the variables it is calculated from} +}} +\usage{ +standard_vars +} +\description{ +A lookup table giving standard names, units and descriptions for variables in PEcAn input/output files. +Originally based on the \href{https://nacp.ornl.gov/MsTMIP_variables.shtml}{MsTMIP} standards, +with additions to accomodate a wider range of model inputs and outputs. +The standard_vars table replaces both \code{mstmip_vars} and \code{mstmip_local}, +both of which are now deprecated. +} +\keyword{datasets} From 518cf0435c7a2185c0118595223cdf388f20b7ba Mon Sep 17 00:00:00 2001 From: Chris Black Date: Fri, 15 Sep 2017 15:57:57 -0400 Subject: [PATCH 707/771] remove outdated test when LazyData = true, csv version of trait.dictionary is not available for direct reading --- base/utils/tests/testthat/test.trait.dictionary.R | 7 ------- 1 file changed, 7 deletions(-) diff --git a/base/utils/tests/testthat/test.trait.dictionary.R b/base/utils/tests/testthat/test.trait.dictionary.R index ef8d105de8f..39da807c566 100644 --- a/base/utils/tests/testthat/test.trait.dictionary.R +++ b/base/utils/tests/testthat/test.trait.dictionary.R @@ -16,10 +16,3 @@ test_that("trait dictionary loads and has expected columns",{ expect_true(ncol(trait.dictionary) >= 4) # dim = 49 x 4 at time of writing expect_true(nrow(trait.dictionary) >=49) }) - - -test_that("trait dictionary can be loaded ",{ - data("trait.dictionary", package = "PEcAn.utils") - td <- read.csv(system.file("data", "trait.dictionary.csv", package = "PEcAn.utils"), sep = ";") - expect_equal(trait.dictionary, td) -}) \ No newline at end of file From 5fd42410ba0733b9c41d51c74a6a0b92c20150f6 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Fri, 15 Sep 2017 19:57:41 -0400 Subject: [PATCH 708/771] use base::inherits instead of methods::is This lets us skip loading methods namespace --- base/utils/DESCRIPTION | 1 - base/utils/R/SafeList.R | 4 ++-- base/utils/R/ensemble.R | 2 +- base/utils/R/sensitivity.R | 2 +- base/utils/tests/testthat/test.SafeList.class.R | 4 ++-- 5 files changed, 6 insertions(+), 7 deletions(-) diff --git a/base/utils/DESCRIPTION b/base/utils/DESCRIPTION index 0a38c30a782..3f1f4c4842f 100644 --- a/base/utils/DESCRIPTION +++ b/base/utils/DESCRIPTION @@ -19,7 +19,6 @@ Imports: data.table, getPass, ggplot2, - methods, PEcAn.data.atmosphere, PEcAn.data.land, PEcAn.DB, diff --git a/base/utils/R/SafeList.R b/base/utils/R/SafeList.R index 547f123c8dc..1cd512ccef4 100644 --- a/base/utils/R/SafeList.R +++ b/base/utils/R/SafeList.R @@ -26,7 +26,7 @@ SafeList <- function(...) { result <- list(...) if (length(result) == 1) { - if (methods::is(result[[1]], "SafeList")) { + if (inherits(result[[1]], "SafeList")) { return(result[[1]]) } else if (is.list(result[[1]])) { result <- result[[1]] @@ -46,7 +46,7 @@ as.SafeList <- function(x) { ##' @export is.SafeList <- function(x) { - return(methods::is(x, "SafeList")) + inherits(x, "SafeList") } # is.SafeList diff --git a/base/utils/R/ensemble.R b/base/utils/R/ensemble.R index 984937330d0..0ef1f0094fe 100644 --- a/base/utils/R/ensemble.R +++ b/base/utils/R/ensemble.R @@ -176,7 +176,7 @@ write.ensemble.configs <- function(defaults, ensemble.samples, settings, model, # Open connection to database so we can store all run/ensemble information if (write.to.db) { con <- try(PEcAn.DB::db.open(settings$database$bety), silent = TRUE) - if (methods::is(con, "try-error")) { + if (inherits(con, "try-error")) { con <- NULL } else { on.exit(PEcAn.DB::db.close(con)) diff --git a/base/utils/R/sensitivity.R b/base/utils/R/sensitivity.R index e2dedc4bda0..e7a25da1a8b 100644 --- a/base/utils/R/sensitivity.R +++ b/base/utils/R/sensitivity.R @@ -90,7 +90,7 @@ write.sa.configs <- function(defaults, quantile.samples, settings, model, if (write.to.db) { con <- try(PEcAn.DB::db.open(settings$database$bety), silent = TRUE) - if (methods::is(con, "try-error")) { + if (inherits(con, "try-error")) { con <- NULL } else { on.exit(PEcAn.DB::db.close(con)) diff --git a/base/utils/tests/testthat/test.SafeList.class.R b/base/utils/tests/testthat/test.SafeList.class.R index e28d7e03ddd..f1f6370446e 100644 --- a/base/utils/tests/testthat/test.SafeList.class.R +++ b/base/utils/tests/testthat/test.SafeList.class.R @@ -20,8 +20,8 @@ test_that("SafeList constructors work as expected", { expect_identical(s1, s2) expect_identical(s1, s3) - expect_true(is(s1, "list")) - expect_true(is(s1, "SafeList")) + expect_true(inherits(s1, "list")) + expect_true(inherits(s1, "SafeList")) expect_true(is.SafeList(s1)) expect_false(is.SafeList(l)) expect_equal(length(class(s1)), 2) From 69b6d0be65b78236e67e5ebf851152a0520677a5 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Tue, 19 Sep 2017 21:49:23 -0400 Subject: [PATCH 709/771] roxygen cleanup Document many parameters, linewrapping, typo fixes --- base/remote/R/open.tunnel.R | 4 +-- base/remote/R/remote.copy.update.R | 4 +-- base/remote/man/open_tunnel.Rd | 6 ++-- base/utils/R/SafeList.R | 7 +++- base/utils/R/days_in_year.R | 2 +- base/utils/R/do_conversions.R | 4 +++ base/utils/R/download.url.R | 6 ++-- base/utils/R/get.ensemble.inputs.R | 2 +- base/utils/R/listToArgString.R | 4 +-- base/utils/R/mcmc.list2init.R | 1 - base/utils/R/n_leap_day.R | 3 +- base/utils/R/plots.R | 7 ++-- base/utils/R/to_nc.R | 9 +++--- base/utils/R/utils.R | 44 +++++++++++++------------- base/utils/man/SafeList.Rd | 13 ++++++++ base/utils/man/days_in_year.Rd | 3 ++ base/utils/man/do_conversions.Rd | 5 +++ base/utils/man/download.url.Rd | 10 +++--- base/utils/man/get.ensemble.inputs.Rd | 2 ++ base/utils/man/get.parameter.stat.Rd | 5 +++ base/utils/man/get.stats.mcmc.Rd | 5 +++ base/utils/man/listToArgString.Rd | 5 ++- base/utils/man/listToXml.default.Rd | 2 ++ base/utils/man/n_leap_day.Rd | 3 ++ base/utils/man/newxtable.Rd | 2 ++ base/utils/man/paste.stats.Rd | 15 ++++++++- base/utils/man/ssh.Rd | 7 ++++ base/utils/man/temp.settings.Rd | 3 ++ base/utils/man/theme_border.Rd | 7 ++-- base/utils/man/to_ncdim.Rd | 5 ++- base/utils/man/to_ncvar.Rd | 5 ++- base/utils/man/zero.bounded.density.Rd | 6 +++- 32 files changed, 148 insertions(+), 58 deletions(-) diff --git a/base/remote/R/open.tunnel.R b/base/remote/R/open.tunnel.R index 4895671481b..79acbeb506c 100644 --- a/base/remote/R/open.tunnel.R +++ b/base/remote/R/open.tunnel.R @@ -1,4 +1,4 @@ -#' Open an SSH tunnel +#' Open an SSH tunnel, prompting for passwords as needed #' #' @param remote_host name of remote server to connect to (e.g. geo.bu.edu) #' @param tunnel_dir directory to store tunnel file in, typically from settings$host @@ -7,7 +7,7 @@ #' @param wait.time how long to give system to connect before deleting password (seconds) #' @param tunnel_script Path to sshtunnel.sh script file for opening tunnel #' -#' @return `TRUE` if successful, or `FALSE` otherwise +#' @return numeric giving ssh PID if configured, otherwise logical with TRUE = success #' @export open_tunnel <- function(remote_host, user = NULL, password = NULL, tunnel_dir = "~/.pecan/tunnel/", wait.time = 15, tunnel_script = '~/pecan/web/sshtunnel.sh'){ diff --git a/base/remote/R/remote.copy.update.R b/base/remote/R/remote.copy.update.R index 455ba63b66c..19ff1d5ea1e 100644 --- a/base/remote/R/remote.copy.update.R +++ b/base/remote/R/remote.copy.update.R @@ -13,7 +13,7 @@ remote.copy.update <- function(input_id, remote_dir, remote_file_name = NULL, ho PEcAn.remote::remote.execute.cmd(host, "mkdir", c("-p", remote_dir)) - local_file_record <- db.query(paste("SELECT * from dbfiles where container_id =", input_id), con) + local_file_record <- PEcAn.DB::db.query(paste("SELECT * from dbfiles where container_id =", input_id), con) if(is.null(remote_file_name)){ local_file_name <- local_file_record$file_name @@ -31,7 +31,7 @@ remote.copy.update <- function(input_id, remote_dir, remote_file_name = NULL, ho remote.copy.to(host, local_file_path, remote_file_path) # update DB record - remote_id <- dbfile.insert(in.path = remote_dir, in.prefix = remote_file_name, + remote_id <- PEcAn.DB::dbfile.insert(in.path = remote_dir, in.prefix = remote_file_name, type = local_file_record$container_type, id = local_file_record$container_id, con = con, hostname = host$name) diff --git a/base/remote/man/open_tunnel.Rd b/base/remote/man/open_tunnel.Rd index afcbf0ab13f..7c577a73f4e 100644 --- a/base/remote/man/open_tunnel.Rd +++ b/base/remote/man/open_tunnel.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/open.tunnel.R \name{open_tunnel} \alias{open_tunnel} -\title{Open an SSH tunnel} +\title{Open an SSH tunnel, prompting for passwords as needed} \usage{ open_tunnel(remote_host, user = NULL, password = NULL, tunnel_dir = "~/.pecan/tunnel/", wait.time = 15, @@ -22,8 +22,8 @@ open_tunnel(remote_host, user = NULL, password = NULL, \item{tunnel_script}{Path to sshtunnel.sh script file for opening tunnel} } \value{ -\code{TRUE} if successful, or \code{FALSE} otherwise +numeric giving ssh PID if configured, otherwise logical with TRUE = success } \description{ -Open an SSH tunnel +Open an SSH tunnel, prompting for passwords as needed } diff --git a/base/utils/R/SafeList.R b/base/utils/R/SafeList.R index 1cd512ccef4..93b765b9d12 100644 --- a/base/utils/R/SafeList.R +++ b/base/utils/R/SafeList.R @@ -38,13 +38,18 @@ SafeList <- function(...) { ##' @export -##' @describeIn SafeList Coerce an object to SafeList. +##' @describeIn SafeList Coerce an object to SafeList. +##' @param x list to coerce +##' @return a SafeList version of x as.SafeList <- function(x) { return(SafeList(x)) } # as.SafeList ##' @export +##' @describeIn SafeList Test if object is already a SafeList. +##' @param x list object to be tested +##' @return logical is.SafeList <- function(x) { inherits(x, "SafeList") } # is.SafeList diff --git a/base/utils/R/days_in_year.R b/base/utils/R/days_in_year.R index 4192f4f8459..42eca3c01ca 100644 --- a/base/utils/R/days_in_year.R +++ b/base/utils/R/days_in_year.R @@ -5,7 +5,7 @@ #' @param year Numeric year (can be a vector) #' #' @author Alexey Shiklomanov -#' @return +#' @return integer vector, all either 365 or 366 #' @export #' @examples #' days_in_year(2010) # Not a leap year -- returns 365 diff --git a/base/utils/R/do_conversions.R b/base/utils/R/do_conversions.R index 1e3075b5a52..d7346b051b8 100644 --- a/base/utils/R/do_conversions.R +++ b/base/utils/R/do_conversions.R @@ -3,6 +3,10 @@ ##' @name do_conversions ##' @title do_conversions ##' @description Input conversion workflow +##' +##' @param settings PEcAn settings list +##' @param overwrite.met,overwrite.fia,overwrite.ic logical +##' ##' @author Ryan Kelly, Rob Kooper, Betsy Cowdery, Istem Fer do_conversions <- function(settings, overwrite.met = FALSE, overwrite.fia = FALSE, overwrite.ic = FALSE) { if (PEcAn.settings::is.MultiSettings(settings)) { diff --git a/base/utils/R/download.url.R b/base/utils/R/download.url.R index e99b31b8d04..a1595953003 100644 --- a/base/utils/R/download.url.R +++ b/base/utils/R/download.url.R @@ -8,13 +8,13 @@ ##' @name download.url ##' @title Download file from the url. ##' @export -##' @param the url of the file to download -##' @param the filename +##' @param url the url of the file to download +##' @param file the filename ##' @param timeout number of seconds to wait for file (default 600) ##' @param list of options for curl, for example to download from a ##' protected site use list(userpwd=userpass, httpauth = 1L) ##' @param retry404 retry on a 404, this is used by Brown Dog -##' @return returns name of file if successfull or NA if not. +##' @return returns name of file if successful or NA if not. ##' ##' @examples ##' \dontrun{ diff --git a/base/utils/R/get.ensemble.inputs.R b/base/utils/R/get.ensemble.inputs.R index 0572f378636..bcc7a5553ea 100644 --- a/base/utils/R/get.ensemble.inputs.R +++ b/base/utils/R/get.ensemble.inputs.R @@ -3,7 +3,7 @@ ##' @name get.ensemble.inputs ##' @author Mike Dietze and Ann Raiho ##' -##' @param settings +##' @param settings PEcAn settings list ##' @param ens ensemble number. default = 1 ##' @description Splits climate met for SIPNET ##' diff --git a/base/utils/R/listToArgString.R b/base/utils/R/listToArgString.R index a2b076f51a8..68d56d599d2 100644 --- a/base/utils/R/listToArgString.R +++ b/base/utils/R/listToArgString.R @@ -1,5 +1,5 @@ -##' @name listToArgString -##' @title listToArgString +##' format a list of arguments as one comma-separated string +##' ##' @export ##' ##' @param l a named list of function arguments diff --git a/base/utils/R/mcmc.list2init.R b/base/utils/R/mcmc.list2init.R index 1cabcccfb28..5da90e1db69 100644 --- a/base/utils/R/mcmc.list2init.R +++ b/base/utils/R/mcmc.list2init.R @@ -9,7 +9,6 @@ #' @return list #' @export #' -#' @examples mcmc.list2init <- function(dat) { ## get unique variable names diff --git a/base/utils/R/n_leap_day.R b/base/utils/R/n_leap_day.R index 17c6bd6140d..0bbdae568e2 100644 --- a/base/utils/R/n_leap_day.R +++ b/base/utils/R/n_leap_day.R @@ -2,8 +2,7 @@ ##' @title n_leap_day ##' @description number of leap days between two dates ##' @author Mike Dietze -##' @param start_date -##' @param end_date +##' @param start_date,end_date dates in any format recognized by \code{\link[base]{as.Date}} ##' @export n_leap_day <- function(start_date, end_date) { diff --git a/base/utils/R/plots.R b/base/utils/R/plots.R index 3e099fbab2d..35054f67594 100644 --- a/base/utils/R/plots.R +++ b/base/utils/R/plots.R @@ -251,9 +251,12 @@ plot_data <- function(trait.data, base.plot = NULL, ymax, color = "black") { #--------------------------------------------------------------------------------------------------# -##' Add borders to .. content for \description{} (no empty lines) .. +##' Add borders to plot ##' -##' Has ggplot2 display only specified borders, e.g. ('L'-shaped) borders, rather than a rectangle or no border. Note that the order can be significant; for example, if you specify the L border option and then a theme, the theme settings will override the border option, so you need to specify the theme (if any) before the border option, as above. +##' Has ggplot2 display only specified borders, e.g. ('L'-shaped) borders, +##' rather than a rectangle or no border. Note that the order can be significant; +##' for example, if you specify the L border option and then a theme, the theme settings +##' will override the border option, so you need to specify the theme (if any) before the border option, as above. ##' @name theme_border ##' @title Theme border for plot ##' @param type diff --git a/base/utils/R/to_nc.R b/base/utils/R/to_nc.R index bf82e8c05a9..26beec2cd7e 100644 --- a/base/utils/R/to_nc.R +++ b/base/utils/R/to_nc.R @@ -1,5 +1,6 @@ -##' @name to_ncdim -##' @title to_ncdim +##' Make some values into an NCDF dimension variable +##' +##' Units and longnames are looked up from the \code{\link{standard_vars}} table ##' @export ##' ##' @param dimname character vector, standard dimension name (must be in PEcAn.utils::standard_vars) @@ -29,8 +30,8 @@ to_ncdim <- function(dimname,vals){ } #to_ncdim -##' @name to_ncvar -##' @title to_ncvar +##' Define an NCDF variable +##' ##' @export ##' ##' @param varname character vector, standard variable name (must be in PEcAn.utils::standard_vars) diff --git a/base/utils/R/utils.R b/base/utils/R/utils.R index 2a04c02fccb..fd2e8e1a055 100644 --- a/base/utils/R/utils.R +++ b/base/utils/R/utils.R @@ -124,9 +124,9 @@ rsync <- function(args, from, to, pattern = "") { ##' R implementation of SSH ##' ##' @title SSH -##' @param host -##' @param ... -##' @param args +##' @param host (character) machine to connect to +##' @param ... Commands to execute. Will be passed as a single quoted string +##' @param args futher arguments ##' @export #--------------------------------------------------------------------------------------------------# ssh <- function(host, ..., args = "") { @@ -185,7 +185,7 @@ listToXml <- function(x, ...) { ##' ##' Can convert list or other object to an xml object using xmlNode ##' @title List to XML -##' @param item +##' @param item object to be converted. Despite the function name, need not actually be a list ##' @param tag xml tag ##' @return xmlNode ##' @export @@ -233,9 +233,11 @@ listToXml.default <- function(item, tag) { ##' Zero bounded density using log density transform ##' ##' Provides a zero bounded density estimate of a parameter. -##' Kernel Density Estimation used by the \code{\link{stats::density}} function will cause problems at the left hand end because it will put some weight on negative values. One useful approach is to transform to logs, estimate the density using KDE, and then transform back. +##' Kernel Density Estimation used by the \code{\link[stats]{density}} function will cause problems +##' at the left hand end because it will put some weight on negative values. +##' One useful approach is to transform to logs, estimate the density using KDE, and then transform back. ##' @title Zero Bounded Density -##' @param x +##' @param x data, as a numeric vector ##' @param bw The smoothing bandwidth to be used. See 'bw.nrd' ##' @return data frame with back-transformed log density estimate ##' @author \href{http://stats.stackexchange.com/q/6588/2750}{Rob Hyndman} @@ -275,8 +277,8 @@ summarize.result <- function(result) { ##' Further summarizes output from summary.mcmc ##' ##' @title Get stats for parameters in MCMC output -##' @param mcmc.summary -##' @param sample.size +##' @param mcmc.summary probably produced by \code{\link[coda]{summary.mcmc}} +##' @param sample.size passed as 'n' in returned list ##' @return list with summary statistics for parameters in an MCMC chain ##' @author David LeBauer get.stats.mcmc <- function(mcmc.summary, sample.size) { @@ -299,14 +301,16 @@ get.stats.mcmc <- function(mcmc.summary, sample.size) { ##' Used by \code{\link{get.parameter.stat}}. ##' @title Paste Stats ##' @name paste.stats -##' @param mcmc.summary -##' @param median -##' @param lcl -##' @param ucl -##' @param n +##' @param median 50-percent quantile +##' @param lcl lower confidence limit +##' @param ucl upper confidence limit +##' @param n significant digits for printing. Passed to \code{\link{tabnum}} ##' @export ##' @author David LeBauer -paste.stats <- function(mcmc.summary, median, lcl, ucl, n = 2) { +##' @examples +##' paste.stats(3.333333, 5.00001, 6.22222, n = 3) +##' # [1] "$3.33(5,6.22)$" +paste.stats <- function(median, lcl, ucl, n = 2) { paste0("$", tabnum(median, n), "(", tabnum(lcl, n), ",", tabnum(ucl, n), ")", "$") @@ -317,8 +321,8 @@ paste.stats <- function(mcmc.summary, median, lcl, ucl, n = 2) { ##' Gets statistics for LaTeX - formatted table ##' ##' @title Get Parameter Statistics -##' @param mcmc.summary -##' @param parameter +##' @param mcmc.summary probably produced by \code{\link[coda]{summary.mcmc}} +##' @param parameter name of parameter to extract, as character ##' @return table with parameter statistics ##' @author David LeBauer ##' @export @@ -462,11 +466,7 @@ isFALSE <- function(x) !isTRUE(x) ##' @title newxtable ##' @param x data.frame to be converted to latex table ##' @param environment can be 'table'; 'sidewaystable' if using latex rotating package -##' @param table.placement -##' @param label -##' @param caption -##' @param caption.placement -##' @param align +##' @param table.placement,label,caption,caption.placement,align passed to \code{\link[xtable]{xtable}} ##' @return Latex version of table, with percentages properly formatted ##' @author David LeBauer newxtable <- function(x, environment = "table", table.placement = "ht", label = NULL, @@ -529,7 +529,7 @@ as.sequence <- function(x, na.rm = TRUE) { ##' Useful for testing functions that depend on settings file ##' Reference: http://stackoverflow.com/a/12940705/199217 ##' @title temp.settings -##' @param settings.txt +##' @param settings.txt character vector to be written ##' @return character vector written to and read from a temporary file ##' @export ##' @author David LeBauer diff --git a/base/utils/man/SafeList.Rd b/base/utils/man/SafeList.Rd index 45990309361..80ef577d83d 100644 --- a/base/utils/man/SafeList.Rd +++ b/base/utils/man/SafeList.Rd @@ -3,17 +3,28 @@ \name{SafeList} \alias{SafeList} \alias{as.SafeList} +\alias{is.SafeList} \title{Constrct SafeList Object} \usage{ SafeList(...) as.SafeList(x) + +is.SafeList(x) } \arguments{ \item{...}{A list to upgrade to SafeList, or elements to be added to a new SafeList} + +\item{x}{list to coerce} + +\item{x}{list object to be tested} } \value{ The resulting SafeList + +a SafeList version of x + +logical } \description{ Create a SafeList object @@ -31,6 +42,8 @@ attribute updated to include 'SafeList', or \section{Functions}{ \itemize{ \item \code{as.SafeList}: Coerce an object to SafeList. + +\item \code{is.SafeList}: Test if object is already a SafeList. }} \author{ diff --git a/base/utils/man/days_in_year.Rd b/base/utils/man/days_in_year.Rd index 8ddb24ff2e5..a0d291ecd9d 100644 --- a/base/utils/man/days_in_year.Rd +++ b/base/utils/man/days_in_year.Rd @@ -9,6 +9,9 @@ days_in_year(year) \arguments{ \item{year}{Numeric year (can be a vector)} } +\value{ +integer vector, all either 365 or 366 +} \description{ Calculate number of days in a year based on whether it is a leap year or not. } diff --git a/base/utils/man/do_conversions.Rd b/base/utils/man/do_conversions.Rd index 19c7c03f854..ee42a47225a 100644 --- a/base/utils/man/do_conversions.Rd +++ b/base/utils/man/do_conversions.Rd @@ -8,6 +8,11 @@ do_conversions(settings, overwrite.met = FALSE, overwrite.fia = FALSE, overwrite.ic = FALSE) } +\arguments{ +\item{settings}{PEcAn settings list} + +\item{overwrite.met, overwrite.fia, overwrite.ic}{logical} +} \description{ Input conversion workflow } diff --git a/base/utils/man/download.url.Rd b/base/utils/man/download.url.Rd index 62d9586d871..af7ef90e356 100644 --- a/base/utils/man/download.url.Rd +++ b/base/utils/man/download.url.Rd @@ -7,19 +7,19 @@ download.url(url, file, timeout = 600, .opts = list(), retry404 = TRUE) } \arguments{ -\item{timeout}{number of seconds to wait for file (default 600)} +\item{url}{the url of the file to download} -\item{retry404}{retry on a 404, this is used by Brown Dog} +\item{file}{the filename} -\item{the}{url of the file to download} +\item{timeout}{number of seconds to wait for file (default 600)} -\item{the}{filename} +\item{retry404}{retry on a 404, this is used by Brown Dog} \item{list}{of options for curl, for example to download from a protected site use list(userpwd=userpass, httpauth = 1L)} } \value{ -returns name of file if successfull or NA if not. +returns name of file if successful or NA if not. } \description{ Try and download a file. diff --git a/base/utils/man/get.ensemble.inputs.Rd b/base/utils/man/get.ensemble.inputs.Rd index e3f627e76aa..18478ba1ea1 100644 --- a/base/utils/man/get.ensemble.inputs.Rd +++ b/base/utils/man/get.ensemble.inputs.Rd @@ -7,6 +7,8 @@ get.ensemble.inputs(settings, ens = 1) } \arguments{ +\item{settings}{PEcAn settings list} + \item{ens}{ensemble number. default = 1} } \value{ diff --git a/base/utils/man/get.parameter.stat.Rd b/base/utils/man/get.parameter.stat.Rd index 68b6c7bc337..9a6f87d1386 100644 --- a/base/utils/man/get.parameter.stat.Rd +++ b/base/utils/man/get.parameter.stat.Rd @@ -6,6 +6,11 @@ \usage{ get.parameter.stat(mcmc.summary, parameter) } +\arguments{ +\item{mcmc.summary}{probably produced by \code{\link[coda]{summary.mcmc}}} + +\item{parameter}{name of parameter to extract, as character} +} \value{ table with parameter statistics } diff --git a/base/utils/man/get.stats.mcmc.Rd b/base/utils/man/get.stats.mcmc.Rd index fc2f83426c0..00f6af0a576 100644 --- a/base/utils/man/get.stats.mcmc.Rd +++ b/base/utils/man/get.stats.mcmc.Rd @@ -6,6 +6,11 @@ \usage{ get.stats.mcmc(mcmc.summary, sample.size) } +\arguments{ +\item{mcmc.summary}{probably produced by \code{\link[coda]{summary.mcmc}}} + +\item{sample.size}{passed as 'n' in returned list} +} \value{ list with summary statistics for parameters in an MCMC chain } diff --git a/base/utils/man/listToArgString.Rd b/base/utils/man/listToArgString.Rd index e5dfead3799..17c92173cb8 100644 --- a/base/utils/man/listToArgString.Rd +++ b/base/utils/man/listToArgString.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/listToArgString.R \name{listToArgString} \alias{listToArgString} -\title{listToArgString} +\title{format a list of arguments as one comma-separated string} \usage{ listToArgString(l) } @@ -12,6 +12,9 @@ listToArgString(l) \value{ A string containing named argument/value pairs separated by commas } +\description{ +format a list of arguments as one comma-separated string +} \author{ Ryan Kelly } diff --git a/base/utils/man/listToXml.default.Rd b/base/utils/man/listToXml.default.Rd index 855fb47f31c..3ef931bdcf2 100644 --- a/base/utils/man/listToXml.default.Rd +++ b/base/utils/man/listToXml.default.Rd @@ -7,6 +7,8 @@ \method{listToXml}{default}(item, tag) } \arguments{ +\item{item}{object to be converted. Despite the function name, need not actually be a list} + \item{tag}{xml tag} } \value{ diff --git a/base/utils/man/n_leap_day.Rd b/base/utils/man/n_leap_day.Rd index 2c2bedc224b..be252682fef 100644 --- a/base/utils/man/n_leap_day.Rd +++ b/base/utils/man/n_leap_day.Rd @@ -6,6 +6,9 @@ \usage{ n_leap_day(start_date, end_date) } +\arguments{ +\item{start_date, end_date}{dates in any format recognized by \code{\link[base]{as.Date}}} +} \description{ number of leap days between two dates } diff --git a/base/utils/man/newxtable.Rd b/base/utils/man/newxtable.Rd index 4e769656bcc..cd84d688b0c 100644 --- a/base/utils/man/newxtable.Rd +++ b/base/utils/man/newxtable.Rd @@ -11,6 +11,8 @@ newxtable(x, environment = "table", table.placement = "ht", label = NULL, \item{x}{data.frame to be converted to latex table} \item{environment}{can be 'table'; 'sidewaystable' if using latex rotating package} + +\item{table.placement, label, caption, caption.placement, align}{passed to \code{\link[xtable]{xtable}}} } \value{ Latex version of table, with percentages properly formatted diff --git a/base/utils/man/paste.stats.Rd b/base/utils/man/paste.stats.Rd index 22116462cd9..fa07de14d68 100644 --- a/base/utils/man/paste.stats.Rd +++ b/base/utils/man/paste.stats.Rd @@ -4,7 +4,16 @@ \alias{paste.stats} \title{Paste Stats} \usage{ -paste.stats(mcmc.summary, median, lcl, ucl, n = 2) +paste.stats(median, lcl, ucl, n = 2) +} +\arguments{ +\item{median}{50-percent quantile} + +\item{lcl}{lower confidence limit} + +\item{ucl}{upper confidence limit} + +\item{n}{significant digits for printing. Passed to \code{\link{tabnum}}} } \description{ A helper function for building a LaTex table. @@ -12,6 +21,10 @@ A helper function for building a LaTex table. \details{ Used by \code{\link{get.parameter.stat}}. } +\examples{ +paste.stats(3.333333, 5.00001, 6.22222, n = 3) +# [1] "$3.33(5,6.22)$" +} \author{ David LeBauer } diff --git a/base/utils/man/ssh.Rd b/base/utils/man/ssh.Rd index 48e35cd3a8b..bacc286f4d9 100644 --- a/base/utils/man/ssh.Rd +++ b/base/utils/man/ssh.Rd @@ -6,6 +6,13 @@ \usage{ ssh(host, ..., args = "") } +\arguments{ +\item{host}{(character) machine to connect to} + +\item{...}{Commands to execute. Will be passed as a single quoted string} + +\item{args}{futher arguments} +} \description{ R implementation of SSH } diff --git a/base/utils/man/temp.settings.Rd b/base/utils/man/temp.settings.Rd index 7490477900b..fa5e643ba98 100644 --- a/base/utils/man/temp.settings.Rd +++ b/base/utils/man/temp.settings.Rd @@ -6,6 +6,9 @@ \usage{ temp.settings(settings.txt) } +\arguments{ +\item{settings.txt}{character vector to be written} +} \value{ character vector written to and read from a temporary file } diff --git a/base/utils/man/theme_border.Rd b/base/utils/man/theme_border.Rd index a9f400c8c34..cd8d23a63f2 100644 --- a/base/utils/man/theme_border.Rd +++ b/base/utils/man/theme_border.Rd @@ -20,10 +20,13 @@ theme_border(type = c("left", "right", "bottom", "top", "none"), adds borders to ggplot as a side effect } \description{ -Add borders to .. content for \description{} (no empty lines) .. +Add borders to plot } \details{ -Has ggplot2 display only specified borders, e.g. ('L'-shaped) borders, rather than a rectangle or no border. Note that the order can be significant; for example, if you specify the L border option and then a theme, the theme settings will override the border option, so you need to specify the theme (if any) before the border option, as above. +Has ggplot2 display only specified borders, e.g. ('L'-shaped) borders, +rather than a rectangle or no border. Note that the order can be significant; +for example, if you specify the L border option and then a theme, the theme settings +will override the border option, so you need to specify the theme (if any) before the border option, as above. } \examples{ \dontrun{ diff --git a/base/utils/man/to_ncdim.Rd b/base/utils/man/to_ncdim.Rd index e5df5113b90..189c00a71bd 100644 --- a/base/utils/man/to_ncdim.Rd +++ b/base/utils/man/to_ncdim.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/to_nc.R \name{to_ncdim} \alias{to_ncdim} -\title{to_ncdim} +\title{Make some values into an NCDF dimension variable} \usage{ to_ncdim(dimname, vals) } @@ -14,6 +14,9 @@ to_ncdim(dimname, vals) \value{ ncdim defined according to standard_vars } +\description{ +Units and longnames are looked up from the \code{\link{standard_vars}} table +} \author{ Anne Thomas } diff --git a/base/utils/man/to_ncvar.Rd b/base/utils/man/to_ncvar.Rd index fb69a14a19b..4d1df9d246c 100644 --- a/base/utils/man/to_ncvar.Rd +++ b/base/utils/man/to_ncvar.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/to_nc.R \name{to_ncvar} \alias{to_ncvar} -\title{to_ncvar} +\title{Define an NCDF variable} \usage{ to_ncvar(varname, dims) } @@ -14,6 +14,9 @@ to_ncvar(varname, dims) \value{ ncvar defined according to standard_vars } +\description{ +Define an NCDF variable +} \author{ Anne Thomas } diff --git a/base/utils/man/zero.bounded.density.Rd b/base/utils/man/zero.bounded.density.Rd index 76ae5a3f87e..5037f7b59e3 100644 --- a/base/utils/man/zero.bounded.density.Rd +++ b/base/utils/man/zero.bounded.density.Rd @@ -7,6 +7,8 @@ zero.bounded.density(x, bw = "SJ", n = 1001) } \arguments{ +\item{x}{data, as a numeric vector} + \item{bw}{The smoothing bandwidth to be used. See 'bw.nrd'} } \value{ @@ -17,7 +19,9 @@ Zero bounded density using log density transform } \details{ Provides a zero bounded density estimate of a parameter. -Kernel Density Estimation used by the \code{\link{stats::density}} function will cause problems at the left hand end because it will put some weight on negative values. One useful approach is to transform to logs, estimate the density using KDE, and then transform back. +Kernel Density Estimation used by the \code{\link[stats]{density}} function will cause problems +at the left hand end because it will put some weight on negative values. +One useful approach is to transform to logs, estimate the density using KDE, and then transform back. } \references{ M. P. Wand, J. S. Marron and D. Ruppert, 1991. Transformations in Density Estimation. Journal of the American Statistical Association. 86(414):343-353 \url{http://www.jstor.org/stable/2290569} From 4969ffb6f655312f9fff89a539985508730a7dee Mon Sep 17 00:00:00 2001 From: Chris Black Date: Tue, 19 Sep 2017 22:41:16 -0400 Subject: [PATCH 710/771] use standard_vars instead of mstmip --- base/utils/R/regrid.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/utils/R/regrid.R b/base/utils/R/regrid.R index 39622a5d55f..91acf3ed2a2 100644 --- a/base/utils/R/regrid.R +++ b/base/utils/R/regrid.R @@ -47,7 +47,7 @@ grid2netcdf <- function(gdata, date = "9999-09-09", outfile = "out.nc") { calendar = "standard", unlim = TRUE) - yieldvar <- mstmipvar("CropYield", lat, lon, time) + yieldvar <- to_ncvar("CropYield", list(lat, lon, time)) nc <- ncdf4::nc_create(filename = outfile, vars = list(CropYield = yieldvar)) ## Output netCDF data From c0f456d6e4d95cd97ce1a2dccdb990211452ccad Mon Sep 17 00:00:00 2001 From: Chris Black Date: Tue, 19 Sep 2017 22:42:26 -0400 Subject: [PATCH 711/771] no separator lines between docs and function defn --- base/utils/R/utils.R | 5 ----- 1 file changed, 5 deletions(-) diff --git a/base/utils/R/utils.R b/base/utils/R/utils.R index fd2e8e1a055..141265466a0 100644 --- a/base/utils/R/utils.R +++ b/base/utils/R/utils.R @@ -113,7 +113,6 @@ zero.truncate <- function(y) { ##' @export ##' @author David LeBauer ##' @author Shawn Serbin -#--------------------------------------------------------------------------------------------------# rsync <- function(args, from, to, pattern = "") { PEcAn.logger::logger.warn("NEED TO USE TUNNEL") system(paste0("rsync", " ", args, " ", from, pattern, " ", to), intern = TRUE) @@ -128,7 +127,6 @@ rsync <- function(args, from, to, pattern = "") { ##' @param ... Commands to execute. Will be passed as a single quoted string ##' @param args futher arguments ##' @export -#--------------------------------------------------------------------------------------------------# ssh <- function(host, ..., args = "") { PEcAn.logger::logger.warn("NEED TO USE TUNNEL") if (host == "localhost") { @@ -167,7 +165,6 @@ vecpaste <- function(x) paste(paste0("'", x, "'"), collapse = ",") ##' get.run.id('ENS', left.pad.zeros(1, 5)) ##' get.run.id('SA', round(qnorm(-3),3), trait = 'Vcmax') ##' @author Carl Davidson, David LeBauer -#--------------------------------------------------------------------------------------------------# get.run.id <- function(run.type, index, trait = NULL, pft.name = NULL) { result <- paste(c(run.type, pft.name, trait, index), collapse = "-") return(result) @@ -190,7 +187,6 @@ listToXml <- function(x, ...) { ##' @return xmlNode ##' @export ##' @author David LeBauer, Carl Davidson, Rob Kooper -#--------------------------------------------------------------------------------------------------# listToXml.default <- function(item, tag) { # just a textnode, or empty node with attributes @@ -748,7 +744,6 @@ download.file <- function(url, filename, method) { ##' ##' @export ##' @author Shawn Serbin - retry.func <- function(expr, isError=function(x) "try-error" %in% class(x), maxErrors=5, sleep=0) { attempts = 0 retval = try(eval(expr)) From eaf2b28dff7a0defcb94760c3f3467ea2bbf8467 Mon Sep 17 00:00:00 2001 From: adesai Date: Fri, 22 Sep 2017 14:38:32 -0500 Subject: [PATCH 712/771] Fix for NA in temperature on stopifnot debug in rh2qair --- modules/data.atmosphere/R/metutils.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/data.atmosphere/R/metutils.R b/modules/data.atmosphere/R/metutils.R index c5294b90858..e8c6cd5db60 100644 --- a/modules/data.atmosphere/R/metutils.R +++ b/modules/data.atmosphere/R/metutils.R @@ -43,7 +43,7 @@ qair2rh <- function(qair, temp, press = 1013.25) { ##' @author Mike Dietze, Ankur Desai ##' @aliases rh2rv rh2qair <- function(rh, T, press = 101325) { - stopifnot(T >= 0) + stopifnot(T[!is.na(T)] >= 0) Tc <- udunits2::ud.convert(T, "K", "degC") es <- 6.112 * exp((17.67 * Tc) / (Tc + 243.5)) e <- rh * es From 916af11cfc0d7b62d5788cee05b184956330cba9 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 23 Sep 2017 10:19:04 -0400 Subject: [PATCH 713/771] CHANGELOG copy-edits --- CHANGELOG.md | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index de9ec0e2b05..283e05f2f91 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,7 +6,6 @@ section for the next release. For more information about this file see also [Keep a Changelog](http://keepachangelog.com/) . ## [Unreleased] -- Created new (and very rudimentary) web interface for downloading data from the dataone federation into the PEcAn database. More updates to come. ### Fixes - Show workflowid in the URL when run is finshed and user clicks results (#1659) @@ -30,26 +29,23 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Remote execution is more robust to errors in the submission process, not just the actual model execution ### Added +- Created new (and very rudimentary) web interface for downloading data from the dataone federation into the PEcAn database. More updates to come. - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) - New `PEcAn.utils::days_in_year(year)` function that should make it easier to work with leap years. - New `PEcAn.data.atmosphere::solar_angle` function that replaces math that occurs in some models. - New `PEcAn.benchmarking::align_pft` fucntion that aligns data assosiated with two different plant functional types - - #1594 shiny/workflowPlot Adding interactiveness using ggploltly - #1594 shiny/workflowPlot Load outputs from multiple runs of the model - #1594 shiny/workflowPlot Ways to toggle geometries (e.g. geom_point vs. geom_line). - #1594 shiny/workflowPlot Smoothing using geom_smooth (Slider for specifying moving window width) - #1594 shiny/workflowPlot Comparing model output vs loaded data according to [tutorial](https://github.com/PecanProject/pecan/blob/develop/documentation/tutorials/AnalyzeOutput/modelVSdata.Rmd) - - Allow SIPNET and DALEC met files and model2netcdf to start or end mid year - - ### Changed - Clean up directory structure: * Move `base` packages (`utils`, `settings`, `db`, `visualizaton`) to a `base` directory, for consistency with `modules` and `models` * Move `logger.*` functions out of the `PEcAn.utils` package and into the `PEcAn.logger` package - * More `remote` functions out of the `PEcAn.utils` package and into their own `PEcAn.remote` package. + * Move `remote` functions out of the `PEcAn.utils` package and into their own `PEcAn.remote` package. - #1594 shiny/workflowPlot Refactoring of code. `get_workflow_ids` in db/R/query.dplyr.R changed with `ensemble = FALSE`. Also allowing to load all workflow IDs. `load_data_single_run` and `var_names_all` also moved from shiny/workflowPlot/server.R to query.dplyr.R - `PEcAn.remote::start.model.runs` has been significantly refactored to be less redundant and more robust - `betyConnect` function in `query.dplyr.R` is now refactored into `read_web_config` so that the the Data-Ingest app can leverage `read_web_config` and provide it with a machine specific filepath for `.../dbfiles` From a9f4ed682dc26fc4a86502432efc20fb9460ffe7 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 23 Sep 2017 10:26:02 -0400 Subject: [PATCH 714/771] typo --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 283e05f2f91..6e6c02f2d20 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,7 +9,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha ### Fixes - Show workflowid in the URL when run is finshed and user clicks results (#1659) -- `PEcAn.BIOCRO` now uses PEcAn-standard variable names. As a result, two output variables have been renamed but keep their exiting units and definitions: +- `PEcAn.BIOCRO` now uses PEcAn-standard variable names. As a result, two output variables have been renamed but keep their existing units and definitions: - `StemBiom` renamed to `AbvGrndWood` - `RootBiom` renamed to `root_carbon_content` - Improved make install logic (#1558) From 5828797e164ff632df65d794b940d07a9136d6c4 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 23 Sep 2017 12:39:02 -0400 Subject: [PATCH 715/771] move listToXml from PEcAn.utils to PEcAn.settings --- base/settings/NAMESPACE | 3 +- base/settings/R/MultiSettings.R | 1 - base/settings/R/clean.settings.R | 2 +- base/settings/R/listToXml.R | 52 +++++++++++++++++++ base/settings/R/write.settings.R | 2 +- base/settings/man/listToXml.default.Rd | 25 +++++++++ .../tests/testthat/test.MultiSettings.class.R | 2 +- base/utils/R/do_conversions.R | 2 +- base/utils/R/utils.R | 3 ++ base/utils/man/listToXml.default.Rd | 1 + models/biocro/R/write.configs.BIOCRO.R | 8 +-- models/ed/DESCRIPTION | 1 + models/ed/R/write.configs.ed.R | 6 +-- models/maat/DESCRIPTION | 1 + models/maat/R/met2model.MAAT.R | 2 +- models/maat/R/write.config.MAAT.R | 4 +- models/maat/inst/simple_workflow.R | 2 +- modules/assim.batch/DESCRIPTION | 1 + modules/assim.batch/R/pda.mcmc.R | 2 +- modules/assim.batch/R/pda.mcmc.bs.R | 2 +- modules/assim.batch/R/pda.postprocess.R | 2 +- modules/benchmark/DESCRIPTION | 1 + modules/benchmark/R/create_BRR.R | 2 +- scripts/workflow.bm.R | 6 +-- scripts/workflow.pda.R | 8 +-- tests/interactive-workflow.R | 4 +- 26 files changed, 115 insertions(+), 30 deletions(-) create mode 100644 base/settings/R/listToXml.R create mode 100644 base/settings/man/listToXml.default.Rd diff --git a/base/settings/NAMESPACE b/base/settings/NAMESPACE index e3eda5cd2e1..289c4a0219e 100644 --- a/base/settings/NAMESPACE +++ b/base/settings/NAMESPACE @@ -9,6 +9,7 @@ S3method("[[<-",MultiSettings) S3method("names<-",MultiSettings) S3method(expandMultiSettings,list) S3method(listToXml,MultiSettings) +S3method(listToXml,default) S3method(names,MultiSettings) S3method(print,MultiSettings) S3method(printAll,MultiSettings) @@ -33,6 +34,7 @@ export(fix.deprecated.settings) export(getRunSettings) export(is.MultiSettings) export(is.Settings) +export(listToXml) export(papply) export(prepare.settings) export(printAll) @@ -42,5 +44,4 @@ export(setOutDir) export(settingNames) export(update.settings) export(write.settings) -import(PEcAn.utils) import(XML) diff --git a/base/settings/R/MultiSettings.R b/base/settings/R/MultiSettings.R index c42daaf0ffa..8d6eee09471 100644 --- a/base/settings/R/MultiSettings.R +++ b/base/settings/R/MultiSettings.R @@ -163,7 +163,6 @@ printAll.MultiSettings <- function(multiSettings) { .expandableItemsTag <- "multisettings" -##' @import PEcAn.utils ##' @export listToXml.MultiSettings <- function(item, tag, collapse = TRUE) { if (collapse && length(item) > 1) { diff --git a/base/settings/R/clean.settings.R b/base/settings/R/clean.settings.R index f1d555d7e72..fba28a4b7bf 100644 --- a/base/settings/R/clean.settings.R +++ b/base/settings/R/clean.settings.R @@ -58,7 +58,7 @@ clean.settings <- function(inputfile = "pecan.xml", outputfile = "pecan.xml", wr settings$workflow <- NULL # save and done - if(write) XML::saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = outputfile) + if(write) XML::saveXML(listToXml(settings, "pecan"), file = outputfile) ## Return settings file as a list return(invisible(settings)) diff --git a/base/settings/R/listToXml.R b/base/settings/R/listToXml.R new file mode 100644 index 00000000000..e478d979766 --- /dev/null +++ b/base/settings/R/listToXml.R @@ -0,0 +1,52 @@ +##' @export +listToXml <- function(x, ...) { + UseMethod("listToXml") +} # listToXml + + +#--------------------------------------------------------------------------------------------------# +##' Convert List to XML +##' +##' Can convert list or other object to an xml object using xmlNode +##' @title List to XML +##' @param item object to be converted. Despite the function name, need not actually be a list +##' @param tag xml tag +##' @return xmlNode +##' @export +##' @author David LeBauer, Carl Davidson, Rob Kooper +listToXml.default <- function(item, tag) { + + # just a textnode, or empty node with attributes + if (typeof(item) != "list") { + if (length(item) > 1) { + xml <- XML::xmlNode(tag) + for (name in names(item)) { + XML::xmlAttrs(xml)[[name]] <- item[[name]] + } + return(xml) + } else { + return(XML::xmlNode(tag, item)) + } + } + + # create the node + if (identical(names(item), c("text", ".attrs"))) { + # special case a node with text and attributes + xml <- XML::xmlNode(tag, item[["text"]]) + } else { + # node with child nodes + xml <- XML::xmlNode(tag) + for (i in seq_along(item)) { + if (is.null(names(item)) || names(item)[i] != ".attrs") { + xml <- XML::append.xmlNode(xml, listToXml(item[[i]], names(item)[i])) + } + } + } + + # add attributes to node + attrs <- item[[".attrs"]] + for (name in names(attrs)) { + XML::xmlAttrs(xml)[[name]] <- attrs[[name]] + } + return(xml) +} # listToXml.default diff --git a/base/settings/R/write.settings.R b/base/settings/R/write.settings.R index 488d1c282f5..0bf22b6000f 100644 --- a/base/settings/R/write.settings.R +++ b/base/settings/R/write.settings.R @@ -14,5 +14,5 @@ write.settings <- function(settings, outputfile, outputdir=settings$outdir){ if (file.exists(pecanfile)) { PEcAn.logger::logger.warn(paste("File already exists [", pecanfile, "] file will be overwritten")) } - saveXML(PEcAn.utils::listToXml(settings, "pecan"), file=pecanfile) + saveXML(listToXml(settings, "pecan"), file=pecanfile) } diff --git a/base/settings/man/listToXml.default.Rd b/base/settings/man/listToXml.default.Rd new file mode 100644 index 00000000000..1e169d89a5b --- /dev/null +++ b/base/settings/man/listToXml.default.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/listToXml.R +\name{listToXml.default} +\alias{listToXml.default} +\title{List to XML} +\usage{ +\method{listToXml}{default}(item, tag) +} +\arguments{ +\item{item}{object to be converted. Despite the function name, need not actually be a list} + +\item{tag}{xml tag} +} +\value{ +xmlNode +} +\description{ +Convert List to XML +} +\details{ +Can convert list or other object to an xml object using xmlNode +} +\author{ +David LeBauer, Carl Davidson, Rob Kooper +} diff --git a/base/settings/tests/testthat/test.MultiSettings.class.R b/base/settings/tests/testthat/test.MultiSettings.class.R index 6c15a1ee7cf..9fb10d710fc 100644 --- a/base/settings/tests/testthat/test.MultiSettings.class.R +++ b/base/settings/tests/testthat/test.MultiSettings.class.R @@ -289,7 +289,7 @@ are.equal.possiblyNumericToCharacter <- function(o1, o2) { test_that("multiSettings write to and read from xml as expcted (i.e., with collapsing/expanding global settings)", { msOrig <- multiSettingsTemplate - msXML <- PEcAn.utils::listToXml(msOrig, "pecan.multi") + msXML <- PEcAn.settings::listToXml(msOrig, "pecan.multi") listNew <- XML::xmlToList(msXML) msNew <- expandMultiSettings(listNew) diff --git a/base/utils/R/do_conversions.R b/base/utils/R/do_conversions.R index d7346b051b8..9e3f5040002 100644 --- a/base/utils/R/do_conversions.R +++ b/base/utils/R/do_conversions.R @@ -90,7 +90,7 @@ do_conversions <- function(settings, overwrite.met = FALSE, overwrite.fia = FALS } } if (needsave) { - XML::saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.METProcess.xml")) + XML::saveXML(PEcAn.settings::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.METProcess.xml")) } else if (file.exists(file.path(settings$outdir, "pecan.METProcess.xml"))) { settings <- PEcAn.settings::read.settings(file.path(settings$outdir, "pecan.METProcess.xml")) } diff --git a/base/utils/R/utils.R b/base/utils/R/utils.R index 141265466a0..c76ae6704d3 100644 --- a/base/utils/R/utils.R +++ b/base/utils/R/utils.R @@ -173,6 +173,7 @@ get.run.id <- function(run.type, index, trait = NULL, pft.name = NULL) { ##' @export listToXml <- function(x, ...) { + .Deprecated("PEcAn.settings::listToXml") UseMethod("listToXml") } # listToXml @@ -180,6 +181,7 @@ listToXml <- function(x, ...) { #--------------------------------------------------------------------------------------------------# ##' Convert List to XML ##' +##' DEPRECATED. Use \code{\link[PEcAn.settings:listToXml.default]{PEcAn.settings::listToXml.default}} instead. ##' Can convert list or other object to an xml object using xmlNode ##' @title List to XML ##' @param item object to be converted. Despite the function name, need not actually be a list @@ -188,6 +190,7 @@ listToXml <- function(x, ...) { ##' @export ##' @author David LeBauer, Carl Davidson, Rob Kooper listToXml.default <- function(item, tag) { + .Deprecated("PEcAn.settings::listToXml.default") # just a textnode, or empty node with attributes if (typeof(item) != "list") { diff --git a/base/utils/man/listToXml.default.Rd b/base/utils/man/listToXml.default.Rd index 3ef931bdcf2..73b44466887 100644 --- a/base/utils/man/listToXml.default.Rd +++ b/base/utils/man/listToXml.default.Rd @@ -18,6 +18,7 @@ xmlNode Convert List to XML } \details{ +DEPRECATED. Use \code{\link[PEcAn.settings:listToXml.default]{PEcAn.settings::listToXml.default}} instead. Can convert list or other object to an xml object using xmlNode } \author{ diff --git a/models/biocro/R/write.configs.BIOCRO.R b/models/biocro/R/write.configs.BIOCRO.R index 308b71c2106..9d59a4c6945 100644 --- a/models/biocro/R/write.configs.BIOCRO.R +++ b/models/biocro/R/write.configs.BIOCRO.R @@ -159,18 +159,18 @@ write.config.BIOCRO <- function(defaults = NULL, trait.values, settings, run.id) ## this is where soil parms can be set defaults$soilControl$FieldC <- ### Put defaults and other parts of config file together - parms.xml <- PEcAn.utils::listToXml(defaults, "pft") - location.xml <- PEcAn.utils::listToXml(list(latitude = settings$run$site$lat, + parms.xml <- PEcAn.settings::listToXml(defaults, "pft") + location.xml <- PEcAn.settings::listToXml(list(latitude = settings$run$site$lat, longitude = settings$run$site$lon), "location") - run.xml <- PEcAn.utils::listToXml(list(start.date = settings$run$start.date, + run.xml <- PEcAn.settings::listToXml(list(start.date = settings$run$start.date, end.date = settings$run$end.date, met.path = settings$run$inputs$met$path, soil.file = settings$run$inputs$soil$path), "run") slashdate <- function(x) substr(gsub("-", "/", x), 1, 10) - simulationPeriod.xml <- PEcAn.utils::listToXml(list(dateofplanting = slashdate(settings$run$start.date), + simulationPeriod.xml <- PEcAn.settings::listToXml(list(dateofplanting = slashdate(settings$run$start.date), dateofharvest = slashdate(settings$run$end.date)), "simulationPeriod") diff --git a/models/ed/DESCRIPTION b/models/ed/DESCRIPTION index 417bc64232f..c6f4a244b2a 100644 --- a/models/ed/DESCRIPTION +++ b/models/ed/DESCRIPTION @@ -18,6 +18,7 @@ Depends: Imports: PEcAn.logger, PEcAn.remote, + PEcAn.settings, abind (>= 1.4.5), ncdf4 (>= 1.15), stringr(>= 1.1.0), diff --git a/models/ed/R/write.configs.ed.R b/models/ed/R/write.configs.ed.R index 500f2eb8f53..8b22a666b69 100644 --- a/models/ed/R/write.configs.ed.R +++ b/models/ed/R/write.configs.ed.R @@ -350,7 +350,7 @@ write.config.xml.ED2 <- function(settings, trait.values, defaults = settings$con data(pftmapping, package = 'PEcAn.ED2') ## Get ED2 specific model settings and put into output config xml file - xml <- PEcAn.utils::listToXml(settings$model$config.header, "config") + xml <- PEcAn.settings::listToXml(settings$model$config.header, "config") ## Process the names in defaults. Runs only if names(defaults) are null or have at least one ## instance of name attribute 'pft'. Otherwise, AS assumes that names in defaults are already set @@ -396,7 +396,7 @@ write.config.xml.ED2 <- function(settings, trait.values, defaults = settings$con converted.trait.values <- convert.samples.ED(trait.values[[i]]) vals <- modifyList(vals, converted.trait.values) - decompositon.xml <- PEcAn.utils::listToXml(vals, "decomposition") + decompositon.xml <- PEcAn.settings::listToXml(vals, "decomposition") xml <- XML::append.xmlNode(xml, decompositon.xml) } else if(length(pft.number) == 0) { PEcAn.logger::logger.error(pft, "was not matched with a number in settings$constants or pftmapping data. Consult the PEcAn instructions on defining new PFTs.") @@ -421,7 +421,7 @@ write.config.xml.ED2 <- function(settings, trait.values, defaults = settings$con vals <- modifyList(vals, converted.defaults) } - pft.xml <- PEcAn.utils::listToXml(vals, "pft") + pft.xml <- PEcAn.settings::listToXml(vals, "pft") xml <- XML::append.xmlNode(xml, pft.xml) } diff --git a/models/maat/DESCRIPTION b/models/maat/DESCRIPTION index cffe6a494d1..1e937ebc995 100644 --- a/models/maat/DESCRIPTION +++ b/models/maat/DESCRIPTION @@ -9,6 +9,7 @@ Description: This module provides functions to link the MAAT to PEcAn. Imports: PEcAn.logger, PEcAn.remote, + PEcAn.settings, PEcAn.utils, lubridate (>= 1.6.0), ncdf4 (>= 1.15), diff --git a/models/maat/R/met2model.MAAT.R b/models/maat/R/met2model.MAAT.R index 2c1a0984bbd..fb6cbfb2471 100644 --- a/models/maat/R/met2model.MAAT.R +++ b/models/maat/R/met2model.MAAT.R @@ -215,7 +215,7 @@ met2model.MAAT <- function(in.path, in.prefix, outfolder, start_date, end_date, # TODO: make this dynamic with names above! # TODO: add the additional met variables, make dynamic leaf_user_met_list <- list(leaf = list(env = list(time = "'Time'", temp = "'Tair_degC'", par = "'PAR_umols_m2_s'"))) - leaf_user_met_xml <- PEcAn.utils::listToXml(leaf_user_met_list, "met_data_translator") + leaf_user_met_xml <- PEcAn.settings::listToXml(leaf_user_met_list, "met_data_translator") # output XML file saveXML(leaf_user_met_xml, diff --git a/models/maat/R/write.config.MAAT.R b/models/maat/R/write.config.MAAT.R index f56b6a5f309..599b92b8256 100644 --- a/models/maat/R/write.config.MAAT.R +++ b/models/maat/R/write.config.MAAT.R @@ -99,14 +99,14 @@ write.config.MAAT <- function(defaults = NULL, trait.values, settings, run.id) { file.path(settings$model$binary, "src"))) ### Parse config options to XML - xml <- PEcAn.utils::listToXml(settings$model$config, "default") + xml <- PEcAn.settings::listToXml(settings$model$config, "default") ### Run rename and conversion function on PEcAn trait values traits <- convert.samples.MAAT(trait.samples = trait.values[[settings$pfts$pft$name]]) ### Convert traits to list traits.list <- as.list(traits) - traits.xml <- PEcAn.utils::listToXml(traits.list, "pars") + traits.xml <- PEcAn.settings::listToXml(traits.list, "pars") ### Finalize XML xml[[1]] <- addChildren(xml[[1]], traits.xml) diff --git a/models/maat/inst/simple_workflow.R b/models/maat/inst/simple_workflow.R index 31328045eaa..6ace39168de 100644 --- a/models/maat/inst/simple_workflow.R +++ b/models/maat/inst/simple_workflow.R @@ -23,7 +23,7 @@ settings <- read.settings(system.file("pecan.maat.xml",package = "PEcAn.MAAT")) # get traits of pfts settings$pfts <- get.trait.data(settings$pfts, settings$model$type, settings$database$dbfiles, settings$database$bety, settings$meta.analysis$update) -saveXML(PEcAn.utils::listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) +saveXML(PEcAn.settings::listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) #--------------------------------------------------------------------------------------------------# diff --git a/modules/assim.batch/DESCRIPTION b/modules/assim.batch/DESCRIPTION index d97d4e50581..6c3580d6e17 100644 --- a/modules/assim.batch/DESCRIPTION +++ b/modules/assim.batch/DESCRIPTION @@ -25,6 +25,7 @@ Depends: PEcAn.MA Imports: PEcAn.logger, + PEcAn.settings, coda (>= 0.18), lubridate (>= 1.6.0), ncdf4 (>= 1.15), diff --git a/modules/assim.batch/R/pda.mcmc.R b/modules/assim.batch/R/pda.mcmc.R index 0c323ffcb9b..4b3fa7cd0f6 100644 --- a/modules/assim.batch/R/pda.mcmc.R +++ b/modules/assim.batch/R/pda.mcmc.R @@ -150,7 +150,7 @@ pda.mcmc <- function(settings, params.id = NULL, param.names = NULL, prior.id = } ## save updated settings XML. Will be overwritten at end, but useful in case of crash - saveXML(PEcAn.utils::listToXml(settings, "pecan"), + saveXML(PEcAn.settings::listToXml(settings, "pecan"), file = file.path(settings$outdir, paste0("pecan.pda", settings$assim.batch$ensemble.id, diff --git a/modules/assim.batch/R/pda.mcmc.bs.R b/modules/assim.batch/R/pda.mcmc.bs.R index a2bbdf5bec7..c3215332d86 100644 --- a/modules/assim.batch/R/pda.mcmc.bs.R +++ b/modules/assim.batch/R/pda.mcmc.bs.R @@ -169,7 +169,7 @@ pda.mcmc.bs <- function(settings, params.id = NULL, param.names = NULL, prior.id # Save updated settings XML. Will be overwritten at end, but useful in case of crash settings$assim.batch$jump$jvar <- as.list(diag(jcov)) names(settings$assim.batch$jump$jvar) <- rep("jvar", n.param) - saveXML(PEcAn.utils::listToXml(settings, "pecan"), + saveXML(PEcAn.settings::listToXml(settings, "pecan"), file = file.path(settings$outdir, paste0("pecan.pda", settings$assim.batch$ensemble.id, ".xml"))) diff --git a/modules/assim.batch/R/pda.postprocess.R b/modules/assim.batch/R/pda.postprocess.R index 04b222dbbf9..79da0a28d34 100644 --- a/modules/assim.batch/R/pda.postprocess.R +++ b/modules/assim.batch/R/pda.postprocess.R @@ -103,7 +103,7 @@ pda.postprocess <- function(settings, con, mcmc.param.list, pname, prior, prior. } #end of loop over PFTs ## save updated settings XML - saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, paste0("pecan.pda", settings$assim.batch$ensemble.id, + saveXML(PEcAn.settings::listToXml(settings, "pecan"), file = file.path(settings$outdir, paste0("pecan.pda", settings$assim.batch$ensemble.id, ".xml"))) return(settings) diff --git a/modules/benchmark/DESCRIPTION b/modules/benchmark/DESCRIPTION index b3503fc2738..e7032ace09f 100644 --- a/modules/benchmark/DESCRIPTION +++ b/modules/benchmark/DESCRIPTION @@ -12,6 +12,7 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific efficacy of scientific investigation. Imports: PEcAn.logger, + PEcAn.settings, lubridate (>= 1.6.0), ncdf4 (>= 1.15), udunits2 (>= 0.11), diff --git a/modules/benchmark/R/create_BRR.R b/modules/benchmark/R/create_BRR.R index f850c8ae566..e6f13a17344 100644 --- a/modules/benchmark/R/create_BRR.R +++ b/modules/benchmark/R/create_BRR.R @@ -31,7 +31,7 @@ create_BRR <- function(ens_wf, con, user_id = ""){ clean$ensemble <- NULL str(clean) - settings_xml <- toString(PEcAn.utils::listToXml(clean, "pecan")) + settings_xml <- toString(PEcAn.settings::listToXml(clean, "pecan")) ref_run <- db.query(paste0(" SELECT * from reference_runs where settings = '", settings_xml,"'"),con) diff --git a/scripts/workflow.bm.R b/scripts/workflow.bm.R index 9cf3a1c5c44..797f31a38b9 100644 --- a/scripts/workflow.bm.R +++ b/scripts/workflow.bm.R @@ -132,7 +132,7 @@ for (i in seq_along(settings$run$inputs)) { } } if (needsave) { - saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.METProcess.xml")) + saveXML(PEcAn.settings::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.METProcess.xml")) } else if (file.exists(file.path(settings$outdir, "pecan.METProcess.xml"))) { settings <- read.settings(file.path(settings$outdir, "pecan.METProcess.xml")) } @@ -141,7 +141,7 @@ if (needsave) { if (status.check("TRAIT") == 0) { status.start("TRAIT") settings$pfts <- get.trait.data(settings$pfts, settings$model$type, settings$run$dbfiles, settings$database$bety, settings$meta.analysis$update) - saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.TRAIT.xml")) + saveXML(PEcAn.settings::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.TRAIT.xml")) status.end() } else if (file.exists(file.path(settings$outdir, "pecan.TRAIT.xml"))) { settings <- read.settings(file.path(settings$outdir, "pecan.TRAIT.xml")) @@ -167,7 +167,7 @@ if (status.check("CONFIG") == 0) { settings <- run.write.configs(settings, write = settings$database$bety$write, ens.sample.method = settings$ensemble$method) - saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.CONFIGS.xml")) + saveXML(PEcAn.settings::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.CONFIGS.xml")) status.end() } else if (file.exists(file.path(settings$outdir, "pecan.CONFIGS.xml"))) { settings <- read.settings(file.path(settings$outdir, "pecan.CONFIGS.xml")) diff --git a/scripts/workflow.pda.R b/scripts/workflow.pda.R index 539bbc24fc0..996d513e813 100755 --- a/scripts/workflow.pda.R +++ b/scripts/workflow.pda.R @@ -95,7 +95,7 @@ if (length(which(commandArgs() == "--continue")) == 0) { } } } - saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.METProcess.xml")) + saveXML(PEcAn.settings::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.METProcess.xml")) # Check status to avoid repeating work check.status <- function(check.name) { @@ -126,7 +126,7 @@ if (length(which(commandArgs() == "--continue")) == 0) { settings$database$dbfiles, settings$database$bety, settings$meta.analysis$update) - saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.TRAIT.xml")) + saveXML(PEcAn.settings::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.TRAIT.xml")) status.end() } @@ -147,7 +147,7 @@ if (length(which(commandArgs() == "--continue")) == 0) { if (check.status("CONFIG") == 0) { status.start("CONFIG") settings <- run.write.configs(settings, write = settings$database$bety$write, ens.sample.method = "halton") - saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.CONFIGS.xml")) + saveXML(PEcAn.settings::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.CONFIGS.xml")) status.end() } @@ -211,7 +211,7 @@ if (!is.null(settings$assim.batch)) { # Calls model specific write.configs e.g. write.config.ed.R status.start("PDA.CONFIG") settings <- run.write.configs(settings, write = settings$database$bety$write, ens.sample.method = "halton") - saveXML(PEcAn.utils::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.PDA.CONFIGS.xml")) + saveXML(PEcAn.settings::listToXml(settings, "pecan"), file = file.path(settings$outdir, "pecan.PDA.CONFIGS.xml")) status.end() # Start ecosystem model runs diff --git a/tests/interactive-workflow.R b/tests/interactive-workflow.R index 1c8e2aa8540..d060a519cc3 100644 --- a/tests/interactive-workflow.R +++ b/tests/interactive-workflow.R @@ -23,7 +23,7 @@ settings <- read.settings(settings.file) # get traits of pfts settings$pfts <- get.trait.data(settings$pfts, settings$model$type, settings$database$dbfiles, settings$database$bety, settings$meta.analysis$update) -saveXML(PEcAn.utils::listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) +saveXML(PEcAn.settings::listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) # run meta-analysis @@ -69,7 +69,7 @@ for(i in 1:length(settings$run$inputs)) { # narr download } -saveXML(PEcAn.utils::listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) +saveXML(PEcAn.settings::listToXml(settings, "pecan"), file=file.path(settings$outdir, 'pecan.xml')) # write configurations From e13a2b486a376bc7eb678fa11d0fc00b83ae4f80 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 23 Sep 2017 13:23:12 -0400 Subject: [PATCH 716/771] document Geostreams availability (#1658) --- book_source/data/meteorology.Rmd | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/book_source/data/meteorology.Rmd b/book_source/data/meteorology.Rmd index 98c09ea2f72..a345bbc78f7 100644 --- a/book_source/data/meteorology.Rmd +++ b/book_source/data/meteorology.Rmd @@ -90,5 +90,13 @@ Availability: varies by site http:\/\/www.fluxdata.org\/DataInfo\/Dataset%20Doc Notes: 2007 synthesis. Fluxnet2015 supercedes this for sites that have been updated +## Geostreams +Scale: site + +Resolution: varies + +Availability: varies by site + +Notes: This is a protocol, not a single archive. The PEcAn functions currently default to querying [https://terraref.ncsa.illinois.edu/clowder/api/geostreams], which requires login and contains data from only two sites (Urbana IL and Maricopa AZ). However the interface can be used with any server that supports the [Geostreams API](https://opensource.ncsa.illinois.edu/confluence/display/CATS/Geostreams+API). From 8288a1a22f19ed7a8137653cbb0ec0700f7cf268 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 23 Sep 2017 13:42:10 -0400 Subject: [PATCH 717/771] update changelog --- CHANGELOG.md | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index de9ec0e2b05..2368cf564c6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,21 @@ section for the next release. For more information about this file see also [Keep a Changelog](http://keepachangelog.com/) . ## [Unreleased] + +### Fixes +- `PEcAn.utils` now lazy-loads data for faster execution of functions that consult lookup tables, especially `to_ncvar`. + +### Added + +### Removed +- Removed `PEcAn.utils::model2netcdf`, which has been deprecated since PEcAn 1.3.7. Use `model2netcdf.` in the appropriate model package instead. + +### Changed +- Moved `listToXml` ouf the `PEcAn.utils` package and into the `PEcAn.settings` package. `PEcAn.utils::listToXml` still works with a deprecation warning, but will be removed in a future release. +- Major namespace cleanup in the `PEcAn.utils` package. It now loads more quietly and is much less likely to mask functions in a package you loaded earlier. + + +## [1.5.1] - Created new (and very rudimentary) web interface for downloading data from the dataone federation into the PEcAn database. More updates to come. ### Fixes From dbca13c6c696cbe62cfa887b821789f0ae4c6a66 Mon Sep 17 00:00:00 2001 From: Rob Kooper Date: Mon, 25 Sep 2017 09:07:38 -0500 Subject: [PATCH 718/771] version bump to 1.5.1 --- CHANGELOG.md | 4 +++- base/all/DESCRIPTION | 4 ++-- base/db/DESCRIPTION | 4 ++-- base/logger/DESCRIPTION | 2 +- base/logger/LICENSE | 34 ++++++++++++++++++++++++++++ base/qaqc/DESCRIPTION | 4 ++-- base/remote/DESCRIPTION | 2 +- base/settings/DESCRIPTION | 4 ++-- base/utils/DESCRIPTION | 4 ++-- base/visualization/DESCRIPTION | 4 ++-- models/biocro/DESCRIPTION | 4 ++-- models/cable/DESCRIPTION | 4 ++-- models/clm45/DESCRIPTION | 4 ++-- models/dalec/DESCRIPTION | 4 ++-- models/ed/DESCRIPTION | 4 ++-- models/fates/DESCRIPTION | 4 ++-- models/gday/DESCRIPTION | 4 ++-- models/jules/DESCRIPTION | 4 ++-- models/linkages/DESCRIPTION | 4 ++-- models/lpjguess/DESCRIPTION | 4 ++-- models/maat/DESCRIPTION | 4 ++-- models/maespa/DESCRIPTION | 4 ++-- models/preles/DESCRIPTION | 4 ++-- models/sipnet/DESCRIPTION | 4 ++-- models/template/DESCRIPTION | 4 ++-- modules/allometry/DESCRIPTION | 4 ++-- modules/assim.batch/DESCRIPTION | 4 ++-- modules/assim.sequential/DESCRIPTION | 4 ++-- modules/benchmark/DESCRIPTION | 4 ++-- modules/data.atmosphere/DESCRIPTION | 4 ++-- modules/data.hydrology/DESCRIPTION | 4 ++-- modules/data.land/DESCRIPTION | 4 ++-- modules/data.mining/DESCRIPTION | 4 ++-- modules/data.remote/DESCRIPTION | 4 ++-- modules/emulator/DESCRIPTION | 4 ++-- modules/meta.analysis/DESCRIPTION | 4 ++-- modules/photosynthesis/DESCRIPTION | 4 ++-- modules/priors/DESCRIPTION | 4 ++-- modules/rtm/DESCRIPTION | 4 ++-- modules/uncertainty/DESCRIPTION | 4 ++-- web/common.php | 2 +- 41 files changed, 112 insertions(+), 76 deletions(-) create mode 100644 base/logger/LICENSE diff --git a/CHANGELOG.md b/CHANGELOG.md index 6e6c02f2d20..90f01dcc344 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,8 @@ For more information about this file see also [Keep a Changelog](http://keepacha ## [Unreleased] +## [1.5.2] - 2017-09-?? + ### Fixes - Show workflowid in the URL when run is finshed and user clicks results (#1659) - `PEcAn.BIOCRO` now uses PEcAn-standard variable names. As a result, two output variables have been renamed but keep their existing units and definitions: @@ -20,7 +22,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Cleaned up NAMESPACE and source code of `PEcAn.DB` (#1520) - Debugged python script in call_MODIS in data.remote to allow MODIS downloads - Fixed FATES build script to work on ubuntu -- SIPNET output netcdf now includes LAI; some variable names changed to match standard + SIPNET output netcdf now includes LAI; some variable names changed to match standard - Cleanup of leap year logic, using new `PEcAn.utils::days_in_year(year)` function (#801). - Replace many hard-coded unit conversions with `udunits2::ud.convert` for consistency, readability, and clarity - Refactored extract_soil_nc to create soil2netcdf, which will write soil data out in PEcAn standard. diff --git a/base/all/DESCRIPTION b/base/all/DESCRIPTION index 5ef5e6729bf..850cde629bb 100644 --- a/base/all/DESCRIPTION +++ b/base/all/DESCRIPTION @@ -2,8 +2,8 @@ Package: PEcAn.all Type: Package Title: PEcAn functions used for ecological forecasts and reanalysis -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer, Mike Dietze, Xiaohui Feng, Dan Wang, Mike Dietze, Carl Davidson, Rob Kooper, Shawn Serbin Maintainer: David LeBauer diff --git a/base/db/DESCRIPTION b/base/db/DESCRIPTION index af67e5ca3fa..3189509e9a4 100644 --- a/base/db/DESCRIPTION +++ b/base/db/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.DB Type: Package Title: PEcAn functions used for ecological forecasts and reanalysis -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer, Mike Dietze, Xiaohui Feng, Dan Wang, Carl Davidson, Rob Kooper, Shawn Serbin Maintainer: David LeBauer diff --git a/base/logger/DESCRIPTION b/base/logger/DESCRIPTION index fe684282038..9f028701f40 100644 --- a/base/logger/DESCRIPTION +++ b/base/logger/DESCRIPTION @@ -1,6 +1,6 @@ Package: PEcAn.logger Title: Logger functions for PEcAn -Version: 0.0.0.9000 +Version: 1.5.1 Author: Rob Kooper, Alexey Shiklomanov Maintainer: Alexey Shiklomanov Description: Special logger functions for tracking execution status and the environment. diff --git a/base/logger/LICENSE b/base/logger/LICENSE new file mode 100644 index 00000000000..5a9e44128f1 --- /dev/null +++ b/base/logger/LICENSE @@ -0,0 +1,34 @@ +## This is the master copy of the PEcAn License + +University of Illinois/NCSA Open Source License + +Copyright (c) 2012, University of Illinois, NCSA. All rights reserved. + +PEcAn project +www.pecanproject.org + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal with the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +- Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimers. +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimers in the + documentation and/or other materials provided with the distribution. +- Neither the names of University of Illinois, NCSA, nor the names + of its contributors may be used to endorse or promote products + derived from this Software without specific prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR +ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF +CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. + diff --git a/base/qaqc/DESCRIPTION b/base/qaqc/DESCRIPTION index cd6f6393270..96c916a1293 100644 --- a/base/qaqc/DESCRIPTION +++ b/base/qaqc/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.qaqc Type: Package Title: QAQC -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer Maintainer: David LeBauer Description: PEcAn integration and model skill testing diff --git a/base/remote/DESCRIPTION b/base/remote/DESCRIPTION index 62133b1b525..3113d27b93b 100644 --- a/base/remote/DESCRIPTION +++ b/base/remote/DESCRIPTION @@ -1,7 +1,7 @@ Package: PEcAn.remote Type: Package Title: PEcAn model execution utilities -Version: 0.1.0 +Version: 1.5.1 Author: Alexey Shiklomanov, Rob Kooper, Shawn Serbin, David LeBauer Maintainer: Alexey Shiklomanov Description: This package contains utilities for communicating with and executing code on local and remote hosts. diff --git a/base/settings/DESCRIPTION b/base/settings/DESCRIPTION index b126c2d2658..a01da286662 100644 --- a/base/settings/DESCRIPTION +++ b/base/settings/DESCRIPTION @@ -2,8 +2,8 @@ Package: PEcAn.settings Title: PEcAn Settings package Maintainer: David LeBauer Author: David LeBauer, Rob Kooper -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 License: FreeBSD + file LICENSE Copyright: Authors LazyLoad: yes diff --git a/base/utils/DESCRIPTION b/base/utils/DESCRIPTION index 4866536f945..1b2ddb3c665 100644 --- a/base/utils/DESCRIPTION +++ b/base/utils/DESCRIPTION @@ -2,8 +2,8 @@ Package: PEcAn.utils Type: Package Title: PEcAn functions used for ecological forecasts and reanalysis -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer, Mike Dietze, Xiaohui Feng, Dan Wang, Mike Dietze, Carl Davidson, Rob Kooper, Shawn Serbin Maintainer: David LeBauer diff --git a/base/visualization/DESCRIPTION b/base/visualization/DESCRIPTION index 3274dd4031f..a56141ce9d3 100644 --- a/base/visualization/DESCRIPTION +++ b/base/visualization/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.visualization Type: Package Title: PEcAn visualization functions. -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer, Mike Dietze, Xiaohui Feng, Dan Wang, Mike Dietze, Carl Davidson, Rob Kooper, Alexey Shiklomanov Maintainer: David LeBauer diff --git a/models/biocro/DESCRIPTION b/models/biocro/DESCRIPTION index 9981877312b..2ba75ebde70 100644 --- a/models/biocro/DESCRIPTION +++ b/models/biocro/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.BIOCRO Type: Package Title: PEcAn package for integration of the BioCro model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer, Deepak Jaiswal Maintainer: David LeBauer Description: This module provides functions to link BioCro to PEcAn. diff --git a/models/cable/DESCRIPTION b/models/cable/DESCRIPTION index 850f0580ab8..8bad92ab14a 100644 --- a/models/cable/DESCRIPTION +++ b/models/cable/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.CABLE Type: Package Title: PEcAn package for integration of the CABLE model -Version: 1.5.0 -Date: 2017-04-18 +Version: 1.5.1 +Date: 2017-09-25 Author: Kaitlin Ragosta Maintainer: Anthony Gardella Description: This module provides functions to link the (CABLE) to PEcAn. diff --git a/models/clm45/DESCRIPTION b/models/clm45/DESCRIPTION index e0552f5b871..e2dffdae556 100644 --- a/models/clm45/DESCRIPTION +++ b/models/clm45/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.CLM45 Type: Package Title: PEcAn package for integration of CLM4.5 model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Mike Dietze Maintainer: Mike Dietze Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific diff --git a/models/dalec/DESCRIPTION b/models/dalec/DESCRIPTION index 3c67dafcdbe..db9f9d18920 100644 --- a/models/dalec/DESCRIPTION +++ b/models/dalec/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.DALEC Type: Package Title: PEcAn package for integration of the DALEC model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Mike Dietze, Tristain Quaife Maintainer: Mike Dietze Description: This module provides functions to link DALEC to PEcAn. diff --git a/models/ed/DESCRIPTION b/models/ed/DESCRIPTION index 417bc64232f..a7cae131f52 100644 --- a/models/ed/DESCRIPTION +++ b/models/ed/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.ED2 Type: Package Title: PEcAn package for integration of ED2 model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer, Mike Dietze, Xiaohui Feng, Dan Wang, Mike Dietze, Carl Davidson, Rob Kooper, Shawn Serbin Maintainer: Mike Dietze diff --git a/models/fates/DESCRIPTION b/models/fates/DESCRIPTION index 3b38d13dcec..91cc6d329cc 100644 --- a/models/fates/DESCRIPTION +++ b/models/fates/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.FATES Type: Package Title: PEcAn package for integration of FATES model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Mike Dietze Maintainer: Mike Dietze Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific diff --git a/models/gday/DESCRIPTION b/models/gday/DESCRIPTION index e5350dbf964..450401f8d16 100644 --- a/models/gday/DESCRIPTION +++ b/models/gday/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.GDAY Type: Package Title: PEcAn package for integration of the GDAY model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Martin De Kauwe Maintainer: Martin De Kauwe Description: This module provides functions to link the GDAY model to PEcAn. diff --git a/models/jules/DESCRIPTION b/models/jules/DESCRIPTION index 65ac1df0d3e..d6a525ac7a7 100644 --- a/models/jules/DESCRIPTION +++ b/models/jules/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.JULES Type: Package Title: PEcAn package for integration of the JULES model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Mike Dietze Maintainer: Mike Dietze Description: This module provides functions to link the (JULES) to PEcAn. diff --git a/models/linkages/DESCRIPTION b/models/linkages/DESCRIPTION index 911f4d720b4..408cd40adfa 100644 --- a/models/linkages/DESCRIPTION +++ b/models/linkages/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.LINKAGES Type: Package Title: PEcAn package for integration of the LINKAGES model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Ann Raiho, Mike Dietze Maintainer: Ann Raiho Description: This module provides functions to link the (LINKAGES) to PEcAn. diff --git a/models/lpjguess/DESCRIPTION b/models/lpjguess/DESCRIPTION index 1e4bbb84a2e..22705f9bf45 100644 --- a/models/lpjguess/DESCRIPTION +++ b/models/lpjguess/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.LPJGUESS Type: Package Title: PEcAn package for integration of the LPJ-GUESS model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Istem Fer, Tony Gardella Maintainer: Istem Fer Description: This module provides functions to link LPJ-GUESS to PEcAn. diff --git a/models/maat/DESCRIPTION b/models/maat/DESCRIPTION index cffe6a494d1..12c63f03807 100644 --- a/models/maat/DESCRIPTION +++ b/models/maat/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.MAAT Type: Package Title: PEcAn package for integration of the MAAT model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Shawn Serbin, Anthony Walker Maintainer: Shawn Serbin Description: This module provides functions to link the MAAT to PEcAn. diff --git a/models/maespa/DESCRIPTION b/models/maespa/DESCRIPTION index 693ffd5c64a..b990c3ac40a 100644 --- a/models/maespa/DESCRIPTION +++ b/models/maespa/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.MAESPA Type: Package Title: PEcAn functions used for ecological forecasts and reanalysis using MAESPA -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Tony Gardella Maintainer: Tony Gardella Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific diff --git a/models/preles/DESCRIPTION b/models/preles/DESCRIPTION index 2766991a588..b079691985f 100644 --- a/models/preles/DESCRIPTION +++ b/models/preles/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.PRELES Type: Package Title: PEcAn package for integration of the PRELES model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Tony Gardella, Mike Dietze Maintainer: Tony Gardella Description: This module provides functions to run the PREdict Light use diff --git a/models/sipnet/DESCRIPTION b/models/sipnet/DESCRIPTION index c43ad81d1c8..a677ef8b3d7 100644 --- a/models/sipnet/DESCRIPTION +++ b/models/sipnet/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.SIPNET Type: Package Title: PEcAn functions used for ecological forecasts and reanalysis -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Mike Dietze Maintainer: Mike Dietze Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific diff --git a/models/template/DESCRIPTION b/models/template/DESCRIPTION index d993bba9364..639a37ab87f 100644 --- a/models/template/DESCRIPTION +++ b/models/template/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.ModelName Type: Package Title: PEcAn package for integration of the ModelName model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: John Doe, Jane Doe Maintainer: John Doe Description: This module provides functions to link the (ModelName) to PEcAn. diff --git a/modules/allometry/DESCRIPTION b/modules/allometry/DESCRIPTION index 3d64baa4ea1..d9f254e6dd8 100644 --- a/modules/allometry/DESCRIPTION +++ b/modules/allometry/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.allometry Type: Package Title: PEcAn allometry functions -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Mike Dietze Maintainer: Mike Dietze Description: Synthesize allometric equations or fit allometries to data diff --git a/modules/assim.batch/DESCRIPTION b/modules/assim.batch/DESCRIPTION index d97d4e50581..095c2a8da53 100644 --- a/modules/assim.batch/DESCRIPTION +++ b/modules/assim.batch/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.assim.batch Type: Package Title: PEcAn functions used for ecological forecasts and reanalysis -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Mike Dietze Maintainer: Mike Dietze Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific diff --git a/modules/assim.sequential/DESCRIPTION b/modules/assim.sequential/DESCRIPTION index 09fe73b4c4d..14d3cc8db14 100644 --- a/modules/assim.sequential/DESCRIPTION +++ b/modules/assim.sequential/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.assim.sequential Type: Package Title: PEcAn functions used for ecological forecasts and reanalysis -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Mike Dietze Maintainer: Mike Dietze Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific diff --git a/modules/benchmark/DESCRIPTION b/modules/benchmark/DESCRIPTION index b3503fc2738..75b4250ba7a 100644 --- a/modules/benchmark/DESCRIPTION +++ b/modules/benchmark/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.benchmark Type: Package Title: PEcAn functions used for benchmarking -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Michael Dietze, David LeBauer, Rob Kooper, Toni Viskari Maintainer: Mike Dietze Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific diff --git a/modules/data.atmosphere/DESCRIPTION b/modules/data.atmosphere/DESCRIPTION index d7390009e1c..15edd34ad75 100644 --- a/modules/data.atmosphere/DESCRIPTION +++ b/modules/data.atmosphere/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.data.atmosphere Type: Package Title: PEcAn functions used for managing climate driver data -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Carl Davidson, Mike Dietze, Rob Kooper, Deepak Jaiswal, David LeBauer Maintainer: David LeBauer Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific diff --git a/modules/data.hydrology/DESCRIPTION b/modules/data.hydrology/DESCRIPTION index 2e234f01d55..56574933f4e 100644 --- a/modules/data.hydrology/DESCRIPTION +++ b/modules/data.hydrology/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.data.hydrology Type: Package Title: PEcAn functions used for ecological forecasts and reanalysis -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer, Mike Dietze, Xiaohui Feng, Dan Wang, Mike Dietze, Carl Davidson, Rob Kooper Maintainer: David LeBauer diff --git a/modules/data.land/DESCRIPTION b/modules/data.land/DESCRIPTION index eddfee45785..201f79c6224 100644 --- a/modules/data.land/DESCRIPTION +++ b/modules/data.land/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.data.land Type: Package Title: PEcAn functions used for ecological forecasts and reanalysis -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer, Mike Dietze, Xiaohui Feng, Dan Wang, Mike Dietze, Carl Davidson, Rob Kooper, Alexey Shiklomanov Maintainer: Mike Dietze , David LeBauer diff --git a/modules/data.mining/DESCRIPTION b/modules/data.mining/DESCRIPTION index 06b11eec36e..a4601b5666c 100644 --- a/modules/data.mining/DESCRIPTION +++ b/modules/data.mining/DESCRIPTION @@ -2,8 +2,8 @@ Package: PEcAn.data.mining Type: Package Title: PEcAn functions used for exploring model residuals and structures Description: (Temporary description) PEcAn functions used for exploring model residuals and structures -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Mike Dietze Maintainer: Mike Dietze Depends: diff --git a/modules/data.remote/DESCRIPTION b/modules/data.remote/DESCRIPTION index 09f85ed5da1..04597e06fe1 100644 --- a/modules/data.remote/DESCRIPTION +++ b/modules/data.remote/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.data.remote Type: Package Title: PEcAn functions used for remote sensing -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Mike Dietze Maintainer: Mike Dietze Description: PEcAn module for processing remote data diff --git a/modules/emulator/DESCRIPTION b/modules/emulator/DESCRIPTION index 01cd18fb590..2c9cf1ecd83 100644 --- a/modules/emulator/DESCRIPTION +++ b/modules/emulator/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.emulator Type: Package Title: Gausian Process emulator -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Michael Dietze Maintainer: Michael Dietze Depends: diff --git a/modules/meta.analysis/DESCRIPTION b/modules/meta.analysis/DESCRIPTION index 35d1c988b1f..5b5ffca9118 100644 --- a/modules/meta.analysis/DESCRIPTION +++ b/modules/meta.analysis/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.MA Type: Package Title: PEcAn functions used for meta-analysis -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer, Mike Dietze, Xiaohui Feng, Dan Wang, Mike Dietze, Carl Davidson, Rob Kooper, Shawn Serbin Maintainer: David LeBauer diff --git a/modules/photosynthesis/DESCRIPTION b/modules/photosynthesis/DESCRIPTION index 16c32cbe303..3b8ba5060a9 100644 --- a/modules/photosynthesis/DESCRIPTION +++ b/modules/photosynthesis/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.photosynthesis Type: Package Title: PEcAn functions used for leaf-level photosynthesis calculations -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Mike Dietze, Xiaohui Feng, Shawn Serbin Maintainer: Mike Dietze Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific diff --git a/modules/priors/DESCRIPTION b/modules/priors/DESCRIPTION index 96256e89d47..97280fdee14 100644 --- a/modules/priors/DESCRIPTION +++ b/modules/priors/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.priors Type: Package Title: PEcAn functions used to estimate priors from data -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer Maintainer: David LeBauer Description: Functions to estimate priors from data. diff --git a/modules/rtm/DESCRIPTION b/modules/rtm/DESCRIPTION index dff5d97b6bd..884b2b819fe 100644 --- a/modules/rtm/DESCRIPTION +++ b/modules/rtm/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAnRTM Type: Package Title: PEcAn functions used for radiative transfer modeling -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Alexey Shiklomanov, Shawn Serbin, Mike Dietze Maintainer: Alexey Shiklomanov Description: This package contains functions for performing forward runs and diff --git a/modules/uncertainty/DESCRIPTION b/modules/uncertainty/DESCRIPTION index b24a7c25547..0ce9a555e93 100644 --- a/modules/uncertainty/DESCRIPTION +++ b/modules/uncertainty/DESCRIPTION @@ -2,8 +2,8 @@ Package: PEcAn.uncertainty Type: Package Title: PEcAn functions used for ecological forecasts and reanalysis -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: David LeBauer, Mike Dietze, Xiaohui Feng, Dan Wang, Mike Dietze, Carl Davidson, Rob Kooper, Shawn Serbin Maintainer: David LeBauer diff --git a/web/common.php b/web/common.php index bc4e2539770..bc37d82b956 100644 --- a/web/common.php +++ b/web/common.php @@ -12,7 +12,7 @@ function get_footer() { return "The PEcAn project is supported by the National Science Foundation (ABI #1062547, ABI #1458021, DIBBS #1261582, ARC #1023477, EF #1318164, EF #1241894, EF #1241891), NASA Terrestrial Ecosystems, the Energy Biosciences Institute, and an Amazon AWS in Education Grant. - PEcAn Version 1.5.0"; + PEcAn Version 1.5.1"; } function whoami() { From cfc55727aa2945f1440509ef447db98f991ce32e Mon Sep 17 00:00:00 2001 From: Rob Kooper Date: Mon, 25 Sep 2017 09:08:20 -0500 Subject: [PATCH 719/771] Update CHANGELOG.md 1.5.1 not 1.5.2 --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 90f01dcc344..2cc47e568c6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,7 +7,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha ## [Unreleased] -## [1.5.2] - 2017-09-?? +## [1.5.1] - 2017-09-?? ### Fixes - Show workflowid in the URL when run is finshed and user clicks results (#1659) From 28d8231d32ac1cd8bb1afe9863636676d7d773b0 Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 25 Sep 2017 12:40:11 -0400 Subject: [PATCH 720/771] get non-NA not length --- modules/assim.batch/R/pda.get.model.output.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modules/assim.batch/R/pda.get.model.output.R b/modules/assim.batch/R/pda.get.model.output.R index 8d71617d5c6..6848fa386cc 100644 --- a/modules/assim.batch/R/pda.get.model.output.R +++ b/modules/assim.batch/R/pda.get.model.output.R @@ -122,7 +122,7 @@ pda.get.model.output <- function(settings, run.id, bety, inputs) { model.out[[k]] <- dat[,colnames(dat) %in% paste0(data.var,".m"), drop = FALSE] inputs[[k]]$obs <- dat[,colnames(dat) %in% paste0(data.var,".o"), drop = FALSE][[1]] - inputs[[k]]$n <- length(inputs[[k]]$obs) + inputs[[k]]$n <- sum(!is.na(inputs[[k]]$obs)) colnames(model.out[[k]]) <- data.var } From f8da66f5900573e74f7fe7dc803b8aea066fdfa8 Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 25 Sep 2017 12:45:59 -0400 Subject: [PATCH 721/771] specify better prior for bias term --- modules/assim.batch/R/pda.utils.R | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/modules/assim.batch/R/pda.utils.R b/modules/assim.batch/R/pda.utils.R index cce72507e14..b47ece8dc1a 100644 --- a/modules/assim.batch/R/pda.utils.R +++ b/modules/assim.batch/R/pda.utils.R @@ -670,7 +670,8 @@ pda.generate.sf <- function(n.knot, sf, prior.list){ ##' @title return.bias ##' @author Istem Fer ##' @export -return.bias <- function(isbias, model.out, inputs, prior.list.bias, nbias, run.round = FALSE, prev.bias = NULL){ +return.bias <- function(isbias, model.out, inputs, prior.list.bias, nbias, + run.round = FALSE, prev.bias = NULL){ # there can be more than one multiplicative Gaussian requested ibias <- length(isbias) @@ -702,16 +703,22 @@ return.bias <- function(isbias, model.out, inputs, prior.list.bias, nbias, run.r } } - bias.prior$parama[i] <- min(bias.params[[i]], na.rm = TRUE) - sd(bias.params[[i]], na.rm = TRUE) - bias.prior$paramb[i] <- max(bias.params[[i]], na.rm = TRUE) + sd(bias.params[[i]], na.rm = TRUE) + bias.prior$parama[i] <- min(bias.params[[i]], na.rm = TRUE) + bias.prior$paramb[i] <- max(bias.params[[i]], na.rm = TRUE) prior.names[i] <- paste0("bias.", sapply(model.out[[1]],names)[isbias[i]]) names(bias.params)[i] <- paste0("bias.", sapply(model.out[[1]],names)[isbias[i]]) } rownames(bias.prior) <- prior.names - prior.list.bias[[(length(prior.list.bias)+1)]] <- bias.prior + # fit a distribution + # TODO: check this when more than one multiplicative Gaussian requested + # probably need to re-format bias.params + bias.prior <- PEcAn.MA::approx.posterior(bias.params, bias.prior) + + prior.list.bias[[(length(prior.list.bias)+1)]] <- bias.prior + # convert params to probs for GPfit # note: there can be new parameters out of previous min/max if this is a round extension bias.probs <- lapply(seq_along(isbias), From 76de2999bf935ca5c7b6f6c822a45ce174d2cf54 Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 25 Sep 2017 12:46:34 -0400 Subject: [PATCH 722/771] no need to convert to probs any more --- modules/assim.batch/R/pda.utils.R | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/modules/assim.batch/R/pda.utils.R b/modules/assim.batch/R/pda.utils.R index b47ece8dc1a..9bf3641a36c 100644 --- a/modules/assim.batch/R/pda.utils.R +++ b/modules/assim.batch/R/pda.utils.R @@ -719,28 +719,14 @@ return.bias <- function(isbias, model.out, inputs, prior.list.bias, nbias, prior.list.bias[[(length(prior.list.bias)+1)]] <- bias.prior - # convert params to probs for GPfit - # note: there can be new parameters out of previous min/max if this is a round extension - bias.probs <- lapply(seq_along(isbias), - function(b) punif(bias.params[[b]], - prior.list.bias[[length(prior.list.bias)]]$parama[b], - prior.list.bias[[length(prior.list.bias)]]$paramb[b])) - # if this is another round, use the first priors if(run.round){ load(prev.bias) prior.list.bias <- prior.list - # convert params to probs for GPfit - # note: there can be new parameters out of previous min/max if this is a round extension - bias.probs <- lapply(seq_along(isbias), - function(b) punif(bias.params[[b]], - prior.list.bias[[length(prior.list.bias)]]$parama[b], - prior.list.bias[[length(prior.list.bias)]]$paramb[b])) - } - return(list(bias.params = bias.params, bias.probs = bias.probs, prior.list.bias = prior.list.bias)) + return(list(bias.params = bias.params, prior.list.bias = prior.list.bias)) } # return.bias From 55b9fdf0081d0710ccb2ad9ca415f87ea7d11cbe Mon Sep 17 00:00:00 2001 From: istfer Date: Mon, 25 Sep 2017 14:36:50 -0400 Subject: [PATCH 723/771] fix tau draw --- modules/assim.batch/R/pda.define.llik.R | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/modules/assim.batch/R/pda.define.llik.R b/modules/assim.batch/R/pda.define.llik.R index d567e018e4d..399ef343f91 100644 --- a/modules/assim.batch/R/pda.define.llik.R +++ b/modules/assim.batch/R/pda.define.llik.R @@ -200,7 +200,14 @@ pda.calc.llik.par <-function(settings, n, error.stats){ if (settings$assim.batch$inputs[[k]]$likelihood == "Gaussian" | settings$assim.batch$inputs[[k]]$likelihood == "multipGauss") { - llik.par[[k]]$par <- rgamma(1, 0.001 + n[k]/2, 0.001 + error.stats[k]/2) + # calculate a minimum scale for gamma if emulator proposes negative SS + if(error.stats[k] < 0){ + get_order <- log10(abs(error.stats[k])) + min.scale <- 1e-10 * (10^get_order) # to make this less likely + error.stats[k] <- min.scale + } + + llik.par[[k]]$par <- rgamma(1, n[k]/2, error.stats[k]/2) names(llik.par[[k]]$par) <- paste0("tau.", names(n)[k]) } From 530139c9a905931bee070025f6685e9e9ef02d99 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Mon, 25 Sep 2017 15:49:39 -0400 Subject: [PATCH 724/771] fix preles? --- models/preles/DESCRIPTION | 9 ++- models/preles/R/runPRELES.jobsh.R | 124 ++++++++++++++---------------- 2 files changed, 64 insertions(+), 69 deletions(-) diff --git a/models/preles/DESCRIPTION b/models/preles/DESCRIPTION index b079691985f..d58eb492f3a 100644 --- a/models/preles/DESCRIPTION +++ b/models/preles/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.PRELES Type: Package Title: PEcAn package for integration of the PRELES model -Version: 1.5.1 -Date: 2017-09-25 +Version: 1.5.0 +Date: 2017-07-14 Author: Tony Gardella, Mike Dietze Maintainer: Tony Gardella Description: This module provides functions to run the PREdict Light use @@ -18,7 +18,10 @@ Imports: PEcAn.logger, lubridate (>= 1.6.0), ncdf4 (>= 1.15), - udunits2 (>= 0.11) + udunits2 (>= 0.11), + PEcAn.data.atmosphere, + PEcAn.utils, + Rpreles Suggests: testthat (>= 1.0.2) SystemRequirements: preles diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index b4b051c0292..885e385d352 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -16,72 +16,68 @@ ##' @param end_date End time of the simulation ##' @export ##' @author Tony Gardella, Michael Dietze -##' @importFrom ncdf4 ncvar_get ncvar_def runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, start.date, end.date) { - - library(PEcAn.data.atmosphere) - library(PEcAn.utils) - library(Rpreles) - + + # Process start and end dates start_date <- as.POSIXlt(start.date, tz = "UTC") end_date <- as.POSIXlt(end.date, tz = "UTC") - + start_year <- lubridate::year(start_date) end_year <- lubridate::year(end_date) - + timestep.s <- udunits2::ud.convert(1, "day", "seconds") # Number of seconds in a day - + ## Build met met <- NULL for (year in start_year:end_year) { - + met.file.y <- paste(met.file, year, "nc", sep = ".") - + if (file.exists(met.file.y)) { - + ## Open netcdf file nc <- ncdf4::nc_open(met.file.y) - + ## convert time to seconds sec <- nc$dim$time$vals sec <- udunits2::ud.convert(sec, unlist(strsplit(nc$dim$time$units, " "))[1], "seconds") - + ## build day and year - + dt <- PEcAn.utils::seconds_in_year(year) / length(sec) tstep <- round(timestep.s / dt) #time steps per day - + diy <- PEcAn.utils::days_in_year(year) - doy <- seq_len(diy, each = tstep)[seq_along(sec)] - + doy <- doy <- rep(seq_len(diy), each = tstep)[seq_along(sec)] + ## Get variables from netcdf file - SW <- ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") # SW in W/m2 - Tair <- ncvar_get(nc, "air_temperature") # air temperature in K - Precip <- ncvar_get(nc, "precipitation_flux") # precipitation in kg/m2s1 - CO2 <- try(ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air")) # mol/mol - SH <- ncvar_get(nc, "specific_humidity") - lat <- ncvar_get(nc, "latitude") - lon <- ncvar_get(nc, "longitude") - + SW <- ncdf4::ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") # SW in W/m2 + Tair <- ncdf4::ncvar_get(nc, "air_temperature") # air temperature in K + Precip <- ncdf4::ncvar_get(nc, "precipitation_flux") # precipitation in kg/m2s1 + CO2 <- try(ncdf4::ncvar_get(nc, "mole_fraction_of_carbon_dioxide_in_air")) # mol/mol + SH <- ncdf4::ncvar_get(nc, "specific_humidity") + lat <- ncdf4::ncvar_get(nc, "latitude") + lon <- ncdf4::ncvar_get(nc, "longitude") + ncdf4::nc_close(nc) - + ## Check for CO2 and PAR if (!is.numeric(CO2)) { PEcAn.logger::logger.warn("CO2 not found. Setting to default: 4.0e+8 mol/mol") # using rough estimate of atmospheric CO2 levels CO2 <- rep(4e+08, length(Precip)) } - + ## GET VPD from Saturated humidity and Air Temperature - RH <- qair2rh(SH, Tair) - VPD <- get.vpd(RH, Tair) - + RH <- PEcAn.data.atmosphere::qair2rh(SH, Tair) + VPD <- PEcAn.data.atmosphere::get.vpd(RH, Tair) + VPD <- VPD * 0.01 # convert to Pascal - + ## Get PPFD from SW - PPFD <- sw2ppfd(SW) # PPFD in umol/m2/s + PPFD <- PEcAn.data.atmosphere::sw2ppfd(SW) # PPFD in umol/m2/s PPFD <- udunits2::ud.convert(PPFD, "umol m-2 s-1", "mol m-2 s-1") - + ## Format/convert inputs ppfd <- tapply(PPFD, doy, mean, na.rm = TRUE) # Find the mean for the day tair <- udunits2::ud.convert(tapply(Tair, doy, mean, na.rm = TRUE), "kelvin", "celsius") # Convert Kelvin to Celcius @@ -91,16 +87,16 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star co2 <- co2 * 1e+06 # convert to ppm doy <- tapply(doy, doy, mean) # day of year fapar <- rep(0.6, length = length(doy)) # For now set to 0.6. Needs to be between 0-1 - + ## Bind inputs tmp <- cbind(ppfd, tair, vpd, precip, co2, fapar) tmp[is.na(tmp)] <- 0 met <- rbind(met, tmp) } ## end file exists } ## end met process - + param.def <- rep(NA, 30) - + #PARAMETER DEFAULT LIST ##GPP_MODEL_PARAMETERS #1.soildepth 413.0 |2.ThetaFC 0.450 | 3.ThetaPWP 0.118 |4.tauDrainage 3 @@ -118,72 +114,68 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star #28.t0 fPheno_start_date_Tsum_accumulation; conif -999, for birch 57 #29.tcrit -999 fPheno_start_date_Tsum_Tthreshold, 1.5 birch #30.tsumcrit -999 fPheno_budburst_Tsum, 134 birch - + ## Replace default with sampled parameters load(parameters) params <- data.frame(trait.values) colnames <- c(names(trait.values[[1]])) colnames(params) <- colnames - + param.def[5] <- as.numeric(params["bGPP"]) param.def[9] <- as.numeric(params["kGPP"]) - + ## Run PRELES - PRELES.output <- as.data.frame(PRELES(PAR = tmp[, "ppfd"], - TAir = tmp[, "tair"], - VPD = tmp[, "vpd"], - Precip = tmp[, "precip"], - CO2 = tmp[, "co2"], - fAPAR = tmp[, "fapar"], - p = param.def)) + PRELES.output <- as.data.frame(Rpreles::PRELES(PAR = tmp[, "ppfd"], + TAir = tmp[, "tair"], + VPD = tmp[, "vpd"], + Precip = tmp[, "precip"], + CO2 = tmp[, "co2"], + fAPAR = tmp[, "fapar"], + p = param.def)) PRELES.output.dims <- dim(PRELES.output) - + days <- as.Date(start_date):as.Date(end_date) year <- strftime(as.Date(days, origin = "1970-01-01"), "%Y") years <- unique(year) num.years <- length(years) - + for (y in years) { if (file.exists(file.path(outdir, paste(y)))) next print(paste("----Processing year: ", y)) - + sub.PRELES.output <- subset(PRELES.output, years == y) sub.PRELES.output.dims <- dim(sub.PRELES.output) - + output <- list() output[[1]] <- udunits2::ud.convert(sub.PRELES.output[, 1], 'g m-2 day-1', 'kg m-2 sec-1') #GPP - gC/m2day to kgC/m2s1 output[[2]] <- (sub.PRELES.output[, 2])/timestep.s #Evapotranspiration - mm =kg/m2 output[[3]] <- (sub.PRELES.output[, 3])/timestep.s #Soilmoisture - mm = kg/m2 - output[[4]] <- (sub.PRELES.output[, 4])/timestep.s #fWE modifier - just a modifier - output[[5]] <- (sub.PRELES.output[, 5])/timestep.s #fW modifier - just a modifier output[[6]] <- (sub.PRELES.output[, 6])/timestep.s #Evaporation - mm = kg/m2 output[[7]] <- (sub.PRELES.output[, 7])/timestep.s #transpiration - mm = kg/m2 - + t <- ncdf4::ncdim_def(name = "time", - units = paste0("days since", y, "-01-01 00:00:00"), - vals = 1:nrow(sub.PRELES.output), - calendar = "standard", - unlim = TRUE) - + units = paste0("days since", y, "-01-01 00:00:00"), + vals = 1:nrow(sub.PRELES.output), + calendar = "standard", + unlim = TRUE) + lat <- ncdf4::ncdim_def("lat", "degrees_east", vals = as.numeric(sitelat), longname = "station_longitude") lon <- ncdf4::ncdim_def("lat", "degrees_north", vals = as.numeric(sitelon), longname = "station_longitude") - + for (i in seq_along(output)) { if (length(output[[i]]) == 0) output[[i]] <- rep(-999, length(t$vals)) } - + dims <- list(lon = lon, lat = lat, time = t) var <- list() var[[1]] <- PEcAn.utils::to_ncvar("GPP",dims) - var[[2]] <- PEcAn.utils::to_ncvar("Evapotranspiration", dims) + var[[2]] <- ncdf4::ncvar_def("Evapotranspiration", "kg/m2s1", list(lon, lat, t), -999) var[[3]] <- PEcAn.utils::to_ncvar("SoilMoist", dims) - var[[4]] <- PEcAn.utils::to_ncvar("fWE", dims) - var[[5]] <- PEcAn.utils::to_ncvar("fW", dims) - var[[6]] <- PEcAn.utils::to_ncvar("Evap", dims) - var[[7]] <- PEcAn.utils::to_ncvar("TVeg", dims) + var[[4]] <- PEcAn.utils::to_ncvar("Evap", dims) + var[[5]] <- PEcAn.utils::to_ncvar("TVeg", dims) nc <- ncdf4::nc_create(file.path(outdir, paste(y, "nc", sep = ".")), var) varfile <- file(file.path(outdir, paste(y, "nc", "var", sep = ".")), "w") From fc030b63310a43c2e0c04fdd4070e2a2980b542f Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Mon, 25 Sep 2017 16:05:59 -0400 Subject: [PATCH 725/771] fix description file and add to changelog --- CHANGELOG.md | 1 + models/preles/DESCRIPTION | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2cc47e568c6..a219be203bc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -29,6 +29,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Added a new retry.func() to base/utils to provide ability to re-try a function X times before stopping. Currently using this function in the download.CRUNCEP() function to handle slow responses from THREDDS. - Reformatted call_MODIS netcdf output to reflect the orientation of the MODIS grid - Remote execution is more robust to errors in the submission process, not just the actual model execution +- PRELES model run script bug fix ### Added - Created new (and very rudimentary) web interface for downloading data from the dataone federation into the PEcAn database. More updates to come. diff --git a/models/preles/DESCRIPTION b/models/preles/DESCRIPTION index d58eb492f3a..198f5b72b27 100644 --- a/models/preles/DESCRIPTION +++ b/models/preles/DESCRIPTION @@ -1,8 +1,8 @@ Package: PEcAn.PRELES Type: Package Title: PEcAn package for integration of the PRELES model -Version: 1.5.0 -Date: 2017-07-14 +Version: 1.5.1 +Date: 2017-09-25 Author: Tony Gardella, Mike Dietze Maintainer: Tony Gardella Description: This module provides functions to run the PREdict Light use From ce9e70641b37955e24b463d1e7bbe48f25cbd6b3 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Mon, 25 Sep 2017 16:13:02 -0400 Subject: [PATCH 726/771] typo --- models/preles/R/runPRELES.jobsh.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index 885e385d352..411e4c5d196 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -49,7 +49,7 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star tstep <- round(timestep.s / dt) #time steps per day diy <- PEcAn.utils::days_in_year(year) - doy <- doy <- rep(seq_len(diy), each = tstep)[seq_along(sec)] + doy <- rep(seq_len(diy), each = tstep)[seq_along(sec)] ## Get variables from netcdf file SW <- ncdf4::ncvar_get(nc, "surface_downwelling_shortwave_flux_in_air") # SW in W/m2 From cfa319573900fa449f424d2958d05cd01b35c646 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Mon, 25 Sep 2017 16:23:58 -0400 Subject: [PATCH 727/771] move model package to suggests instead of depends --- models/preles/DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/models/preles/DESCRIPTION b/models/preles/DESCRIPTION index 198f5b72b27..3a7dfceeff1 100644 --- a/models/preles/DESCRIPTION +++ b/models/preles/DESCRIPTION @@ -20,10 +20,10 @@ Imports: ncdf4 (>= 1.15), udunits2 (>= 0.11), PEcAn.data.atmosphere, - PEcAn.utils, - Rpreles + PEcAn.utils Suggests: testthat (>= 1.0.2) + Rpreles SystemRequirements: preles OS_type: unix License: FreeBSD + file LICENSE From affe1da4ffceefe9408b71c721f058f5d1be1087 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Mon, 25 Sep 2017 16:42:07 -0400 Subject: [PATCH 728/771] typo --- models/preles/DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/preles/DESCRIPTION b/models/preles/DESCRIPTION index 3a7dfceeff1..81f87c23abe 100644 --- a/models/preles/DESCRIPTION +++ b/models/preles/DESCRIPTION @@ -22,7 +22,7 @@ Imports: PEcAn.data.atmosphere, PEcAn.utils Suggests: - testthat (>= 1.0.2) + testthat (>= 1.0.2), Rpreles SystemRequirements: preles OS_type: unix From fae30e59995b031b1699f9a525381a702c0fa454 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Mon, 25 Sep 2017 17:39:33 -0400 Subject: [PATCH 729/771] namespace changes --- models/preles/NAMESPACE | 2 -- 1 file changed, 2 deletions(-) diff --git a/models/preles/NAMESPACE b/models/preles/NAMESPACE index 7f50c4a8cb5..3d12922bb60 100644 --- a/models/preles/NAMESPACE +++ b/models/preles/NAMESPACE @@ -2,5 +2,3 @@ export(runPRELES.jobsh) export(write.config.PRELES) -importFrom(ncdf4,ncvar_def) -importFrom(ncdf4,ncvar_get) From b6cf6cbe449eb20916763e9c833a4a1b3abe473f Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 26 Sep 2017 09:37:57 -0400 Subject: [PATCH 730/771] SS of Gaussian shouldnt be negative, reject --- modules/assim.batch/R/pda.define.llik.R | 24 +++++++++++++----------- modules/emulator/R/minimize.GP.R | 8 ++++++-- 2 files changed, 19 insertions(+), 13 deletions(-) diff --git a/modules/assim.batch/R/pda.define.llik.R b/modules/assim.batch/R/pda.define.llik.R index 399ef343f91..982d3b1ef58 100644 --- a/modules/assim.batch/R/pda.define.llik.R +++ b/modules/assim.batch/R/pda.define.llik.R @@ -26,8 +26,12 @@ pda.define.llik.fn <- function(settings) { llik.fn[[i]] <- function(pda.errors, llik.par) { # lnL = (n/2) * log(tau) - (tau/2) * SS - LL <- (llik.par$n/2) * log(llik.par$par) - (llik.par$par/2) * pda.errors - return(LL) + if(!is.na(llik.par$par)){ + LL <- (llik.par$n/2) * log(llik.par$par) - (llik.par$par/2) * pda.errors + return(LL) + }else{ + return(-Inf) + } } } # if-block @@ -200,16 +204,14 @@ pda.calc.llik.par <-function(settings, n, error.stats){ if (settings$assim.batch$inputs[[k]]$likelihood == "Gaussian" | settings$assim.batch$inputs[[k]]$likelihood == "multipGauss") { - # calculate a minimum scale for gamma if emulator proposes negative SS - if(error.stats[k] < 0){ - get_order <- log10(abs(error.stats[k])) - min.scale <- 1e-10 * (10^get_order) # to make this less likely - error.stats[k] <- min.scale + if(error.stats[k] > 0){ + llik.par[[k]]$par <- rgamma(1, n[k]/2, error.stats[k]/2) + names(llik.par[[k]]$par) <- paste0("tau.", names(n)[k]) + }else{ + llik.par[[k]]$par <- NA + names(llik.par[[k]]$par) <- paste0("tau.", names(n)[k]) } - - llik.par[[k]]$par <- rgamma(1, n[k]/2, error.stats[k]/2) - names(llik.par[[k]]$par) <- paste0("tau.", names(n)[k]) - + } llik.par[[k]]$n <- n[k] diff --git a/modules/emulator/R/minimize.GP.R b/modules/emulator/R/minimize.GP.R index 7e0ef250bed..ff0a50d4759 100644 --- a/modules/emulator/R/minimize.GP.R +++ b/modules/emulator/R/minimize.GP.R @@ -151,8 +151,12 @@ get_y <- function(SSnew, xnew, llik.fn, priors, llik.par) { ##' @title is.accepted ##' @export is.accepted <- function(ycurr, ynew, format = "lin") { - a <- exp(ynew - ycurr) - a > runif(1) + if(ynew == -Inf & ycurr == -Inf){ + return(FALSE) + }else{ + a <- exp(ynew - ycurr) + a > runif(1) + } } # is.accepted ##' Function to sample from a GP model From a4921e29e2e4ef61ac5ec71aa18bfbed40a7f328 Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 26 Sep 2017 10:56:22 -0400 Subject: [PATCH 731/771] change how to handle negative gaussian SS --- modules/assim.batch/R/pda.define.llik.R | 13 ++---- modules/emulator/R/minimize.GP.R | 59 +++++++++++++++++++++---- 2 files changed, 54 insertions(+), 18 deletions(-) diff --git a/modules/assim.batch/R/pda.define.llik.R b/modules/assim.batch/R/pda.define.llik.R index 982d3b1ef58..b8728b40642 100644 --- a/modules/assim.batch/R/pda.define.llik.R +++ b/modules/assim.batch/R/pda.define.llik.R @@ -26,12 +26,10 @@ pda.define.llik.fn <- function(settings) { llik.fn[[i]] <- function(pda.errors, llik.par) { # lnL = (n/2) * log(tau) - (tau/2) * SS - if(!is.na(llik.par$par)){ + LL <- (llik.par$n/2) * log(llik.par$par) - (llik.par$par/2) * pda.errors return(LL) - }else{ - return(-Inf) - } + } } # if-block @@ -204,13 +202,10 @@ pda.calc.llik.par <-function(settings, n, error.stats){ if (settings$assim.batch$inputs[[k]]$likelihood == "Gaussian" | settings$assim.batch$inputs[[k]]$likelihood == "multipGauss") { - if(error.stats[k] > 0){ + llik.par[[k]]$par <- rgamma(1, n[k]/2, error.stats[k]/2) names(llik.par[[k]]$par) <- paste0("tau.", names(n)[k]) - }else{ - llik.par[[k]]$par <- NA - names(llik.par[[k]]$par) <- paste0("tau.", names(n)[k]) - } + } llik.par[[k]]$n <- n[k] diff --git a/modules/emulator/R/minimize.GP.R b/modules/emulator/R/minimize.GP.R index ff0a50d4759..64b40917f83 100644 --- a/modules/emulator/R/minimize.GP.R +++ b/modules/emulator/R/minimize.GP.R @@ -151,12 +151,8 @@ get_y <- function(SSnew, xnew, llik.fn, priors, llik.par) { ##' @title is.accepted ##' @export is.accepted <- function(ycurr, ynew, format = "lin") { - if(ynew == -Inf & ycurr == -Inf){ - return(FALSE) - }else{ a <- exp(ynew - ycurr) a > runif(1) - } } # is.accepted ##' Function to sample from a GP model @@ -183,8 +179,31 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn jmp0 = 0.35 * (rng[, 2] - rng[, 1]), ar.target = 0.5, priors = NA, settings, run.block = TRUE, n.of.obs, llik.fn, resume.list = NULL) { + pos.check <- sapply(settings$assim.batch$inputs, `[[`, "ss.positive") + + if(length(unlist(pos.check)) == 0){ + # if not passed from settings assume none + pos.check <- rep(FALSE, length(settings$assim.batch$inputs)) + }else if(length(unlist(pos.check)) != length(settings$assim.batch$inputs)){ + # maybe one provided, but others are forgotten + # check which ones are provided in settings + from.settings <- sapply(seq_along(pos.check), function(x) !is.null(pos.check[[x]])) + tmp.check <- rep(FALSE, length(settings$assim.batch$inputs)) + # replace those with the values provided in the settings + tmp.check[from.settings] <- unlist(pos.check) + pos.check <- tmp.check + }else{ + pos.check <- as.logical(pos.check) + } + # get SS - currSS <- get_ss(gp, x0) + repeat { + currSS <- get_ss(gp, x0) + if (currSS[pos.check] > 0) { + break + } + } + currllp <- pda.calc.llik.par(settings, n.of.obs, currSS) LLpar <- unlist(sapply(currllp, `[[` , "par")) @@ -236,12 +255,24 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn # if(bounded(xnew,rng)){ # re-predict SS - currSS <- get_ss(gp, xcurr) + repeat { + currSS <- get_ss(gp, xcurr) + if (currSS[pos.check] > 0) { + break + } + } + # don't update the currllp ( = llik.par, e.g. tau) yet # calculate posterior with xcurr | currllp ycurr <- get_y(currSS, xcurr, llik.fn, priors, currllp) - newSS <- get_ss(gp, xnew) + repeat { + newSS <- get_ss(gp, xnew) + if (newSS[pos.check] > 0) { + break + } + } + newllp <- pda.calc.llik.par(settings, n.of.obs, newSS) ynew <- get_y(newSS, xnew, llik.fn, priors, newllp) @@ -265,10 +296,20 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn } } # if(bounded(xnew,rng)){ - currSS <- get_ss(gp, xcurr) + repeat { + currSS <- get_ss(gp, xcurr) + if (currSS[pos.check] > 0) { + break + } + } ycurr <- get_y(currSS, xcurr, llik.fn, priors, currllp) - newSS <- get_ss(gp, xnew) + repeat { + newSS <- get_ss(gp, xnew) + if (newSS[pos.check] > 0) { + break + } + } newllp <- pda.calc.llik.par(settings, n.of.obs, newSS) ynew <- get_y(newSS, xnew, llik.fn, priors, newllp) if (is.accepted(ycurr, ynew)) { From 13a981577c0f1c5aef3e02dd829a0c6b81d775fb Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Tue, 26 Sep 2017 13:07:22 -0400 Subject: [PATCH 732/771] clenaup and pkg check --- models/maespa/DESCRIPTION | 8 +++----- models/maespa/R/model2netcdf.MAESPA.R | 4 +--- models/maespa/R/write.config.MAESPA.R | 29 +++++++++++++++------------ models/preles/R/runPRELES.jobsh.R | 4 ++++ 4 files changed, 24 insertions(+), 21 deletions(-) diff --git a/models/maespa/DESCRIPTION b/models/maespa/DESCRIPTION index b990c3ac40a..35730be2843 100644 --- a/models/maespa/DESCRIPTION +++ b/models/maespa/DESCRIPTION @@ -11,18 +11,16 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific streamline the interaction between data and models, and to improve the efficacy of scientific investigation.This package allows for MAESPA to be run through the PEcAN workflow. -Depends: - ncdf4 Imports: + PEcAn.data.atmosphere, PEcAn.logger, PEcAn.utils, lubridate (>= 1.6.0), ncdf4 (>= 1.15), - udunits2 (>= 0.11), - Maeswrap + udunits2 (>= 0.11) Suggests: + Maeswrap, coda, - PEcAn.data.atmosphere, testthat (>= 1.0.2) SystemRequirements: MAESPA ecosystem model OS_type: unix diff --git a/models/maespa/R/model2netcdf.MAESPA.R b/models/maespa/R/model2netcdf.MAESPA.R index dfcf17e93d4..68537f76a31 100755 --- a/models/maespa/R/model2netcdf.MAESPA.R +++ b/models/maespa/R/model2netcdf.MAESPA.R @@ -22,11 +22,9 @@ ##' @export ##' ##' @author Tony Gardella -##' @importFrom ncdf4 ncvar_def model2netcdf.MAESPA <- function(outdir, sitelat, sitelon, start_date, end_date, stem_density) { - library(Maeswrap) - + ### Read in model output using Maeswrap. Dayflx.dat, watbalday.dat dayflx.dataframe <- Maeswrap::readdayflux(filename = "Dayflx.dat") watbalday.dataframe <- Maeswrap::readwatbal(filename = "watbalday.dat") diff --git a/models/maespa/R/write.config.MAESPA.R b/models/maespa/R/write.config.MAESPA.R index de3df9b17d3..cb2b36e361d 100755 --- a/models/maespa/R/write.config.MAESPA.R +++ b/models/maespa/R/write.config.MAESPA.R @@ -24,8 +24,11 @@ ##' @author Tony Gardella ##-------------------------------------------------------------------------------------------------# write.config.MAESPA <- function(defaults, trait.values, settings, run.id) { - - library(Maeswrap) + + if(!require("Maeswrap")){ + logger.severe("The Maeswrap package is not installed. + Please consult PEcAn documentation for install notes") + } # find out where to write run/ouput rundir <- file.path(settings$host$rundir, as.character(run.id)) @@ -91,10 +94,10 @@ write.config.MAESPA <- function(defaults, trait.values, settings, run.id) { confile.run.path <- file.path(settings$rundir, run.id, "confile.dat") writeLines(confile, con = confile.run.path) - replacePAR(confile.run.path, "itermax", "model", newval = 100, noquotes = TRUE) - replacePAR(confile.run.path, "itargets", "treescon", newval = 153, noquotes = TRUE) - replacePAR(confile.run.path, "startdate", "dates", newval = start_date) - replacePAR(confile.run.path, "enddate", "dates", newval = end_date) + Maeswrap::replacePAR(confile.run.path, "itermax", "model", newval = 100, noquotes = TRUE) + Maeswrap::replacePAR(confile.run.path, "itargets", "treescon", newval = 153, noquotes = TRUE) + Maeswrap::replacePAR(confile.run.path, "startdate", "dates", newval = start_date) + Maeswrap::replacePAR(confile.run.path, "enddate", "dates", newval = end_date) ### str.dat USING DEFAULT EXAMPLE VERSION RIGHT NOW AS IS strfile.path <- system.file("str.dat", package = "PEcAn.MAESPA") @@ -108,10 +111,10 @@ write.config.MAESPA <- function(defaults, trait.values, settings, run.id) { phyfile.run.path <- file.path(settings$rundir, run.id, "phy.dat") writeLines(phyfile, con = phyfile.run.path) - replacePAR(phyfile.run.path, "values", "vcmax", newval = vcmax) - replacePAR(phyfile.run.path, "dates", "vcmax", newval = start_date) - replacePAR(phyfile.run.path, "values", "jmax", newval = jmax) - replacePAR(phyfile.run.path, "dates", "jmax", newval = start_date) + Maeswrap::replacePAR(phyfile.run.path, "values", "vcmax", newval = vcmax) + Maeswrap::replacePAR(phyfile.run.path, "dates", "vcmax", newval = start_date) + Maeswrap::replacePAR(phyfile.run.path, "values", "jmax", newval = jmax) + Maeswrap::replacePAR(phyfile.run.path, "dates", "jmax", newval = start_date) ### trees.dat treesfile.path <- system.file("trees.dat", package = "PEcAn.MAESPA") @@ -119,9 +122,9 @@ write.config.MAESPA <- function(defaults, trait.values, settings, run.id) { treesfile.run.path <- file.path(settings$rundir, run.id, "trees.dat") writeLines(treesfile, con = treesfile.run.path) - replacePAR(treesfile.run.path, "xmax", "plot", newval = xmax, noquotes = TRUE) - replacePAR(treesfile.run.path, "ymax", "plot", newval = ymax, noquotes = TRUE) - replacePAR(treesfile.run.path, "notrees", "plot", newval = notrees, noquotes = TRUE) + Maeswrap::replacePAR(treesfile.run.path, "xmax", "plot", newval = xmax, noquotes = TRUE) + Maeswrap::replacePAR(treesfile.run.path, "ymax", "plot", newval = ymax, noquotes = TRUE) + Maeswrap::replacePAR(treesfile.run.path, "notrees", "plot", newval = notrees, noquotes = TRUE) ## watpar.dat watparsfile.path <- system.file("watpars.dat", package = "PEcAn.MAESPA") diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index 411e4c5d196..f2e857f8597 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -18,6 +18,10 @@ ##' @author Tony Gardella, Michael Dietze runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, start.date, end.date) { + if(!require("Rpreles")){ + logger.severe("The Rpreles package is not installed. + Please contact the PEcAn team to obtain source code") + } # Process start and end dates start_date <- as.POSIXlt(start.date, tz = "UTC") From 93cc823b855e7ecfc9bed62e5d288c4005c2d3d2 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Tue, 26 Sep 2017 13:09:15 -0400 Subject: [PATCH 733/771] make doc --- models/maespa/NAMESPACE | 1 - 1 file changed, 1 deletion(-) diff --git a/models/maespa/NAMESPACE b/models/maespa/NAMESPACE index 860544e53b8..49743fe51e1 100644 --- a/models/maespa/NAMESPACE +++ b/models/maespa/NAMESPACE @@ -3,4 +3,3 @@ export(met2model.MAESPA) export(model2netcdf.MAESPA) export(write.config.MAESPA) -importFrom(ncdf4,ncvar_def) From 11d1a349c0eec5b795310beb5de404bb67433687 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Tue, 26 Sep 2017 13:15:17 -0400 Subject: [PATCH 734/771] changelog --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a219be203bc..5059ea8af20 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -52,7 +52,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - #1594 shiny/workflowPlot Refactoring of code. `get_workflow_ids` in db/R/query.dplyr.R changed with `ensemble = FALSE`. Also allowing to load all workflow IDs. `load_data_single_run` and `var_names_all` also moved from shiny/workflowPlot/server.R to query.dplyr.R - `PEcAn.remote::start.model.runs` has been significantly refactored to be less redundant and more robust - `betyConnect` function in `query.dplyr.R` is now refactored into `read_web_config` so that the the Data-Ingest app can leverage `read_web_config` and provide it with a machine specific filepath for `.../dbfiles` - +- Rpreles and Maeswrap package moved to suggest checked for within package function. ## [1.5.0] - 2017-07-13 From 0c161cf55fd39a9c6346029b90c13ad5d78f7d8f Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 26 Sep 2017 13:16:00 -0400 Subject: [PATCH 735/771] need to consider failed model runs --- modules/assim.batch/R/pda.utils.R | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/modules/assim.batch/R/pda.utils.R b/modules/assim.batch/R/pda.utils.R index 9bf3641a36c..d36a0568b8b 100644 --- a/modules/assim.batch/R/pda.utils.R +++ b/modules/assim.batch/R/pda.utils.R @@ -687,6 +687,7 @@ return.bias <- function(isbias, model.out, inputs, prior.list.bias, nbias, for(i in seq_along(isbias)){ bias.params[[i]] <- matrix(NA, nrow = length(model.out), ncol = nbias) + bias.probs[[i]] <- matrix(NA, nrow = length(model.out), ncol = nbias) for(iknot in seq_along(model.out)){ if(anyNA(model.out[[iknot]], recursive = TRUE)){ @@ -708,6 +709,10 @@ return.bias <- function(isbias, model.out, inputs, prior.list.bias, nbias, prior.names[i] <- paste0("bias.", sapply(model.out[[1]],names)[isbias[i]]) names(bias.params)[i] <- paste0("bias.", sapply(model.out[[1]],names)[isbias[i]]) + + # get rid of NAs for distribution fitting + bias.probs[[i]] <- bias.params[[i]][complete.cases(bias.params[[i]]), ] + names(bias.probs)[i] <- paste0("bias.", sapply(model.out[[1]],names)[isbias[i]]) } rownames(bias.prior) <- prior.names @@ -715,7 +720,8 @@ return.bias <- function(isbias, model.out, inputs, prior.list.bias, nbias, # fit a distribution # TODO: check this when more than one multiplicative Gaussian requested # probably need to re-format bias.params - bias.prior <- PEcAn.MA::approx.posterior(bias.params, bias.prior) + bias.params + bias.prior <- PEcAn.MA::approx.posterior(bias.probs, bias.prior) prior.list.bias[[(length(prior.list.bias)+1)]] <- bias.prior From 7d326f58a2eabf5ec257a231926fbe31fdfee31f Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 26 Sep 2017 13:39:40 -0400 Subject: [PATCH 736/771] forgot the case for no zero bound SS --- modules/assim.batch/R/pda.emulator.R | 968 ++++++++++----------------- 1 file changed, 341 insertions(+), 627 deletions(-) diff --git a/modules/assim.batch/R/pda.emulator.R b/modules/assim.batch/R/pda.emulator.R index 3a96c477c5d..c60583727ad 100644 --- a/modules/assim.batch/R/pda.emulator.R +++ b/modules/assim.batch/R/pda.emulator.R @@ -1,685 +1,399 @@ -##' Paramater Data Assimilation using emulator -##' -##' @title Paramater Data Assimilation using emulator -##' @param settings = a pecan settings list -##' @param external.data = list of inputs -##' @param external.priors = list or priors -##' -##' @return nothing. Diagnostic plots, MCMC samples, and posterior distributions -##' are saved as files and db records. -##' -##' @author Mike Dietze -##' @author Ryan Kelly, Istem Fer +##' @name minimize.GP +##' @title minimize.GP ##' @export -pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, - params.id = NULL, param.names = NULL, prior.id = NULL, - chain = NULL, iter = NULL, adapt = NULL, adj.min = NULL, - ar.target = NULL, jvar = NULL, n.knot = NULL) { - - ## this bit of code is useful for defining the variables passed to this function if you are - ## debugging - if (FALSE) { - external.data <- external.priors <- NULL - params.id <- param.names <- prior.id <- chain <- iter <- NULL - n.knot <- adapt <- adj.min <- ar.target <- jvar <- NULL - } - - # handle extention flags - # is this an extension run - extension.check <- is.null(settings$assim.batch$extension) - - if (extension.check) { - # not an extension run - run.normal <- TRUE - run.round <- FALSE - run.longer <- FALSE - } else if (!extension.check & settings$assim.batch$extension == "round") { - # 'round' extension - run.normal <- FALSE - run.round <- TRUE - run.longer <- FALSE - } else if (!extension.check & settings$assim.batch$extension == "longer") { - # 'longer' extension - run.normal <- FALSE - run.round <- FALSE - run.longer <- TRUE +##' +##' @param gp +##' @param rng +##' @param x0 +##' @param splinefuns +##' +##' @author Michael Dietze +minimize.GP <- function(gp, rng, x0, splinefuns = NULL) { + + isotropic <- gp$isotropic + x.id <- gp$x.id + ey <- 0 + + if (gp$method == "bayes") { + samp <- gp$samp + tauw <- coda::mcmc(gp$tauw[samp, ]) + psi <- coda::mcmc(gp$psi[samp, ]) + mu <- coda::mcmc(gp$mu) + tauv <- W <- NULL + } else { + ## MLE + psi <- gp$psi + mu <- gp$mu + tauw <- gp$tauw + tauv <- gp$tauv } - ## -------------------------------------- Setup ------------------------------------- - ## Handle settings - settings <- pda.settings( - settings=settings, params.id=params.id, param.names=param.names, - prior.id=prior.id, chain=chain, iter=iter, adapt=adapt, - adj.min=adj.min, ar.target=ar.target, jvar=jvar, n.knot=n.knot, run.round) - - ## history restart - pda.restart.file <- file.path(settings$outdir,paste0("history.pda", - settings$assim.batch$ensemble.id, ".Rdata")) - current.step <- "START" - - ## will be used to check if multiplicative Gaussian is requested - any.mgauss <- sapply(settings$assim.batch$inputs, `[[`, "likelihood") - isbias <- which(unlist(any.mgauss) == "multipGauss") - - ## check if scaling factors are gonna be used - any.scaling <- sapply(settings$assim.batch$param.names, `[[`, "scaling") - sf <- unique(unlist(any.scaling)) - - ## Open database connection - if (settings$database$bety$write) { - con <- try(db.open(settings$database$bety), silent = TRUE) - if (is(con, "try-error")) { - con <- NULL + psibar <- NULL + if (isotropic) { + psibar <- median(psi) + } else { + if (is.matrix(psi)) { + psibar <- apply(psi, 2, median) } else { - on.exit(db.close(con)) + psibar <- psi } + } + tauwbar <- median(tauw) + S <- calcSpatialCov(gp$d, psibar, tauwbar) + # S12 <- Sprime[1:(npred*dim),(npred*dim+1):(n.unique+npred*dim)] S22 <- + # Sprime[(npred*dim+1):(n.unique+npred*dim),(npred*dim+1):(n.unique+npred*dim)] + S22inv <- solve(S) + if (gp$zeroMean) { + ey <- 0 } else { - con <- NULL + ey <- max(mu) #mean(y) } - - bety <- src_postgres(dbname = settings$database$bety$dbname, - host = settings$database$bety$host, - user = settings$database$bety$user, - password = settings$database$bety$password) + ybar <- tapply(gp$y, gp$x.id, mean) + k <- S22inv %*% (ybar - ey) - ## Load priors - if(is.null(external.priors)){ - temp <- pda.load.priors(settings, bety$con, run.normal) - prior.list <- temp$prior - settings <- temp$settings - }else{ - prior.list <- external.priors + nlm(gpeval, x0, k = k, mu = ey, tau = tauwbar, psi = psibar, + x = gp$x.compact, rng = rng, splinefcns = splinefcns) +} # minimize.GP + + +##' Calculates the probability of a set of parameter values, given by xnew +##' +##' @name gpeval +##' @title gpeval +##' @export +##' +##' @param xnew +##' @param k +##' @param mu +##' @param tau +##' @param psi +##' @param x +##' @param rng range +##' @param splinefcns +##' +##' @author Michael Dietze +gpeval <- function(xnew, k, mu, tau, psi, x, rng, splinefcns) { + + ## second calc value + S12 <- sapply(seq_along(k), function(i) { + tau * exp(-sum(psi * (xnew - x[i, ]) ^ 2)) + }) + yprime <- mu + sum(S12 * k) + + if (!is.null(splinefcns)) { + ## add trend surface back on + y0 <- splinefuns[[length(xnew) + 1]] + f <- sapply(seq_along(xnew), function(j) { + splinefuns[[j]](xnew[j]) + }) + y.trend <- y0 + sum(f - y0) + yprime <- yprime + ytrend } - pname <- lapply(prior.list, rownames) - n.param.all <- sapply(prior.list, nrow) + return(yprime) +} # gpeval - if(is.null(external.data)){ - inputs <- load.pda.data(settings, bety) - }else{ - inputs <- external.data - } - n.input <- length(inputs) - +##' @name ddist +##' @title ddist +##' @export +ddist <- function(x, prior) { + eval(parse(text = paste("d", prior$distn, sep = "")))(x, prior$parama, prior$paramb) +} # ddist - ## Set model-specific functions - do.call("library", list(paste0("PEcAn.", settings$model$type))) - my.write.config <- paste("write.config.", settings$model$type, sep = "") - if (!exists(my.write.config)) { - PEcAn.logger::logger.severe(paste(my.write.config, - "does not exist. Please make sure that the PEcAn interface is loaded for", - settings$model$type)) - } + +# calculate.prior <- function(samples, priors){ traits <- names(samples) joint <- +# sum(sapply(1:nrow(priors), function(i) -log(ddist(samples[[i]], priors[i,])))) #note: +# this is within the negative log domain return(joint) } + +##' @name calculate.prior +##' @title calculate.prior +##' @export +calculate.prior <- function(samples, priors) { + sum(sapply(seq_along(priors), function(i) eval(priors[[i]], list(x = samples[[i]])))) +} # calculate.prior + +##' @name get_ss +##' @title get_ss +##' @export +get_ss <- function(gp, xnew) { - ## Select parameters to constrain - prior.ind <- lapply(seq_along(settings$pfts), - function(x) which(pname[[x]] %in% settings$assim.batch$param.names[[x]])) - n.param <- sapply(prior.ind, length) - prior.ind.orig <- lapply(seq_along(settings$pfts), - function(x) which(pname[[x]] %in% settings$assim.batch$param.names[[x]] | - pname[[x]] %in% any.scaling[[x]])) - n.param.orig <- sapply(prior.ind.orig, length) + SS <- numeric(length(gp)) - ## Get the workflow id - if ("workflow" %in% names(settings)) { - workflow.id <- settings$workflow$id - } else { - workflow.id <- -1 + X <- matrix(unlist(xnew), nrow = 1, byrow = TRUE) + + for(igp in seq_along(gp)){ + Y <- mlegp::predict.gp(gp[[igp]], newData = X[, 1:ncol(gp[[igp]]$X), drop=FALSE], se.fit = TRUE) + SS[igp] <- rnorm(1, Y$fit, Y$se.fit) } + return(SS) - ## Create an ensemble id - settings$assim.batch$ensemble.id <- pda.create.ensemble(settings, con, workflow.id) +} # get_ss + +##' @name get_y +##' @title get_y +##' @export +get_y <- function(SSnew, xnew, llik.fn, priors, llik.par) { + + likelihood <- pda.calc.llik(SSnew, llik.fn, llik.par) + + prior.prob <- calculate.prior(xnew, priors) + posterior.prob <- likelihood + prior.prob + return(posterior.prob) - ## Set up likelihood functions - llik.fn <- pda.define.llik.fn(settings) +} # get_y + +# is.accepted <- function(ycurr, ynew, format='lin'){ z <- exp(ycurr-ynew) acceptance <- +# z>runif(1) return(acceptance) } + +##' @name is.accepted +##' @title is.accepted +##' @export +is.accepted <- function(ycurr, ynew, format = "lin") { + a <- exp(ynew - ycurr) + a > runif(1) +} # is.accepted + +##' Function to sample from a GP model +##' that is assumed to be a -lnLikelihood surface +##' with flat priors and bounded region +##' +##' @name mcmc.GP +##' @title mcmc.GP +##' @export +##' +##' @param gp +##' @param x0 +##' @param nmcmc +##' @param rng +##' @param format lin = lnlike fcn, log = log(lnlike) +##' @param mix each = jump each dim. independently, joint = jump all at once +##' @param splinefcns +##' @param jmp0 +##' @param ar.target +##' @param priors +##' +##' @author Michael Dietze +mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcns = NULL, + jmp0 = 0.35 * (rng[, 2] - rng[, 1]), ar.target = 0.5, priors = NA, settings, + run.block = TRUE, n.of.obs, llik.fn, resume.list = NULL) { + + pos.check <- sapply(settings$assim.batch$inputs, `[[`, "ss.positive") + + if(length(unlist(pos.check)) == 0){ + # if not passed from settings assume none + pos.check <- rep(FALSE, length(settings$assim.batch$inputs)) + }else if(length(unlist(pos.check)) != length(settings$assim.batch$inputs)){ + # maybe one provided, but others are forgotten + # check which ones are provided in settings + from.settings <- sapply(seq_along(pos.check), function(x) !is.null(pos.check[[x]])) + tmp.check <- rep(FALSE, length(settings$assim.batch$inputs)) + # replace those with the values provided in the settings + tmp.check[from.settings] <- unlist(pos.check) + pos.check <- tmp.check + }else{ + pos.check <- as.logical(pos.check) + } - ## ------------------------------------ Emulator ------------------------------------ - # if we are going to throw scaling factor(s) instead of parameters - # 1. append scaling factor priors to prior.list - # 2. use the same probs for all pft params to be scaled - if(!is.null(sf)){ - sf.ind <- length(prior.list) + 1 - sf.list <- pda.generate.sf(settings$assim.batch$n.knot, sf, prior.list) - probs.sf <- sf.list$probs - prior.list <- sf.list$priors - }else { - probs.sf <- NULL + # get SS + if(!any(pos.check)){ + currSS <- get_ss(gp, x0) + }else{ + repeat { + currSS <- get_ss(gp, x0) + if (currSS[pos.check] > 0) { + break + } + } } - ## Set prior distribution functions (d___, q___, r___, and multivariate versions) - prior.fn <- lapply(prior.list, pda.define.prior.fn) + currllp <- pda.calc.llik.par(settings, n.of.obs, currSS) + LLpar <- unlist(sapply(currllp, `[[` , "par")) + + xcurr <- x0 + dim <- length(x0) + samp <- matrix(NA, nmcmc, dim) + par <- matrix(NA, nmcmc, length(LLpar), dimnames = list(NULL, names(LLpar))) # note: length(LLpar) can be 0 - ## Propose parameter knots (X) for emulator design - knots.list <- lapply(seq_along(settings$pfts), - function(x) pda.generate.knots(settings$assim.batch$n.knot, sf, probs.sf, - n.param.all[x], - prior.ind.orig[[x]], - prior.fn[[x]], - pname[[x]])) - names(knots.list) <- sapply(settings$pfts,"[[",'name') - knots.params <- lapply(knots.list, `[[`, "params") - knots.probs <- lapply(knots.list, `[[`, "probs") + if (run.block) { + jcov <- diag((jmp0)^2) + accept.count <- 0 + start <- 1 + # jmp <- mvjump(ic=jmp0,rate=ar.target, nc=dim) + } else { + jcov <- jmp0 + accept.count <- resume.list$ac + prev.samp <- resume.list$prev.samp + prev.par <- resume.list$par + colnames(prev.samp) <- names(x0) + samp <- rbind(prev.samp, samp) + par <- rbind(prev.par, par) + start <- dim(prev.samp)[1] + 1 + nmcmc <- dim(samp)[1] + # jmp <- mvjump(ic=diag(jmp0),rate=ar.target, nc=dim) + } - current.step <- "GENERATE KNOTS" - save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) - ## Run this block if this is a "round" extension - if (run.round) { - - # loads the posteriors of the the previous emulator run - temp.round <- pda.load.priors(settings, con, run.round) - prior.round.list <- temp.round$prior - - - prior.round.fn <- lapply(prior.round.list, pda.define.prior.fn) - - ## Propose a percentage (if not specified 80%) of the new parameter knots from the posterior of the previous run - knot.par <- ifelse(!is.null(settings$assim.batch$knot.par), - as.numeric(settings$assim.batch$knot.par), - 0.8) - - n.post.knots <- floor(knot.par * settings$assim.batch$n.knot) + for (g in start:nmcmc) { + + if (mix == "joint") { - if(!is.null(sf)){ - load(settings$assim.batch$sf.path) - sf.round.post <- pda.define.prior.fn(sf.post.distns) - rm(sf.post.distns) - n.sf <- length(sf) - sf.round.list <- pda.generate.knots(n.post.knots, - sf = NULL, probs.sf = NULL, - n.param.all = n.sf, - prior.ind = seq_len(n.sf), - prior.fn = sf.round.post, - pname = paste0(sf, "_SF")) - probs.round.sf <- sf.round.list$params - }else { - probs.round.sf <- NULL + # adapt + if ((g > 2) && ((g - 1) %% settings$assim.batch$jump$adapt == 0)) { + params.recent <- samp[(g - settings$assim.batch$jump$adapt):(g - 1), ] + colnames(params.recent) <- names(x0) + # accept.count <- round(jmp@arate[(g-1)/settings$assim.batch$jump$adapt]*100) + jcov <- pda.adjust.jumps.bs(settings, jcov, accept.count, params.recent) + accept.count <- 0 # Reset counter } - ## set prior distribution functions for posterior of the previous emulator run - knots.list.temp <- lapply(seq_along(settings$pfts), - function(x) pda.generate.knots(n.post.knots, - sf, probs.round.sf, - n.param.all[x], - prior.ind.orig[[x]], - prior.round.fn[[x]], - pname[[x]])) - knots.params.temp <- lapply(knots.list.temp, `[[`, "params") - - - for (i in seq_along(settings$pfts)) { - # mixture of knots - mix.knots <- sample(nrow(knots.params[[i]]), (settings$assim.batch$n.knot - n.post.knots)) - knots.list[[i]]$params <- rbind(knots.params[[i]][mix.knots, ], - knots.list.temp[[i]]$params) - names(knots.list)[i] <- settings$pfts[[i]]['name'] + ## propose new parameters + repeat { + xnew <- mvrnorm(1, unlist(xcurr), jcov) + if (bounded(xnew, rng)) { + break + } } + # if(bounded(xnew,rng)){ - knots.params <- lapply(knots.list, `[[`, "params") - knots.probs <- lapply(knots.list, `[[`, "probs") + # re-predict SS + if(!any(pos.check)){ + currSS <- get_ss(gp, xcurr) + }else{ + repeat { + currSS <- get_ss(gp, xcurr) + if (currSS[pos.check] > 0) { + break + } + } + } - current.step <- "Generate Knots: round-if block" - save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) - } # end round-if block - - - ## Run this block if this is normal run or a "round" extension - if(run.normal | run.round){ - ## Set up runs and write run configs for all proposed knots - run.ids <- pda.init.run(settings, con, my.write.config, workflow.id, knots.params, - n = settings$assim.batch$n.knot, - run.names = paste0(settings$assim.batch$ensemble.id, ".knot.", - 1:settings$assim.batch$n.knot)) - current.step <- "pda.init.run" - save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) + # don't update the currllp ( = llik.par, e.g. tau) yet + # calculate posterior with xcurr | currllp + ycurr <- get_y(currSS, xcurr, llik.fn, priors, currllp) - ## start model runs - PEcAn.remote::start.model.runs(settings, settings$database$bety$write) - - ## Retrieve model outputs and error statistics - model.out <- list() - pda.errors <- list() - - - ## read model outputs - for (i in seq_len(settings$assim.batch$n.knot)) { - align.return <- pda.get.model.output(settings, run.ids[i], bety, inputs) - model.out[[i]] <- align.return$model.out - if(all(!is.na(model.out[[i]]))){ - inputs <- align.return$inputs + if(!any(pos.check)){ + newSS <- get_ss(gp, xnew) + }else{ + repeat { + newSS <- get_ss(gp, xnew) + if (newSS[pos.check] > 0) { + break + } } } - - current.step <- "pda.get.model.output" - save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) - # efficient sample size calculation - inputs <- pda.neff.calc(inputs) + newllp <- pda.calc.llik.par(settings, n.of.obs, newSS) + ynew <- get_y(newSS, xnew, llik.fn, priors, newllp) - # handle bias parameters if multiplicative Gaussian is listed in the likelihoods - if(any(unlist(any.mgauss) == "multipGauss")) { - # how many bias parameters per dataset requested - nbias <- ifelse(is.null(settings$assim.batch$inputs[[isbias]]$nbias), 1, - as.numeric(settings$assim.batch$inputs[[isbias]]$nbias)) - bias.list <- return.bias(isbias, model.out, inputs, prior.list, nbias, run.round, settings$assim.batch$bias.path) - bias.terms <- bias.list$bias.params - prior.list <- bias.list$prior.list.bias - prior.fn <- lapply(prior.list, pda.define.prior.fn) - } else { - bias.terms <- NULL + if (is.accepted(ycurr, ynew)) { + xcurr <- xnew + currSS <- newSS + accept.count <- accept.count + 1 } - - for (i in seq_len(settings$assim.batch$n.knot)) { - if(!is.null(bias.terms)){ - all.bias <- lapply(bias.terms, function(n) n[i,]) - all.bias <- do.call("rbind", all.bias) - } else { - all.bias <- NULL - } - ## calculate error statistics and save in the DB - pda.errors[[i]] <- pda.calc.error(settings, con, model_out = model.out[[i]], run.id = run.ids[i], inputs, bias.terms = all.bias) - } - - } # end if-block - current.step <- "pda.calc.error" - save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) - - init.list <- list() - jmp.list <- list() - - prior.all <- do.call("rbind", prior.list) - length.pars <- 0 - prior.ind.list <- prior.ind.list.ns <- list() - # now I need to go through all parameters for each pft, but leave out the ones that scaling factor is requested - for(p in seq_along(settings$assim.batch$param.names)){ - param.names <- settings$assim.batch$param.names[[p]] - prior.ind.list[[p]] <- length.pars + which(pname[[p]] %in% unlist(param.names) & - !(pname[[p]] %in% sf)) - prior.ind.list.ns[[p]] <- length.pars + which(pname[[p]] %in% unlist(param.names)) - length.pars <- length.pars + length(pname[[p]]) - } - prior.ind.all <- unlist(prior.ind.list) - prior.ind.all.ns <- unlist(prior.ind.list.ns) - # if no scaling is requested prior.ind.all == prior.ind.all.ns - # keep this ind.all w/o bias until extracting prob values below - - if (run.normal | run.round) { - - # retrieve n - n.of.obs <- sapply(inputs,`[[`, "n") - names(n.of.obs) <- sapply(model.out[[1]],names) - - # UPDATE: Use mlegp package, I can now draw from parameter space - knots.params.all <- do.call("cbind", knots.params) - X <- knots.params.all[, prior.ind.all, drop = FALSE] - - if(!is.null(sf)){ - X <- cbind(X, probs.sf) - } - - # retrieve SS - error.statistics <- list() - SS.list <- list() - bc <- 1 - - # what percentage of runs is allowed to fail? - if(!is.null(settings$assim.batch$allow.fail)){ - allow.fail <- as.numeric(settings$assim.batch$allow.fail) + # now update currllp | xcurr + currllp <- pda.calc.llik.par(settings, n.of.obs, currSS) + pcurr <- unlist(sapply(currllp, `[[` , "par")) + # } mix = each } else { - allow.fail <- 0.5 - } - # what is it in number of runs? - no.of.allowed <- floor(settings$assim.batch$n.knot * allow.fail) - - for(inputi in seq_len(n.input)){ - error.statistics[[inputi]] <- sapply(pda.errors,`[[`, inputi) - - if(unlist(any.mgauss)[inputi] == "multipGauss") { - - # if yes, then we need to include bias term in the emulator - #bias.probs <- bias.list$bias.probs - #biases <- c(t(bias.probs[[bc]])) - bias.params <- bias.list$bias.params - biases <- c(t(bias.params[[bc]])) - bc <- bc + 1 + for (i in seq_len(dim)) { + ## propose new + repeat { + xnew[i] <- rnorm(1, xcurr[[i]], p(jmp)[i]) + if (bounded(xnew[i], rng[i, , drop = FALSE])) { + break + } + } + # if(bounded(xnew,rng)){ + if(!any(pos.check)){ + currSS <- get_ss(gp, xcurr) + }else{ + repeat { + currSS <- get_ss(gp, xcurr) + if (currSS[pos.check] > 0) { + break + } + } + } - # replicate model parameter set per bias parameter - rep.rows <- rep(1:nrow(X), each = nbias) - X.rep <- X[rep.rows,] - Xnew <- cbind(X.rep, biases) - colnames(Xnew) <- c(colnames(X.rep), paste0("bias.", names(n.of.obs)[inputi])) - SS.list[[inputi]] <- cbind(Xnew, c(error.statistics[[inputi]])) + ycurr <- get_y(currSS, xcurr, llik.fn, priors, currllp) - } else { - SS.list[[inputi]] <- cbind(X, error.statistics[[inputi]]) - } # if-block - - # check failed runs and remove them if you'll have a reasonable amount of param sets after removal - # how many runs failed? - no.of.failed <- sum(is.na(SS.list[[inputi]][, ncol(SS.list[[inputi]])])) - - # check if you're left with enough sets - if(no.of.failed < no.of.allowed & (settings$assim.batch$n.knot - no.of.failed) > 1){ - SS.list[[inputi]] <- SS.list[[inputi]][!rowSums(is.na(SS.list[[inputi]])), ] - if( no.of.failed > 0){ - PEcAn.logger::logger.info(paste0(no.of.failed, " runs failed. Emulator for ", names(n.of.obs)[inputi], " will be built with ", settings$assim.batch$n.knot - no.of.failed, " knots.")) - } - } else{ - PEcAn.logger::logger.error(paste0("Too many runs failed, not enough parameter set to build emulator for ", names(n.of.obs)[inputi], ".")) - } - - } # for-loop - - if (run.round) { - # check if this is another 'round' of emulator - - # load original knots - load(settings$assim.batch$ss.path) - # add on - SS <- lapply(seq_along(SS), function(iss) rbind(SS.list[[iss]], SS[[iss]])) - - } else { - SS <- SS.list - } - - PEcAn.logger::logger.info(paste0("Using 'mlegp' package for Gaussian Process Model fitting.")) - - ## Generate emulator on SS, return a list ## - - # start the clock - ptm.start <- proc.time() - - # prepare for parallelization - dcores <- parallel::detectCores() - 1 - ncores <- min(max(dcores, 1), length(SS)) - - cl <- parallel::makeCluster(ncores, type="FORK") - - ## Parallel fit for GPs - GPmodel <- parallel::parLapply(cl, SS, function(x) mlegp::mlegp(X = x[, -ncol(x), drop = FALSE], Z = x[, ncol(x), drop = FALSE], verbose = 0)) - # GPmodel <- lapply(SS, function(x) mlegp::mlegp(X = x[, -ncol(x), drop = FALSE], Z = x[, ncol(x), drop = FALSE], verbose = 0)) - - parallel::stopCluster(cl) - - # Stop the clock - ptm.finish <- proc.time() - ptm.start - PEcAn.logger::logger.info(paste0("GP fitting took ", paste0(round(ptm.finish[3])), " seconds.")) - - - gp <- GPmodel - - } else { # is this a "longer" type of extension run - - load(settings$assim.batch$emulator.path) # load previously built emulator(s) to run a longer mcmc - load(settings$assim.batch$ss.path) - load(settings$assim.batch$resume.path) - - n.of.obs <- resume.list[[1]]$n.of.obs - - if(any(unlist(any.mgauss) == "multipGauss")){ - load(settings$assim.batch$bias.path) # load prior.list with bias term from previous run - prior.all <- do.call("rbind", prior.list) - } - - - for (c in seq_len(settings$assim.batch$chain)) { - init.list[[c]] <- resume.list[[c]]$prev.samp[nrow(resume.list[[c]]$prev.samp), ] - jmp.list[[c]] <- resume.list[[c]]$jump - } - } - - # add indice and increase n.param for scaling factor - if(!is.null(sf)){ - prior.ind.all <- c(prior.ind.all, - ((length.pars + 1): (length.pars + length(sf)))) - n.param <- c(n.param, length(sf)) - length.pars <- length.pars + length(sf) - } - - # add indice and increase n.param for bias - if(any(unlist(any.mgauss) == "multipGauss")){ - prior.ind.all <- c(prior.ind.all, - ((length.pars + 1) : (length.pars + length(isbias)))) - prior.ind.all.ns <- c(prior.ind.all.ns, - ((length.pars + 1) : (length.pars + length(isbias)))) - n.param <- c(n.param, length(isbias)) - n.param.orig <- c(n.param.orig, length(isbias)) - length.pars <- length.pars + length(isbias) - } - - - ## Set up prior functions accordingly - prior.fn.all <- pda.define.prior.fn(prior.all) - - # define range to make sure mcmc.GP doesn't propose new values outside - rng <- matrix(c(sapply(prior.fn.all$qprior[prior.ind.all], eval, list(p = 1e-05)), - sapply(prior.fn.all$qprior[prior.ind.all], eval, list(p = 0.99999))), - nrow = sum(n.param)) - - if (run.normal | run.round) { - - resume.list <- list() - - for (c in seq_len(settings$assim.batch$chain)) { - jmp.list[[c]] <- sapply(prior.fn.all$qprior, - function(x) 0.1 * diff(eval(x, list(p = c(0.05, 0.95)))))[prior.ind.all] - jmp.list[[c]] <- sqrt(jmp.list[[c]]) - - init.x <- lapply(prior.ind.all, function(v) eval(prior.fn.all$rprior[[v]], list(n = 1))) - names(init.x) <- rownames(prior.all)[prior.ind.all] - init.list[[c]] <- init.x - resume.list[[c]] <- NA - } - } - - if (!is.null(settings$assim.batch$mix)) { - mix <- settings$assim.batch$mix - } else if (sum(n.param) > 1) { - mix <- "joint" - } else { - mix <- "each" - } - - PEcAn.logger::logger.info(paste0("Starting emulator MCMC. Please wait.")) - - current.step <- "pre-MCMC" - save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) - - # start the clock - ptm.start <- proc.time() - - # prepare for parallelization - dcores <- parallel::detectCores() - 1 - ncores <- min(max(dcores, 1), settings$assim.batch$chain) - - PEcAn.logger::logger.setOutputFile(file.path(settings$outdir, "pda.log")) - - cl <- parallel::makeCluster(ncores, type="FORK", outfile = file.path(settings$outdir, "pda.log")) - - ## Sample posterior from emulator - mcmc.out <- parallel::parLapply(cl, 1:settings$assim.batch$chain, function(chain) { - mcmc.GP(gp = gp, ## Emulator(s) - x0 = init.list[[chain]], ## Initial conditions - nmcmc = settings$assim.batch$iter, ## Number of reps - rng = rng, ## range - format = "lin", ## "lin"ear vs "log" of LogLikelihood - mix = mix, ## Jump "each" dimension independently or update them "joint"ly - jmp0 = jmp.list[[chain]], ## Initial jump size - ar.target = settings$assim.batch$jump$ar.target, ## Target acceptance rate - priors = prior.fn.all$dprior[prior.ind.all], ## priors - settings = settings, - run.block = (run.normal | run.round), - n.of.obs = n.of.obs, - llik.fn = llik.fn, - resume.list = resume.list[[chain]] - ) - }) - - parallel::stopCluster(cl) - - # Stop the clock - ptm.finish <- proc.time() - ptm.start - PEcAn.logger::logger.info(paste0("Emulator MCMC took ", paste0(round(ptm.finish[3])), " seconds for ", paste0(settings$assim.batch$iter), " iterations.")) - - current.step <- "post-MCMC" - save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) - - mcmc.samp.list <- sf.samp.list <- list() - - for (c in seq_len(settings$assim.batch$chain)) { - - m <- matrix(NA, nrow = nrow(mcmc.out[[c]]$mcmc.samp), ncol = length(prior.ind.all.ns)) - - if(!is.null(sf)){ - sfm <- matrix(NA, nrow = nrow(mcmc.out[[c]]$mcmc.samp), ncol = length(sf)) - } - ## Set the prior functions back to work with actual parameter range - - prior.all <- do.call("rbind", prior.list) - prior.fn.all <- pda.define.prior.fn(prior.all) - - # retrieve rownames separately to get rid of var_name* structures - prior.all.rownames <- unlist(sapply(prior.list, rownames)) - - sc <- 1 - for (i in seq_along(prior.ind.all.ns)) { - sf.check <- prior.all.rownames[prior.ind.all.ns][i] - idx <- grep(sf.check, rownames(prior.all)[prior.ind.all]) - if(any(grepl(sf.check, sf))){ + if(!any(pos.check)){ + newSS <- get_ss(gp, xnew) + }else{ + repeat { + newSS <- get_ss(gp, xnew) + if (newSS[pos.check] > 0) { + break + } + } + } - m[, i] <- eval(prior.fn.all$qprior[prior.ind.all.ns][[i]], - list(p = mcmc.out[[c]]$mcmc.samp[, idx])) - if(sc <= length(sf)){ - sfm[, sc] <- mcmc.out[[c]]$mcmc.samp[, idx] - sc <- sc + 1 + newllp <- pda.calc.llik.par(settings, n.of.obs, newSS) + ynew <- get_y(newSS, xnew, llik.fn, priors, newllp) + if (is.accepted(ycurr, ynew)) { + xcurr <- xnew + currSS <- newSS } - }else{ - m[, i] <- mcmc.out[[c]]$mcmc.samp[, idx] + currllp <- pda.calc.llik.par(settings, n.of.obs, currSS) + pcurr <- unlist(sapply(currllp, `[[` , "par")) + + # } } } + samp[g, ] <- unlist(xcurr) + par[g, ] <- pcurr - colnames(m) <- prior.all.rownames[prior.ind.all.ns] - mcmc.samp.list[[c]] <- m - - if(!is.null(sf)){ - colnames(sfm) <- paste0(sf, "_SF") - sf.samp.list[[c]] <- sfm - } - - resume.list[[c]] <- mcmc.out[[c]]$chain.res - } - - - - if (FALSE) { - gp = gp - x0 = init.list[[chain]] - nmcmc = settings$assim.batch$iter - rng = rng - format = "lin" - mix = mix - jmp0 = jmp.list[[chain]] - ar.target = settings$assim.batch$jump$ar.target - priors = prior.fn.all$dprior[prior.ind.all] - settings = settings - run.block = (run.normal | run.round) - n.of.obs = n.of.obs - llik.fn = llik.fn - resume.list = resume.list[[chain]] + if(g %% 1000 == 0) PEcAn.logger::logger.info(g, "of", nmcmc, "iterations") + # print(p(jmp)) jmp <- update(jmp,samp) } - ## ------------------------------------ Clean up ------------------------------------ - current.step <- "clean up" - save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) - ## Save emulator, outputs files - settings$assim.batch$emulator.path <- file.path(settings$outdir, - paste0("emulator.pda", - settings$assim.batch$ensemble.id, - ".Rdata")) - save(gp, file = settings$assim.batch$emulator.path) + chain.res <- list(jump = jcov, ac = accept.count, prev.samp = samp, par = par, n.of.obs = n.of.obs) - settings$assim.batch$ss.path <- file.path(settings$outdir, - paste0("ss.pda", - settings$assim.batch$ensemble.id, - ".Rdata")) - save(SS, file = settings$assim.batch$ss.path) + return(list(mcmc.samp = samp, mcmc.par = par, chain.res = chain.res)) + ## xnew <- gpeval,x0,k=k,mu=ey,tau=tauwbar,psi=psibar,x=gp$x.compact,rng=rng) - settings$assim.batch$mcmc.path <- file.path(settings$outdir, - paste0("mcmc.list.pda", - settings$assim.batch$ensemble.id, - ".Rdata")) - save(mcmc.samp.list, file = settings$assim.batch$mcmc.path) - - settings$assim.batch$resume.path <- file.path(settings$outdir, - paste0("resume.pda", - settings$assim.batch$ensemble.id, - ".Rdata")) - save(resume.list, file = settings$assim.batch$resume.path) - - # save prior.list with bias term - if(any(unlist(any.mgauss) == "multipGauss")){ - settings$assim.batch$bias.path <- file.path(settings$outdir, - paste0("bias.pda", - settings$assim.batch$ensemble.id, - ".Rdata")) - save(prior.list, file = settings$assim.batch$bias.path) - } + ################### IN PROGRESS ############## +} # mcmc.GP - # save sf posterior - if(!is.null(sf)){ - sf.filename <- file.path(settings$outdir, - paste0("post.distns.pda.sf", "_", settings$assim.batch$ensemble.id, ".Rdata")) - sf.prior <- prior.list[[sf.ind]] - sf.post.distns <- write_sf_posterior(sf.samp.list, sf.prior, sf.filename) - save(sf.post.distns, file = sf.filename) - settings$assim.batch$sf.path <- sf.filename - } - - # Separate each PFT's parameter samples (and bias term) to their own list - mcmc.param.list <- list() - ind <- 0 - for (i in seq_along(n.param.orig)) { - mcmc.param.list[[i]] <- lapply(mcmc.samp.list, function(x) x[, (ind + 1):(ind + n.param.orig[i]), drop = FALSE]) - ind <- ind + n.param.orig[i] - } - - # Collect non-model parameters in their own list - if(length(mcmc.param.list) > length(settings$pfts)) { - # means bias parameter was at least one bias param in the emulator - # it will be the last list in mcmc.param.list - # there will always be at least one tau for bias - for(c in seq_len(settings$assim.batch$chain)){ - mcmc.param.list[[length(mcmc.param.list)]][[c]] <- cbind( mcmc.param.list[[length(mcmc.param.list)]][[c]], - mcmc.out[[c]]$mcmc.par) - } - } else if (ncol(mcmc.out[[1]]$mcmc.par) != 0){ - # means no bias param but there are still other params, e.g. Gaussian - mcmc.param.list[[length(mcmc.param.list)+1]] <- list() - for(c in seq_len(settings$assim.batch$chain)){ - mcmc.param.list[[length(mcmc.param.list)]][[c]] <- mcmc.out[[c]]$mcmc.par - } - } - - settings <- pda.postprocess(settings, con, mcmc.param.list, pname, prior.list, prior.ind.orig) - - ## close database connection - if (!is.null(con)) { - db.close(con) - } - - ## Output an updated settings list - current.step <- "pda.finish" - save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) - return(settings) - -} ## end pda.emulator +##' @name bounded +##' @title bounded +##' @export +bounded <- function(xnew, rng) { + xnew <- as.vector(as.matrix(xnew)) + down <- xnew > rng[, 1] + up <- xnew < rng[, 2] + return(all(up & down)) +} # bounded + + +##' @name plot.mvjump +##' @title plot.mvjump +##' @export +##' +##' @param jmp +##' +##' @author Michael Dietze +plot.mvjump <- function(jmp) { + par(mfrow = c(1, 2)) + plot(attr(jmp, "history")[, 1], ylab = "Jump Parameter", main = "Jump Parameter") + abline(h = mean(attr(jmp, "history")[, 1], na.rm = TRUE)) + text(0.9 * length(attr(jmp, "history")[, 1]), + min(attr(jmp, "history")[, 1]) + 0.8 * + (max(attr(jmp, "history")[, 1]) - min(attr(jmp, "history")[, 1])), + paste("mean=", mean(attr(jmp, "history")[, 1]))) + plot(attr(jmp, "arate"), ylab = "Acceptance Rate", + main = "Acceptance Rate", + ylim = c(0, 1)) + abline(h = attr(jmp, "target")) + abline(h = mean(attr(jmp, "arate"), na.rm = TRUE), col = 2) +} # plot.mvjump From f4cb160295da511f4fabe0df29df5e39600192d7 Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 26 Sep 2017 13:57:24 -0400 Subject: [PATCH 737/771] roxygenize --- modules/assim.batch/NAMESPACE | 11 ++++++++- modules/assim.batch/man/pda.emulator.Rd | 30 ------------------------- 2 files changed, 10 insertions(+), 31 deletions(-) delete mode 100644 modules/assim.batch/man/pda.emulator.Rd diff --git a/modules/assim.batch/NAMESPACE b/modules/assim.batch/NAMESPACE index 908747a217c..40d09fe63da 100644 --- a/modules/assim.batch/NAMESPACE +++ b/modules/assim.batch/NAMESPACE @@ -2,13 +2,22 @@ export(assim.batch) export(autoburnin) +export(bounded) +export(calculate.prior) export(correlationPlot) +export(ddist) export(gelman_diag_gelmanPlot) export(gelman_diag_mw) export(getBurnin) +export(get_ss) +export(get_y) +export(gpeval) +export(is.accepted) export(load.L2Ameriflux.cf) export(load.pda.data) export(makeMCMCList) +export(mcmc.GP) +export(minimize.GP) export(pda.adjust.jumps) export(pda.adjust.jumps.bs) export(pda.autocorr.calc) @@ -20,7 +29,6 @@ export(pda.create.btprior) export(pda.create.ensemble) export(pda.define.llik.fn) export(pda.define.prior.fn) -export(pda.emulator) export(pda.generate.knots) export(pda.generate.sf) export(pda.get.model.output) @@ -35,6 +43,7 @@ export(pda.plot.params) export(pda.postprocess) export(pda.settings) export(pda.settings.bt) +export(plot.mvjump) export(return.bias) export(runModule.assim.batch) export(write_sf_posterior) diff --git a/modules/assim.batch/man/pda.emulator.Rd b/modules/assim.batch/man/pda.emulator.Rd deleted file mode 100644 index 178e8545504..00000000000 --- a/modules/assim.batch/man/pda.emulator.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pda.emulator.R -\name{pda.emulator} -\alias{pda.emulator} -\title{Paramater Data Assimilation using emulator} -\usage{ -pda.emulator(settings, external.data = NULL, external.priors = NULL, - params.id = NULL, param.names = NULL, prior.id = NULL, chain = NULL, - iter = NULL, adapt = NULL, adj.min = NULL, ar.target = NULL, - jvar = NULL, n.knot = NULL) -} -\arguments{ -\item{settings}{= a pecan settings list} - -\item{external.data}{= list of inputs} - -\item{external.priors}{= list or priors} -} -\value{ -nothing. Diagnostic plots, MCMC samples, and posterior distributions - are saved as files and db records. -} -\description{ -Paramater Data Assimilation using emulator -} -\author{ -Mike Dietze - -Ryan Kelly, Istem Fer -} From a8319b3b25c45e7d4f06163a6b095f0e0c450624 Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 26 Sep 2017 14:03:23 -0400 Subject: [PATCH 738/771] messed up scripts --- modules/assim.batch/NAMESPACE | 11 +- modules/assim.batch/R/pda.emulator.R | 986 +++++++++++++++--------- modules/assim.batch/man/pda.emulator.Rd | 30 + modules/emulator/NAMESPACE | 4 +- modules/emulator/R/minimize.GP.R | 69 +- modules/emulator/man/plot.jump.Rd | 2 +- modules/emulator/man/plot.mvjump.Rd | 2 +- modules/emulator/man/summarize.GP.Rd | 2 +- 8 files changed, 719 insertions(+), 387 deletions(-) create mode 100644 modules/assim.batch/man/pda.emulator.Rd diff --git a/modules/assim.batch/NAMESPACE b/modules/assim.batch/NAMESPACE index 40d09fe63da..908747a217c 100644 --- a/modules/assim.batch/NAMESPACE +++ b/modules/assim.batch/NAMESPACE @@ -2,22 +2,13 @@ export(assim.batch) export(autoburnin) -export(bounded) -export(calculate.prior) export(correlationPlot) -export(ddist) export(gelman_diag_gelmanPlot) export(gelman_diag_mw) export(getBurnin) -export(get_ss) -export(get_y) -export(gpeval) -export(is.accepted) export(load.L2Ameriflux.cf) export(load.pda.data) export(makeMCMCList) -export(mcmc.GP) -export(minimize.GP) export(pda.adjust.jumps) export(pda.adjust.jumps.bs) export(pda.autocorr.calc) @@ -29,6 +20,7 @@ export(pda.create.btprior) export(pda.create.ensemble) export(pda.define.llik.fn) export(pda.define.prior.fn) +export(pda.emulator) export(pda.generate.knots) export(pda.generate.sf) export(pda.get.model.output) @@ -43,7 +35,6 @@ export(pda.plot.params) export(pda.postprocess) export(pda.settings) export(pda.settings.bt) -export(plot.mvjump) export(return.bias) export(runModule.assim.batch) export(write_sf_posterior) diff --git a/modules/assim.batch/R/pda.emulator.R b/modules/assim.batch/R/pda.emulator.R index c60583727ad..d46525b255b 100644 --- a/modules/assim.batch/R/pda.emulator.R +++ b/modules/assim.batch/R/pda.emulator.R @@ -1,399 +1,685 @@ -##' @name minimize.GP -##' @title minimize.GP -##' @export +##' Paramater Data Assimilation using emulator ##' -##' @param gp -##' @param rng -##' @param x0 -##' @param splinefuns -##' -##' @author Michael Dietze -minimize.GP <- function(gp, rng, x0, splinefuns = NULL) { - - isotropic <- gp$isotropic - x.id <- gp$x.id - ey <- 0 - - if (gp$method == "bayes") { - samp <- gp$samp - tauw <- coda::mcmc(gp$tauw[samp, ]) - psi <- coda::mcmc(gp$psi[samp, ]) - mu <- coda::mcmc(gp$mu) - tauv <- W <- NULL - } else { - ## MLE - psi <- gp$psi - mu <- gp$mu - tauw <- gp$tauw - tauv <- gp$tauv - } - - psibar <- NULL - if (isotropic) { - psibar <- median(psi) - } else { - if (is.matrix(psi)) { - psibar <- apply(psi, 2, median) - } else { - psibar <- psi - } - } - tauwbar <- median(tauw) - S <- calcSpatialCov(gp$d, psibar, tauwbar) - # S12 <- Sprime[1:(npred*dim),(npred*dim+1):(n.unique+npred*dim)] S22 <- - # Sprime[(npred*dim+1):(n.unique+npred*dim),(npred*dim+1):(n.unique+npred*dim)] - S22inv <- solve(S) - if (gp$zeroMean) { - ey <- 0 - } else { - ey <- max(mu) #mean(y) - } - ybar <- tapply(gp$y, gp$x.id, mean) - k <- S22inv %*% (ybar - ey) - - nlm(gpeval, x0, k = k, mu = ey, tau = tauwbar, psi = psibar, - x = gp$x.compact, rng = rng, splinefcns = splinefcns) -} # minimize.GP - - -##' Calculates the probability of a set of parameter values, given by xnew +##' @title Paramater Data Assimilation using emulator +##' @param settings = a pecan settings list +##' @param external.data = list of inputs +##' @param external.priors = list or priors ##' -##' @name gpeval -##' @title gpeval -##' @export +##' @return nothing. Diagnostic plots, MCMC samples, and posterior distributions +##' are saved as files and db records. ##' -##' @param xnew -##' @param k -##' @param mu -##' @param tau -##' @param psi -##' @param x -##' @param rng range -##' @param splinefcns -##' -##' @author Michael Dietze -gpeval <- function(xnew, k, mu, tau, psi, x, rng, splinefcns) { - - ## second calc value - S12 <- sapply(seq_along(k), function(i) { - tau * exp(-sum(psi * (xnew - x[i, ]) ^ 2)) - }) - yprime <- mu + sum(S12 * k) - - if (!is.null(splinefcns)) { - ## add trend surface back on - y0 <- splinefuns[[length(xnew) + 1]] - f <- sapply(seq_along(xnew), function(j) { - splinefuns[[j]](xnew[j]) - }) - y.trend <- y0 + sum(f - y0) - yprime <- yprime + ytrend - } - - return(yprime) -} # gpeval - - -##' @name ddist -##' @title ddist -##' @export -ddist <- function(x, prior) { - eval(parse(text = paste("d", prior$distn, sep = "")))(x, prior$parama, prior$paramb) -} # ddist - - -# calculate.prior <- function(samples, priors){ traits <- names(samples) joint <- -# sum(sapply(1:nrow(priors), function(i) -log(ddist(samples[[i]], priors[i,])))) #note: -# this is within the negative log domain return(joint) } - -##' @name calculate.prior -##' @title calculate.prior +##' @author Mike Dietze +##' @author Ryan Kelly, Istem Fer ##' @export -calculate.prior <- function(samples, priors) { - sum(sapply(seq_along(priors), function(i) eval(priors[[i]], list(x = samples[[i]])))) -} # calculate.prior - -##' @name get_ss -##' @title get_ss -##' @export -get_ss <- function(gp, xnew) { +pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, + params.id = NULL, param.names = NULL, prior.id = NULL, + chain = NULL, iter = NULL, adapt = NULL, adj.min = NULL, + ar.target = NULL, jvar = NULL, n.knot = NULL) { - SS <- numeric(length(gp)) + ## this bit of code is useful for defining the variables passed to this function if you are + ## debugging + if (FALSE) { + external.data <- external.priors <- NULL + params.id <- param.names <- prior.id <- chain <- iter <- NULL + n.knot <- adapt <- adj.min <- ar.target <- jvar <- NULL + } - X <- matrix(unlist(xnew), nrow = 1, byrow = TRUE) + # handle extention flags + # is this an extension run + extension.check <- is.null(settings$assim.batch$extension) - for(igp in seq_along(gp)){ - Y <- mlegp::predict.gp(gp[[igp]], newData = X[, 1:ncol(gp[[igp]]$X), drop=FALSE], se.fit = TRUE) - SS[igp] <- rnorm(1, Y$fit, Y$se.fit) + if (extension.check) { + # not an extension run + run.normal <- TRUE + run.round <- FALSE + run.longer <- FALSE + } else if (!extension.check & settings$assim.batch$extension == "round") { + # 'round' extension + run.normal <- FALSE + run.round <- TRUE + run.longer <- FALSE + } else if (!extension.check & settings$assim.batch$extension == "longer") { + # 'longer' extension + run.normal <- FALSE + run.round <- FALSE + run.longer <- TRUE } - return(SS) -} # get_ss - -##' @name get_y -##' @title get_y -##' @export -get_y <- function(SSnew, xnew, llik.fn, priors, llik.par) { + ## -------------------------------------- Setup ------------------------------------- + ## Handle settings + settings <- pda.settings( + settings=settings, params.id=params.id, param.names=param.names, + prior.id=prior.id, chain=chain, iter=iter, adapt=adapt, + adj.min=adj.min, ar.target=ar.target, jvar=jvar, n.knot=n.knot, run.round) - likelihood <- pda.calc.llik(SSnew, llik.fn, llik.par) + ## history restart + pda.restart.file <- file.path(settings$outdir,paste0("history.pda", + settings$assim.batch$ensemble.id, ".Rdata")) + current.step <- "START" - prior.prob <- calculate.prior(xnew, priors) - posterior.prob <- likelihood + prior.prob + ## will be used to check if multiplicative Gaussian is requested + any.mgauss <- sapply(settings$assim.batch$inputs, `[[`, "likelihood") + isbias <- which(unlist(any.mgauss) == "multipGauss") - return(posterior.prob) + ## check if scaling factors are gonna be used + any.scaling <- sapply(settings$assim.batch$param.names, `[[`, "scaling") + sf <- unique(unlist(any.scaling)) -} # get_y - -# is.accepted <- function(ycurr, ynew, format='lin'){ z <- exp(ycurr-ynew) acceptance <- -# z>runif(1) return(acceptance) } - -##' @name is.accepted -##' @title is.accepted -##' @export -is.accepted <- function(ycurr, ynew, format = "lin") { - a <- exp(ynew - ycurr) - a > runif(1) -} # is.accepted - -##' Function to sample from a GP model -##' that is assumed to be a -lnLikelihood surface -##' with flat priors and bounded region -##' -##' @name mcmc.GP -##' @title mcmc.GP -##' @export -##' -##' @param gp -##' @param x0 -##' @param nmcmc -##' @param rng -##' @param format lin = lnlike fcn, log = log(lnlike) -##' @param mix each = jump each dim. independently, joint = jump all at once -##' @param splinefcns -##' @param jmp0 -##' @param ar.target -##' @param priors -##' -##' @author Michael Dietze -mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcns = NULL, - jmp0 = 0.35 * (rng[, 2] - rng[, 1]), ar.target = 0.5, priors = NA, settings, - run.block = TRUE, n.of.obs, llik.fn, resume.list = NULL) { - - pos.check <- sapply(settings$assim.batch$inputs, `[[`, "ss.positive") - - if(length(unlist(pos.check)) == 0){ - # if not passed from settings assume none - pos.check <- rep(FALSE, length(settings$assim.batch$inputs)) - }else if(length(unlist(pos.check)) != length(settings$assim.batch$inputs)){ - # maybe one provided, but others are forgotten - # check which ones are provided in settings - from.settings <- sapply(seq_along(pos.check), function(x) !is.null(pos.check[[x]])) - tmp.check <- rep(FALSE, length(settings$assim.batch$inputs)) - # replace those with the values provided in the settings - tmp.check[from.settings] <- unlist(pos.check) - pos.check <- tmp.check + ## Open database connection + if (settings$database$bety$write) { + 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 + } + + bety <- src_postgres(dbname = settings$database$bety$dbname, + host = settings$database$bety$host, + user = settings$database$bety$user, + password = settings$database$bety$password) + + ## Load priors + if(is.null(external.priors)){ + temp <- pda.load.priors(settings, bety$con, run.normal) + prior.list <- temp$prior + settings <- temp$settings }else{ - pos.check <- as.logical(pos.check) + prior.list <- external.priors } + pname <- lapply(prior.list, rownames) + n.param.all <- sapply(prior.list, nrow) + - # get SS - if(!any(pos.check)){ - currSS <- get_ss(gp, x0) + if(is.null(external.data)){ + inputs <- load.pda.data(settings, bety) }else{ - repeat { - currSS <- get_ss(gp, x0) - if (currSS[pos.check] > 0) { - break - } - } + inputs <- external.data } + n.input <- length(inputs) - currllp <- pda.calc.llik.par(settings, n.of.obs, currSS) - LLpar <- unlist(sapply(currllp, `[[` , "par")) - xcurr <- x0 - dim <- length(x0) - samp <- matrix(NA, nmcmc, dim) - par <- matrix(NA, nmcmc, length(LLpar), dimnames = list(NULL, names(LLpar))) # note: length(LLpar) can be 0 + ## Set model-specific functions + do.call("library", list(paste0("PEcAn.", settings$model$type))) + my.write.config <- paste("write.config.", settings$model$type, sep = "") + if (!exists(my.write.config)) { + PEcAn.logger::logger.severe(paste(my.write.config, + "does not exist. Please make sure that the PEcAn interface is loaded for", + settings$model$type)) + } + ## Select parameters to constrain + prior.ind <- lapply(seq_along(settings$pfts), + function(x) which(pname[[x]] %in% settings$assim.batch$param.names[[x]])) + n.param <- sapply(prior.ind, length) + prior.ind.orig <- lapply(seq_along(settings$pfts), + function(x) which(pname[[x]] %in% settings$assim.batch$param.names[[x]] | + pname[[x]] %in% any.scaling[[x]])) + n.param.orig <- sapply(prior.ind.orig, length) - if (run.block) { - jcov <- diag((jmp0)^2) - accept.count <- 0 - start <- 1 - # jmp <- mvjump(ic=jmp0,rate=ar.target, nc=dim) + ## Get the workflow id + if ("workflow" %in% names(settings)) { + workflow.id <- settings$workflow$id } else { - jcov <- jmp0 - accept.count <- resume.list$ac - prev.samp <- resume.list$prev.samp - prev.par <- resume.list$par - colnames(prev.samp) <- names(x0) - samp <- rbind(prev.samp, samp) - par <- rbind(prev.par, par) - start <- dim(prev.samp)[1] + 1 - nmcmc <- dim(samp)[1] - # jmp <- mvjump(ic=diag(jmp0),rate=ar.target, nc=dim) + workflow.id <- -1 } + ## Create an ensemble id + settings$assim.batch$ensemble.id <- pda.create.ensemble(settings, con, workflow.id) + + + ## Set up likelihood functions + llik.fn <- pda.define.llik.fn(settings) + + ## ------------------------------------ Emulator ------------------------------------ + # if we are going to throw scaling factor(s) instead of parameters + # 1. append scaling factor priors to prior.list + # 2. use the same probs for all pft params to be scaled + if(!is.null(sf)){ + sf.ind <- length(prior.list) + 1 + sf.list <- pda.generate.sf(settings$assim.batch$n.knot, sf, prior.list) + probs.sf <- sf.list$probs + prior.list <- sf.list$priors + }else { + probs.sf <- NULL + } - for (g in start:nmcmc) { + ## Set prior distribution functions (d___, q___, r___, and multivariate versions) + prior.fn <- lapply(prior.list, pda.define.prior.fn) + + + ## Propose parameter knots (X) for emulator design + knots.list <- lapply(seq_along(settings$pfts), + function(x) pda.generate.knots(settings$assim.batch$n.knot, sf, probs.sf, + n.param.all[x], + prior.ind.orig[[x]], + prior.fn[[x]], + pname[[x]])) + names(knots.list) <- sapply(settings$pfts,"[[",'name') + + knots.params <- lapply(knots.list, `[[`, "params") + knots.probs <- lapply(knots.list, `[[`, "probs") + + current.step <- "GENERATE KNOTS" + save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) + + ## Run this block if this is a "round" extension + if (run.round) { - if (mix == "joint") { - - # adapt - if ((g > 2) && ((g - 1) %% settings$assim.batch$jump$adapt == 0)) { - params.recent <- samp[(g - settings$assim.batch$jump$adapt):(g - 1), ] - colnames(params.recent) <- names(x0) - # accept.count <- round(jmp@arate[(g-1)/settings$assim.batch$jump$adapt]*100) - jcov <- pda.adjust.jumps.bs(settings, jcov, accept.count, params.recent) - accept.count <- 0 # Reset counter - } - - ## propose new parameters - repeat { - xnew <- mvrnorm(1, unlist(xcurr), jcov) - if (bounded(xnew, rng)) { - break - } + # loads the posteriors of the the previous emulator run + temp.round <- pda.load.priors(settings, con, run.round) + prior.round.list <- temp.round$prior + + + prior.round.fn <- lapply(prior.round.list, pda.define.prior.fn) + + ## Propose a percentage (if not specified 80%) of the new parameter knots from the posterior of the previous run + knot.par <- ifelse(!is.null(settings$assim.batch$knot.par), + as.numeric(settings$assim.batch$knot.par), + 0.8) + + n.post.knots <- floor(knot.par * settings$assim.batch$n.knot) + + if(!is.null(sf)){ + load(settings$assim.batch$sf.path) + sf.round.post <- pda.define.prior.fn(sf.post.distns) + rm(sf.post.distns) + n.sf <- length(sf) + sf.round.list <- pda.generate.knots(n.post.knots, + sf = NULL, probs.sf = NULL, + n.param.all = n.sf, + prior.ind = seq_len(n.sf), + prior.fn = sf.round.post, + pname = paste0(sf, "_SF")) + probs.round.sf <- sf.round.list$params + }else { + probs.round.sf <- NULL + } + + ## set prior distribution functions for posterior of the previous emulator run + knots.list.temp <- lapply(seq_along(settings$pfts), + function(x) pda.generate.knots(n.post.knots, + sf, probs.round.sf, + n.param.all[x], + prior.ind.orig[[x]], + prior.round.fn[[x]], + pname[[x]])) + knots.params.temp <- lapply(knots.list.temp, `[[`, "params") + + + for (i in seq_along(settings$pfts)) { + # mixture of knots + mix.knots <- sample(nrow(knots.params[[i]]), (settings$assim.batch$n.knot - n.post.knots)) + knots.list[[i]]$params <- rbind(knots.params[[i]][mix.knots, ], + knots.list.temp[[i]]$params) + names(knots.list)[i] <- settings$pfts[[i]]['name'] + } + + knots.params <- lapply(knots.list, `[[`, "params") + knots.probs <- lapply(knots.list, `[[`, "probs") + + current.step <- "Generate Knots: round-if block" + save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) + } # end round-if block + + + ## Run this block if this is normal run or a "round" extension + if(run.normal | run.round){ + + ## Set up runs and write run configs for all proposed knots + run.ids <- pda.init.run(settings, con, my.write.config, workflow.id, knots.params, + n = settings$assim.batch$n.knot, + run.names = paste0(settings$assim.batch$ensemble.id, ".knot.", + 1:settings$assim.batch$n.knot)) + current.step <- "pda.init.run" + save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) + + ## start model runs + PEcAn.remote::start.model.runs(settings, settings$database$bety$write) + + ## Retrieve model outputs and error statistics + model.out <- list() + pda.errors <- list() + + + ## read model outputs + for (i in seq_len(settings$assim.batch$n.knot)) { + align.return <- pda.get.model.output(settings, run.ids[i], bety, inputs) + model.out[[i]] <- align.return$model.out + if(all(!is.na(model.out[[i]]))){ + inputs <- align.return$inputs } - # if(bounded(xnew,rng)){ - - # re-predict SS - if(!any(pos.check)){ - currSS <- get_ss(gp, xcurr) - }else{ - repeat { - currSS <- get_ss(gp, xcurr) - if (currSS[pos.check] > 0) { - break - } - } + } + + + current.step <- "pda.get.model.output" + save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) + + # efficient sample size calculation + inputs <- pda.neff.calc(inputs) + + # handle bias parameters if multiplicative Gaussian is listed in the likelihoods + if(any(unlist(any.mgauss) == "multipGauss")) { + # how many bias parameters per dataset requested + nbias <- ifelse(is.null(settings$assim.batch$inputs[[isbias]]$nbias), 1, + as.numeric(settings$assim.batch$inputs[[isbias]]$nbias)) + bias.list <- return.bias(isbias, model.out, inputs, prior.list, nbias, run.round, settings$assim.batch$bias.path) + bias.terms <- bias.list$bias.params + prior.list <- bias.list$prior.list.bias + prior.fn <- lapply(prior.list, pda.define.prior.fn) + } else { + bias.terms <- NULL + } + + for (i in seq_len(settings$assim.batch$n.knot)) { + if(!is.null(bias.terms)){ + all.bias <- lapply(bias.terms, function(n) n[i,]) + all.bias <- do.call("rbind", all.bias) + } else { + all.bias <- NULL } + ## calculate error statistics and save in the DB + pda.errors[[i]] <- pda.calc.error(settings, con, model_out = model.out[[i]], run.id = run.ids[i], inputs, bias.terms = all.bias) + } + + } # end if-block + current.step <- "pda.calc.error" + save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) + + init.list <- list() + jmp.list <- list() + + prior.all <- do.call("rbind", prior.list) + length.pars <- 0 + prior.ind.list <- prior.ind.list.ns <- list() + # now I need to go through all parameters for each pft, but leave out the ones that scaling factor is requested + for(p in seq_along(settings$assim.batch$param.names)){ + param.names <- settings$assim.batch$param.names[[p]] + prior.ind.list[[p]] <- length.pars + which(pname[[p]] %in% unlist(param.names) & + !(pname[[p]] %in% sf)) + prior.ind.list.ns[[p]] <- length.pars + which(pname[[p]] %in% unlist(param.names)) + length.pars <- length.pars + length(pname[[p]]) + } + prior.ind.all <- unlist(prior.ind.list) + prior.ind.all.ns <- unlist(prior.ind.list.ns) + # if no scaling is requested prior.ind.all == prior.ind.all.ns + # keep this ind.all w/o bias until extracting prob values below + + if (run.normal | run.round) { + + # retrieve n + n.of.obs <- sapply(inputs,`[[`, "n") + names(n.of.obs) <- sapply(model.out[[1]],names) + + + # UPDATE: Use mlegp package, I can now draw from parameter space + knots.params.all <- do.call("cbind", knots.params) + X <- knots.params.all[, prior.ind.all, drop = FALSE] + + if(!is.null(sf)){ + X <- cbind(X, probs.sf) + } + + # retrieve SS + error.statistics <- list() + SS.list <- list() + bc <- 1 + + # what percentage of runs is allowed to fail? + if(!is.null(settings$assim.batch$allow.fail)){ + allow.fail <- as.numeric(settings$assim.batch$allow.fail) + } else { + allow.fail <- 0.5 + } + # what is it in number of runs? + no.of.allowed <- floor(settings$assim.batch$n.knot * allow.fail) + + for(inputi in seq_len(n.input)){ + error.statistics[[inputi]] <- sapply(pda.errors,`[[`, inputi) + if(unlist(any.mgauss)[inputi] == "multipGauss") { + + # if yes, then we need to include bias term in the emulator + #bias.probs <- bias.list$bias.probs + #biases <- c(t(bias.probs[[bc]])) + bias.params <- bias.list$bias.params + biases <- c(t(bias.params[[bc]])) + bc <- bc + 1 + + # replicate model parameter set per bias parameter + rep.rows <- rep(1:nrow(X), each = nbias) + X.rep <- X[rep.rows,] + Xnew <- cbind(X.rep, biases) + colnames(Xnew) <- c(colnames(X.rep), paste0("bias.", names(n.of.obs)[inputi])) + SS.list[[inputi]] <- cbind(Xnew, c(error.statistics[[inputi]])) + + } else { + SS.list[[inputi]] <- cbind(X, error.statistics[[inputi]]) + } # if-block - # don't update the currllp ( = llik.par, e.g. tau) yet - # calculate posterior with xcurr | currllp - ycurr <- get_y(currSS, xcurr, llik.fn, priors, currllp) + # check failed runs and remove them if you'll have a reasonable amount of param sets after removal + # how many runs failed? + no.of.failed <- sum(is.na(SS.list[[inputi]][, ncol(SS.list[[inputi]])])) - if(!any(pos.check)){ - newSS <- get_ss(gp, xnew) - }else{ - repeat { - newSS <- get_ss(gp, xnew) - if (newSS[pos.check] > 0) { - break - } - } + # check if you're left with enough sets + if(no.of.failed < no.of.allowed & (settings$assim.batch$n.knot - no.of.failed) > 1){ + SS.list[[inputi]] <- SS.list[[inputi]][!rowSums(is.na(SS.list[[inputi]])), ] + if( no.of.failed > 0){ + PEcAn.logger::logger.info(paste0(no.of.failed, " runs failed. Emulator for ", names(n.of.obs)[inputi], " will be built with ", settings$assim.batch$n.knot - no.of.failed, " knots.")) + } + } else{ + PEcAn.logger::logger.error(paste0("Too many runs failed, not enough parameter set to build emulator for ", names(n.of.obs)[inputi], ".")) } + } # for-loop + + if (run.round) { + # check if this is another 'round' of emulator - newllp <- pda.calc.llik.par(settings, n.of.obs, newSS) - ynew <- get_y(newSS, xnew, llik.fn, priors, newllp) - - if (is.accepted(ycurr, ynew)) { - xcurr <- xnew - currSS <- newSS - accept.count <- accept.count + 1 - } + # load original knots + load(settings$assim.batch$ss.path) + # add on + SS <- lapply(seq_along(SS), function(iss) rbind(SS.list[[iss]], SS[[iss]])) - # now update currllp | xcurr - currllp <- pda.calc.llik.par(settings, n.of.obs, currSS) - pcurr <- unlist(sapply(currllp, `[[` , "par")) - # } mix = each } else { - for (i in seq_len(dim)) { - ## propose new - repeat { - xnew[i] <- rnorm(1, xcurr[[i]], p(jmp)[i]) - if (bounded(xnew[i], rng[i, , drop = FALSE])) { - break - } - } - # if(bounded(xnew,rng)){ - if(!any(pos.check)){ - currSS <- get_ss(gp, xcurr) - }else{ - repeat { - currSS <- get_ss(gp, xcurr) - if (currSS[pos.check] > 0) { - break - } - } - } - - ycurr <- get_y(currSS, xcurr, llik.fn, priors, currllp) - - if(!any(pos.check)){ - newSS <- get_ss(gp, xnew) - }else{ - repeat { - newSS <- get_ss(gp, xnew) - if (newSS[pos.check] > 0) { - break - } - } - } + SS <- SS.list + } + + PEcAn.logger::logger.info(paste0("Using 'mlegp' package for Gaussian Process Model fitting.")) + + ## Generate emulator on SS, return a list ## + + # start the clock + ptm.start <- proc.time() + + # prepare for parallelization + dcores <- parallel::detectCores() - 1 + ncores <- min(max(dcores, 1), length(SS)) + + cl <- parallel::makeCluster(ncores, type="FORK") + + ## Parallel fit for GPs + GPmodel <- parallel::parLapply(cl, SS, function(x) mlegp::mlegp(X = x[, -ncol(x), drop = FALSE], Z = x[, ncol(x), drop = FALSE], verbose = 0)) + # GPmodel <- lapply(SS, function(x) mlegp::mlegp(X = x[, -ncol(x), drop = FALSE], Z = x[, ncol(x), drop = FALSE], verbose = 0)) + + parallel::stopCluster(cl) + + # Stop the clock + ptm.finish <- proc.time() - ptm.start + PEcAn.logger::logger.info(paste0("GP fitting took ", paste0(round(ptm.finish[3])), " seconds.")) + + + gp <- GPmodel + + } else { # is this a "longer" type of extension run + + load(settings$assim.batch$emulator.path) # load previously built emulator(s) to run a longer mcmc + load(settings$assim.batch$ss.path) + load(settings$assim.batch$resume.path) + + n.of.obs <- resume.list[[1]]$n.of.obs + + if(any(unlist(any.mgauss) == "multipGauss")){ + load(settings$assim.batch$bias.path) # load prior.list with bias term from previous run + prior.all <- do.call("rbind", prior.list) + } + + + for (c in seq_len(settings$assim.batch$chain)) { + init.list[[c]] <- resume.list[[c]]$prev.samp[nrow(resume.list[[c]]$prev.samp), ] + jmp.list[[c]] <- resume.list[[c]]$jump + } + } + + # add indice and increase n.param for scaling factor + if(!is.null(sf)){ + prior.ind.all <- c(prior.ind.all, + ((length.pars + 1): (length.pars + length(sf)))) + n.param <- c(n.param, length(sf)) + length.pars <- length.pars + length(sf) + } + + # add indice and increase n.param for bias + if(any(unlist(any.mgauss) == "multipGauss")){ + prior.ind.all <- c(prior.ind.all, + ((length.pars + 1) : (length.pars + length(isbias)))) + prior.ind.all.ns <- c(prior.ind.all.ns, + ((length.pars + 1) : (length.pars + length(isbias)))) + n.param <- c(n.param, length(isbias)) + n.param.orig <- c(n.param.orig, length(isbias)) + length.pars <- length.pars + length(isbias) + } + + + ## Set up prior functions accordingly + prior.fn.all <- pda.define.prior.fn(prior.all) + + # define range to make sure mcmc.GP doesn't propose new values outside + rng <- matrix(c(sapply(prior.fn.all$qprior[prior.ind.all], eval, list(p = 1e-05)), + sapply(prior.fn.all$qprior[prior.ind.all], eval, list(p = 0.99999))), + nrow = sum(n.param)) + + if (run.normal | run.round) { + + resume.list <- list() + + for (c in seq_len(settings$assim.batch$chain)) { + jmp.list[[c]] <- sapply(prior.fn.all$qprior, + function(x) 0.1 * diff(eval(x, list(p = c(0.05, 0.95)))))[prior.ind.all] + jmp.list[[c]] <- sqrt(jmp.list[[c]]) + + init.x <- lapply(prior.ind.all, function(v) eval(prior.fn.all$rprior[[v]], list(n = 1))) + names(init.x) <- rownames(prior.all)[prior.ind.all] + init.list[[c]] <- init.x + resume.list[[c]] <- NA + } + } + + if (!is.null(settings$assim.batch$mix)) { + mix <- settings$assim.batch$mix + } else if (sum(n.param) > 1) { + mix <- "joint" + } else { + mix <- "each" + } + + PEcAn.logger::logger.info(paste0("Starting emulator MCMC. Please wait.")) + + current.step <- "pre-MCMC" + save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) + + # start the clock + ptm.start <- proc.time() + + # prepare for parallelization + dcores <- parallel::detectCores() - 1 + ncores <- min(max(dcores, 1), settings$assim.batch$chain) + + PEcAn.logger::logger.setOutputFile(file.path(settings$outdir, "pda.log")) + + cl <- parallel::makeCluster(ncores, type="FORK", outfile = file.path(settings$outdir, "pda.log")) + + ## Sample posterior from emulator + mcmc.out <- parallel::parLapply(cl, 1:settings$assim.batch$chain, function(chain) { + mcmc.GP(gp = gp, ## Emulator(s) + x0 = init.list[[chain]], ## Initial conditions + nmcmc = settings$assim.batch$iter, ## Number of reps + rng = rng, ## range + format = "lin", ## "lin"ear vs "log" of LogLikelihood + mix = mix, ## Jump "each" dimension independently or update them "joint"ly + jmp0 = jmp.list[[chain]], ## Initial jump size + ar.target = settings$assim.batch$jump$ar.target, ## Target acceptance rate + priors = prior.fn.all$dprior[prior.ind.all], ## priors + settings = settings, + run.block = (run.normal | run.round), + n.of.obs = n.of.obs, + llik.fn = llik.fn, + resume.list = resume.list[[chain]] + ) + }) + + parallel::stopCluster(cl) + + # Stop the clock + ptm.finish <- proc.time() - ptm.start + PEcAn.logger::logger.info(paste0("Emulator MCMC took ", paste0(round(ptm.finish[3])), " seconds for ", paste0(settings$assim.batch$iter), " iterations.")) + + current.step <- "post-MCMC" + save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) + + mcmc.samp.list <- sf.samp.list <- list() + + for (c in seq_len(settings$assim.batch$chain)) { + + m <- matrix(NA, nrow = nrow(mcmc.out[[c]]$mcmc.samp), ncol = length(prior.ind.all.ns)) + + if(!is.null(sf)){ + sfm <- matrix(NA, nrow = nrow(mcmc.out[[c]]$mcmc.samp), ncol = length(sf)) + } + ## Set the prior functions back to work with actual parameter range + + prior.all <- do.call("rbind", prior.list) + prior.fn.all <- pda.define.prior.fn(prior.all) + + # retrieve rownames separately to get rid of var_name* structures + prior.all.rownames <- unlist(sapply(prior.list, rownames)) + + sc <- 1 + for (i in seq_along(prior.ind.all.ns)) { + sf.check <- prior.all.rownames[prior.ind.all.ns][i] + idx <- grep(sf.check, rownames(prior.all)[prior.ind.all]) + if(any(grepl(sf.check, sf))){ - newllp <- pda.calc.llik.par(settings, n.of.obs, newSS) - ynew <- get_y(newSS, xnew, llik.fn, priors, newllp) - if (is.accepted(ycurr, ynew)) { - xcurr <- xnew - currSS <- newSS + m[, i] <- eval(prior.fn.all$qprior[prior.ind.all.ns][[i]], + list(p = mcmc.out[[c]]$mcmc.samp[, idx])) + if(sc <= length(sf)){ + sfm[, sc] <- mcmc.out[[c]]$mcmc.samp[, idx] + sc <- sc + 1 } - currllp <- pda.calc.llik.par(settings, n.of.obs, currSS) - pcurr <- unlist(sapply(currllp, `[[` , "par")) - - # } + }else{ + m[, i] <- mcmc.out[[c]]$mcmc.samp[, idx] } } - samp[g, ] <- unlist(xcurr) - par[g, ] <- pcurr - if(g %% 1000 == 0) PEcAn.logger::logger.info(g, "of", nmcmc, "iterations") - # print(p(jmp)) jmp <- update(jmp,samp) + colnames(m) <- prior.all.rownames[prior.ind.all.ns] + mcmc.samp.list[[c]] <- m + + if(!is.null(sf)){ + colnames(sfm) <- paste0(sf, "_SF") + sf.samp.list[[c]] <- sfm + } + + resume.list[[c]] <- mcmc.out[[c]]$chain.res + } + + + + if (FALSE) { + gp = gp + x0 = init.list[[chain]] + nmcmc = settings$assim.batch$iter + rng = rng + format = "lin" + mix = mix + jmp0 = jmp.list[[chain]] + ar.target = settings$assim.batch$jump$ar.target + priors = prior.fn.all$dprior[prior.ind.all] + settings = settings + run.block = (run.normal | run.round) + n.of.obs = n.of.obs + llik.fn = llik.fn + resume.list = resume.list[[chain]] + } + + ## ------------------------------------ Clean up ------------------------------------ + current.step <- "clean up" + save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) + + ## Save emulator, outputs files + settings$assim.batch$emulator.path <- file.path(settings$outdir, + paste0("emulator.pda", + settings$assim.batch$ensemble.id, + ".Rdata")) + save(gp, file = settings$assim.batch$emulator.path) + + settings$assim.batch$ss.path <- file.path(settings$outdir, + paste0("ss.pda", + settings$assim.batch$ensemble.id, + ".Rdata")) + save(SS, file = settings$assim.batch$ss.path) + + settings$assim.batch$mcmc.path <- file.path(settings$outdir, + paste0("mcmc.list.pda", + settings$assim.batch$ensemble.id, + ".Rdata")) + save(mcmc.samp.list, file = settings$assim.batch$mcmc.path) + + settings$assim.batch$resume.path <- file.path(settings$outdir, + paste0("resume.pda", + settings$assim.batch$ensemble.id, + ".Rdata")) + save(resume.list, file = settings$assim.batch$resume.path) + + # save prior.list with bias term + if(any(unlist(any.mgauss) == "multipGauss")){ + settings$assim.batch$bias.path <- file.path(settings$outdir, + paste0("bias.pda", + settings$assim.batch$ensemble.id, + ".Rdata")) + save(prior.list, file = settings$assim.batch$bias.path) + } + + # save sf posterior + if(!is.null(sf)){ + sf.filename <- file.path(settings$outdir, + paste0("post.distns.pda.sf", "_", settings$assim.batch$ensemble.id, ".Rdata")) + sf.prior <- prior.list[[sf.ind]] + sf.post.distns <- write_sf_posterior(sf.samp.list, sf.prior, sf.filename) + save(sf.post.distns, file = sf.filename) + settings$assim.batch$sf.path <- sf.filename + } + + # Separate each PFT's parameter samples (and bias term) to their own list + mcmc.param.list <- list() + ind <- 0 + for (i in seq_along(n.param.orig)) { + mcmc.param.list[[i]] <- lapply(mcmc.samp.list, function(x) x[, (ind + 1):(ind + n.param.orig[i]), drop = FALSE]) + ind <- ind + n.param.orig[i] + } + + # Collect non-model parameters in their own list + if(length(mcmc.param.list) > length(settings$pfts)) { + # means bias parameter was at least one bias param in the emulator + # it will be the last list in mcmc.param.list + # there will always be at least one tau for bias + for(c in seq_len(settings$assim.batch$chain)){ + mcmc.param.list[[length(mcmc.param.list)]][[c]] <- cbind( mcmc.param.list[[length(mcmc.param.list)]][[c]], + mcmc.out[[c]]$mcmc.par) + } + + } else if (ncol(mcmc.out[[1]]$mcmc.par) != 0){ + # means no bias param but there are still other params, e.g. Gaussian + mcmc.param.list[[length(mcmc.param.list)+1]] <- list() + for(c in seq_len(settings$assim.batch$chain)){ + mcmc.param.list[[length(mcmc.param.list)]][[c]] <- mcmc.out[[c]]$mcmc.par + } } + settings <- pda.postprocess(settings, con, mcmc.param.list, pname, prior.list, prior.ind.orig) - chain.res <- list(jump = jcov, ac = accept.count, prev.samp = samp, par = par, n.of.obs = n.of.obs) + ## close database connection + if (!is.null(con)) { + db.close(con) + } - return(list(mcmc.samp = samp, mcmc.par = par, chain.res = chain.res)) - ## xnew <- gpeval,x0,k=k,mu=ey,tau=tauwbar,psi=psibar,x=gp$x.compact,rng=rng) + ## Output an updated settings list + current.step <- "pda.finish" + save(list = ls(all.names = TRUE),envir=environment(),file=pda.restart.file) + return(settings) - ################### IN PROGRESS ############## -} # mcmc.GP - - -##' @name bounded -##' @title bounded -##' @export -bounded <- function(xnew, rng) { - xnew <- as.vector(as.matrix(xnew)) - down <- xnew > rng[, 1] - up <- xnew < rng[, 2] - return(all(up & down)) -} # bounded - - -##' @name plot.mvjump -##' @title plot.mvjump -##' @export -##' -##' @param jmp -##' -##' @author Michael Dietze -plot.mvjump <- function(jmp) { - par(mfrow = c(1, 2)) - plot(attr(jmp, "history")[, 1], ylab = "Jump Parameter", main = "Jump Parameter") - abline(h = mean(attr(jmp, "history")[, 1], na.rm = TRUE)) - text(0.9 * length(attr(jmp, "history")[, 1]), - min(attr(jmp, "history")[, 1]) + 0.8 * - (max(attr(jmp, "history")[, 1]) - min(attr(jmp, "history")[, 1])), - paste("mean=", mean(attr(jmp, "history")[, 1]))) - plot(attr(jmp, "arate"), ylab = "Acceptance Rate", - main = "Acceptance Rate", - ylim = c(0, 1)) - abline(h = attr(jmp, "target")) - abline(h = mean(attr(jmp, "arate"), na.rm = TRUE), col = 2) -} # plot.mvjump +} ## end pda.emulator diff --git a/modules/assim.batch/man/pda.emulator.Rd b/modules/assim.batch/man/pda.emulator.Rd new file mode 100644 index 00000000000..178e8545504 --- /dev/null +++ b/modules/assim.batch/man/pda.emulator.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pda.emulator.R +\name{pda.emulator} +\alias{pda.emulator} +\title{Paramater Data Assimilation using emulator} +\usage{ +pda.emulator(settings, external.data = NULL, external.priors = NULL, + params.id = NULL, param.names = NULL, prior.id = NULL, chain = NULL, + iter = NULL, adapt = NULL, adj.min = NULL, ar.target = NULL, + jvar = NULL, n.knot = NULL) +} +\arguments{ +\item{settings}{= a pecan settings list} + +\item{external.data}{= list of inputs} + +\item{external.priors}{= list or priors} +} +\value{ +nothing. Diagnostic plots, MCMC samples, and posterior distributions + are saved as files and db records. +} +\description{ +Paramater Data Assimilation using emulator +} +\author{ +Mike Dietze + +Ryan Kelly, Istem Fer +} diff --git a/modules/emulator/NAMESPACE b/modules/emulator/NAMESPACE index 421d54566ae..e4c55f18d90 100644 --- a/modules/emulator/NAMESPACE +++ b/modules/emulator/NAMESPACE @@ -4,9 +4,9 @@ S3method(calcSpatialCov,list) S3method(calcSpatialCov,matrix) S3method(p,jump) S3method(p,mvjump) -S3method(plot,mvjump) S3method(predict,GP) S3method(predict,density) +S3method(summarize,GP) S3method(update,jump) S3method(update,mvjump) export(GaussProcess) @@ -34,4 +34,4 @@ export(mvjump) export(nderiv) export(p) export(plot.jump) -export(summarize.GP) +export(plot.mvjump) diff --git a/modules/emulator/R/minimize.GP.R b/modules/emulator/R/minimize.GP.R index 64b40917f83..c60583727ad 100644 --- a/modules/emulator/R/minimize.GP.R +++ b/modules/emulator/R/minimize.GP.R @@ -151,8 +151,8 @@ get_y <- function(SSnew, xnew, llik.fn, priors, llik.par) { ##' @title is.accepted ##' @export is.accepted <- function(ycurr, ynew, format = "lin") { - a <- exp(ynew - ycurr) - a > runif(1) + a <- exp(ynew - ycurr) + a > runif(1) } # is.accepted ##' Function to sample from a GP model @@ -197,16 +197,21 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn } # get SS - repeat { + if(!any(pos.check)){ currSS <- get_ss(gp, x0) - if (currSS[pos.check] > 0) { - break + }else{ + repeat { + currSS <- get_ss(gp, x0) + if (currSS[pos.check] > 0) { + break + } } } - + + currllp <- pda.calc.llik.par(settings, n.of.obs, currSS) LLpar <- unlist(sapply(currllp, `[[` , "par")) - + xcurr <- x0 dim <- length(x0) samp <- matrix(NA, nmcmc, dim) @@ -235,7 +240,7 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn for (g in start:nmcmc) { if (mix == "joint") { - + # adapt if ((g > 2) && ((g - 1) %% settings$assim.batch$jump$adapt == 0)) { params.recent <- samp[(g - settings$assim.batch$jump$adapt):(g - 1), ] @@ -255,27 +260,37 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn # if(bounded(xnew,rng)){ # re-predict SS - repeat { + if(!any(pos.check)){ currSS <- get_ss(gp, xcurr) - if (currSS[pos.check] > 0) { - break + }else{ + repeat { + currSS <- get_ss(gp, xcurr) + if (currSS[pos.check] > 0) { + break + } } } + # don't update the currllp ( = llik.par, e.g. tau) yet # calculate posterior with xcurr | currllp ycurr <- get_y(currSS, xcurr, llik.fn, priors, currllp) - - repeat { + + if(!any(pos.check)){ newSS <- get_ss(gp, xnew) - if (newSS[pos.check] > 0) { - break + }else{ + repeat { + newSS <- get_ss(gp, xnew) + if (newSS[pos.check] > 0) { + break + } } } + newllp <- pda.calc.llik.par(settings, n.of.obs, newSS) ynew <- get_y(newSS, xnew, llik.fn, priors, newllp) - + if (is.accepted(ycurr, ynew)) { xcurr <- xnew currSS <- newSS @@ -296,20 +311,30 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn } } # if(bounded(xnew,rng)){ - repeat { + if(!any(pos.check)){ currSS <- get_ss(gp, xcurr) - if (currSS[pos.check] > 0) { - break + }else{ + repeat { + currSS <- get_ss(gp, xcurr) + if (currSS[pos.check] > 0) { + break + } } } + ycurr <- get_y(currSS, xcurr, llik.fn, priors, currllp) - repeat { + if(!any(pos.check)){ newSS <- get_ss(gp, xnew) - if (newSS[pos.check] > 0) { - break + }else{ + repeat { + newSS <- get_ss(gp, xnew) + if (newSS[pos.check] > 0) { + break + } } } + newllp <- pda.calc.llik.par(settings, n.of.obs, newSS) ynew <- get_y(newSS, xnew, llik.fn, priors, newllp) if (is.accepted(ycurr, ynew)) { diff --git a/modules/emulator/man/plot.jump.Rd b/modules/emulator/man/plot.jump.Rd index 2c3327f997c..b05fe4bfe8d 100644 --- a/modules/emulator/man/plot.jump.Rd +++ b/modules/emulator/man/plot.jump.Rd @@ -4,7 +4,7 @@ \alias{plot.jump} \title{plot.jump} \usage{ -\method{plot}{jump}(jmp) +plot.jump(jmp) } \arguments{ \item{jmp}{jump parameter} diff --git a/modules/emulator/man/plot.mvjump.Rd b/modules/emulator/man/plot.mvjump.Rd index 6db3056b86d..35b8b475916 100644 --- a/modules/emulator/man/plot.mvjump.Rd +++ b/modules/emulator/man/plot.mvjump.Rd @@ -4,7 +4,7 @@ \alias{plot.mvjump} \title{plot.mvjump} \usage{ -\method{plot}{mvjump}(jmp) +plot.mvjump(jmp) } \arguments{ \item{jmp}{} diff --git a/modules/emulator/man/summarize.GP.Rd b/modules/emulator/man/summarize.GP.Rd index 55c705b92d1..8b364f2154b 100644 --- a/modules/emulator/man/summarize.GP.Rd +++ b/modules/emulator/man/summarize.GP.Rd @@ -4,7 +4,7 @@ \alias{summarize.GP} \title{summarize.GP} \usage{ -summarize.GP(gp, pdf_file = NULL, txt_file = NULL) +\method{summarize}{GP}(gp, pdf_file = NULL, txt_file = NULL) } \arguments{ \item{txt_file}{} From 5dd43fbeaf64d8db78b14149083d9bafb44dffdb Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Tue, 26 Sep 2017 15:12:43 -0400 Subject: [PATCH 739/771] fix messages --- models/maespa/R/write.config.MAESPA.R | 3 ++- models/preles/R/runPRELES.jobsh.R | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/models/maespa/R/write.config.MAESPA.R b/models/maespa/R/write.config.MAESPA.R index cb2b36e361d..c0b98aa72ff 100755 --- a/models/maespa/R/write.config.MAESPA.R +++ b/models/maespa/R/write.config.MAESPA.R @@ -27,7 +27,8 @@ write.config.MAESPA <- function(defaults, trait.values, settings, run.id) { if(!require("Maeswrap")){ logger.severe("The Maeswrap package is not installed. - Please consult PEcAn documentation for install notes") + Please consult PEcAn documentation for install notes: + https://pecanproject.github.io/pecan-documentation/master/pecan-models.html#maespa") } # find out where to write run/ouput diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index f2e857f8597..5fd56155b12 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -20,7 +20,7 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star if(!require("Rpreles")){ logger.severe("The Rpreles package is not installed. - Please contact the PEcAn team to obtain source code") + Please execute- devtools::install_github('MikkoPeltoniemi/Rpreles')" } # Process start and end dates From 83f15a444bd6fff8cffbcb566cb601d853752fa1 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Tue, 26 Sep 2017 15:28:55 -0400 Subject: [PATCH 740/771] missed parenthesis --- models/preles/R/runPRELES.jobsh.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/preles/R/runPRELES.jobsh.R b/models/preles/R/runPRELES.jobsh.R index 5fd56155b12..850d6d49011 100644 --- a/models/preles/R/runPRELES.jobsh.R +++ b/models/preles/R/runPRELES.jobsh.R @@ -20,7 +20,7 @@ runPRELES.jobsh <- function(met.file, outdir, parameters, sitelat, sitelon, star if(!require("Rpreles")){ logger.severe("The Rpreles package is not installed. - Please execute- devtools::install_github('MikkoPeltoniemi/Rpreles')" + Please execute- devtools::install_github('MikkoPeltoniemi/Rpreles')") } # Process start and end dates From 40b2d8af5c082f3ca0226794dc76acabde601430 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Tue, 26 Sep 2017 15:57:33 -0400 Subject: [PATCH 741/771] move SafeList from PEcAn.utils to PEcAn.settings --- CHANGELOG.md | 2 +- base/settings/DESCRIPTION | 4 +- base/settings/NAMESPACE | 4 ++ base/settings/R/SafeList.R | 71 +++++++++++++++++++++++++++++ base/settings/man/SafeList.Rd | 51 +++++++++++++++++++++ base/settings/man/cash-.SafeList.Rd | 26 +++++++++++ base/utils/R/SafeList.R | 7 +++ base/utils/man/SafeList.Rd | 3 ++ 8 files changed, 165 insertions(+), 3 deletions(-) create mode 100644 base/settings/R/SafeList.R create mode 100644 base/settings/man/SafeList.Rd create mode 100644 base/settings/man/cash-.SafeList.Rd diff --git a/CHANGELOG.md b/CHANGELOG.md index f94a4f585c2..a9670e60617 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,7 +16,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Removed `PEcAn.utils::model2netcdf`, which has been deprecated since PEcAn 1.3.7. Use `model2netcdf.` in the appropriate model package instead. ### Changed -- Moved `listToXml` ouf the `PEcAn.utils` package and into the `PEcAn.settings` package. `PEcAn.utils::listToXml` still works with a deprecation warning, but will be removed in a future release. +- Moved `listToXml` and `SafeList` ouf the `PEcAn.utils` package and into the `PEcAn.settings` package. The `PEcAn.utils` versions still work with a deprecation warning, but will be removed in a future release. - Major namespace cleanup in the `PEcAn.utils` package. It now loads more quietly and is much less likely to mask functions in a package you loaded earlier. diff --git a/base/settings/DESCRIPTION b/base/settings/DESCRIPTION index a01da286662..589e0614fb6 100644 --- a/base/settings/DESCRIPTION +++ b/base/settings/DESCRIPTION @@ -11,7 +11,6 @@ LazyData: FALSE Require: hdf5 Description: Contains functions to read PEcAn settings files Depends: - PEcAn.utils, PEcAn.DB Imports: PEcAn.logger, @@ -19,5 +18,6 @@ Imports: lubridate (>= 1.6.0), XML (>= 3.98-1.3) Suggests: - testthat (>= 1.0.2) + testthat (>= 1.0.2), + PEcAn.utils RoxygenNote: 6.0.1 diff --git a/base/settings/NAMESPACE b/base/settings/NAMESPACE index 289c4a0219e..f2faf410374 100644 --- a/base/settings/NAMESPACE +++ b/base/settings/NAMESPACE @@ -1,6 +1,7 @@ # Generated by roxygen2: do not edit by hand S3method("$",MultiSettings) +S3method("$",SafeList) S3method("$<-",MultiSettings) S3method("[",MultiSettings) S3method("[<-",MultiSettings) @@ -14,9 +15,11 @@ S3method(names,MultiSettings) S3method(print,MultiSettings) S3method(printAll,MultiSettings) export(MultiSettings) +export(SafeList) export(Settings) export(addSecrets) export(as.MultiSettings) +export(as.SafeList) export(as.Settings) export(check.bety.version) export(check.database) @@ -33,6 +36,7 @@ export(expandMultiSettings) export(fix.deprecated.settings) export(getRunSettings) export(is.MultiSettings) +export(is.SafeList) export(is.Settings) export(listToXml) export(papply) diff --git a/base/settings/R/SafeList.R b/base/settings/R/SafeList.R new file mode 100644 index 00000000000..9e174de77fb --- /dev/null +++ b/base/settings/R/SafeList.R @@ -0,0 +1,71 @@ +#------------------------------------------------------------------------------- +# Copyright (c) 2012 University of Illinois, NCSA. +# All rights reserved. This program and the accompanying materials +# are made available under the terms of the +# University of Illinois/NCSA Open Source License +# which accompanies this distribution, and is available at +# http://opensource.ncsa.illinois.edu/license.html +#------------------------------------------------------------------------------- + +##' Create a SafeList object +##' +##' SafeList is a wrapper class for the normal R list. It should behave identically, except for +##' the $ operator being overridden to require exact matches. +##' +##' The constructor works identical to list(...) unless: +##' +##' 1) The only argument is a list, in which case the result is the same list, with its class +##' attribute updated to include 'SafeList', or +##' 2) The only argument is a SafeList, in which case that argument is returned unchanged +##' +##' @title Constrct SafeList Object +##' @param ... A list to upgrade to SafeList, or elements to be added to a new SafeList +##' @return The resulting SafeList +##' @export +##' @author Ryan Kelly +SafeList <- function(...) { + result <- list(...) + if (length(result) == 1) { + if (inherits(result[[1]], "SafeList")) { + return(result[[1]]) + } else if (is.list(result[[1]])) { + result <- result[[1]] + } + } + class(result) <- c("SafeList", class(result)) + return(result) +} # SafeList + + +##' @export +##' @describeIn SafeList Coerce an object to SafeList. +##' @param x list to coerce +##' @return a SafeList version of x +as.SafeList <- function(x) { + return(SafeList(x)) +} # as.SafeList + + +##' @export +##' @describeIn SafeList Test if object is already a SafeList. +##' @param x list object to be tested +##' @return logical +is.SafeList <- function(x) { + inherits(x, "SafeList") +} # is.SafeList + + +##' Extract SafeList component by name +##' +##' Overrides `$`.list, and works just like it except forces exact match +##' (i.e., makes x$name behave exactly like x[[name, exact=T]]) +##' +##' @title Extract SafeList component by name +##' @param x the SafeList object +##' @param name the name of the component +##' @return The specified component +##' @export +##' @author Ryan Kelly +"$.SafeList" <- function(x, name) { + return(x[[name, exact = TRUE]]) +} # "$.SafeList" diff --git a/base/settings/man/SafeList.Rd b/base/settings/man/SafeList.Rd new file mode 100644 index 00000000000..9e3b9fb24dc --- /dev/null +++ b/base/settings/man/SafeList.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/SafeList.R +\name{SafeList} +\alias{SafeList} +\alias{as.SafeList} +\alias{is.SafeList} +\title{Constrct SafeList Object} +\usage{ +SafeList(...) + +as.SafeList(x) + +is.SafeList(x) +} +\arguments{ +\item{...}{A list to upgrade to SafeList, or elements to be added to a new SafeList} + +\item{x}{list to coerce} + +\item{x}{list object to be tested} +} +\value{ +The resulting SafeList + +a SafeList version of x + +logical +} +\description{ +Create a SafeList object +} +\details{ +SafeList is a wrapper class for the normal R list. It should behave identically, except for +the $ operator being overridden to require exact matches. + +The constructor works identical to list(...) unless: + +1) The only argument is a list, in which case the result is the same list, with its class +attribute updated to include 'SafeList', or +2) The only argument is a SafeList, in which case that argument is returned unchanged +} +\section{Functions}{ +\itemize{ +\item \code{as.SafeList}: Coerce an object to SafeList. + +\item \code{is.SafeList}: Test if object is already a SafeList. +}} + +\author{ +Ryan Kelly +} diff --git a/base/settings/man/cash-.SafeList.Rd b/base/settings/man/cash-.SafeList.Rd new file mode 100644 index 00000000000..5d5559e8dad --- /dev/null +++ b/base/settings/man/cash-.SafeList.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/SafeList.R +\name{$.SafeList} +\alias{$.SafeList} +\title{Extract SafeList component by name} +\usage{ +\method{$}{SafeList}(x, name) +} +\arguments{ +\item{x}{the SafeList object} + +\item{name}{the name of the component} +} +\value{ +The specified component +} +\description{ +Extract SafeList component by name +} +\details{ +Overrides `$`.list, and works just like it except forces exact match +(i.e., makes x$name behave exactly like x[[name, exact=T]]) +} +\author{ +Ryan Kelly +} diff --git a/base/utils/R/SafeList.R b/base/utils/R/SafeList.R index 93b765b9d12..b8659b9c4e9 100644 --- a/base/utils/R/SafeList.R +++ b/base/utils/R/SafeList.R @@ -9,6 +9,9 @@ ##' Create a SafeList object ##' +##' DEPRECATED: SafeList has been moved to the PEcAn.settings package and will be removed +##' from PEcAn.utils in a future release. Please use the version in PEcAn.settings. +##' ##' SafeList is a wrapper class for the normal R list. It should behave identically, except for ##' the $ operator being overridden to require exact matches. ##' @@ -24,6 +27,7 @@ ##' @export ##' @author Ryan Kelly SafeList <- function(...) { + .Deprecated("PEcAn.settings::SafeList") result <- list(...) if (length(result) == 1) { if (inherits(result[[1]], "SafeList")) { @@ -42,6 +46,7 @@ SafeList <- function(...) { ##' @param x list to coerce ##' @return a SafeList version of x as.SafeList <- function(x) { + .Deprecated("PEcAn.settings::as.SafeList") return(SafeList(x)) } # as.SafeList @@ -51,6 +56,7 @@ as.SafeList <- function(x) { ##' @param x list object to be tested ##' @return logical is.SafeList <- function(x) { + .Deprecated("PEcAn.settings::is.SafeList") inherits(x, "SafeList") } # is.SafeList @@ -67,5 +73,6 @@ is.SafeList <- function(x) { ##' @export ##' @author Ryan Kelly "$.SafeList" <- function(x, name) { + .Deprecated("PEcAn.settings::$.SafeList") return(x[[name, exact = TRUE]]) } # "$.SafeList" diff --git a/base/utils/man/SafeList.Rd b/base/utils/man/SafeList.Rd index 80ef577d83d..2d4c862b3be 100644 --- a/base/utils/man/SafeList.Rd +++ b/base/utils/man/SafeList.Rd @@ -30,6 +30,9 @@ logical Create a SafeList object } \details{ +DEPRECATED: SafeList has been moved to the PEcAn.settings package and will be removed +from PEcAn.utils in a future release. Please use the version in PEcAn.settings. + SafeList is a wrapper class for the normal R list. It should behave identically, except for the $ operator being overridden to require exact matches. From 61a6a89195c74055077ce6055768b4a4a5df4c0b Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 26 Sep 2017 15:58:14 -0400 Subject: [PATCH 742/771] roxygenize --- modules/emulator/NAMESPACE | 4 ++-- modules/emulator/R/summarize.GP.R | 2 +- modules/emulator/man/plot.jump.Rd | 2 +- modules/emulator/man/plot.mvjump.Rd | 2 +- modules/emulator/man/summarize.GP.Rd | 2 +- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/modules/emulator/NAMESPACE b/modules/emulator/NAMESPACE index e4c55f18d90..421d54566ae 100644 --- a/modules/emulator/NAMESPACE +++ b/modules/emulator/NAMESPACE @@ -4,9 +4,9 @@ S3method(calcSpatialCov,list) S3method(calcSpatialCov,matrix) S3method(p,jump) S3method(p,mvjump) +S3method(plot,mvjump) S3method(predict,GP) S3method(predict,density) -S3method(summarize,GP) S3method(update,jump) S3method(update,mvjump) export(GaussProcess) @@ -34,4 +34,4 @@ export(mvjump) export(nderiv) export(p) export(plot.jump) -export(plot.mvjump) +export(summarize.GP) diff --git a/modules/emulator/R/summarize.GP.R b/modules/emulator/R/summarize.GP.R index 80f9ac4faf2..e31a8d588e8 100644 --- a/modules/emulator/R/summarize.GP.R +++ b/modules/emulator/R/summarize.GP.R @@ -84,4 +84,4 @@ summarize.GP <- function(gp, pdf_file = NULL, txt_file = NULL) { if (!is.null(txt_file)) { sink() } -} # summarize.GP +} # summarize_GP diff --git a/modules/emulator/man/plot.jump.Rd b/modules/emulator/man/plot.jump.Rd index b05fe4bfe8d..2c3327f997c 100644 --- a/modules/emulator/man/plot.jump.Rd +++ b/modules/emulator/man/plot.jump.Rd @@ -4,7 +4,7 @@ \alias{plot.jump} \title{plot.jump} \usage{ -plot.jump(jmp) +\method{plot}{jump}(jmp) } \arguments{ \item{jmp}{jump parameter} diff --git a/modules/emulator/man/plot.mvjump.Rd b/modules/emulator/man/plot.mvjump.Rd index 35b8b475916..6db3056b86d 100644 --- a/modules/emulator/man/plot.mvjump.Rd +++ b/modules/emulator/man/plot.mvjump.Rd @@ -4,7 +4,7 @@ \alias{plot.mvjump} \title{plot.mvjump} \usage{ -plot.mvjump(jmp) +\method{plot}{mvjump}(jmp) } \arguments{ \item{jmp}{} diff --git a/modules/emulator/man/summarize.GP.Rd b/modules/emulator/man/summarize.GP.Rd index 8b364f2154b..55c705b92d1 100644 --- a/modules/emulator/man/summarize.GP.Rd +++ b/modules/emulator/man/summarize.GP.Rd @@ -4,7 +4,7 @@ \alias{summarize.GP} \title{summarize.GP} \usage{ -\method{summarize}{GP}(gp, pdf_file = NULL, txt_file = NULL) +summarize.GP(gp, pdf_file = NULL, txt_file = NULL) } \arguments{ \item{txt_file}{} From 5e28d6fee8530e6ae4de42c472fb83e221c104fa Mon Sep 17 00:00:00 2001 From: Chris Black Date: Tue, 26 Sep 2017 16:04:26 -0400 Subject: [PATCH 743/771] utils no longer depends on settings --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 8ae001ab22f..648fef07319 100644 --- a/Makefile +++ b/Makefile @@ -55,7 +55,7 @@ depends = .doc/$(1) .install/$(1) .check/$(1) .test/$(1) $(call depends,base/remote): .install/base/logger $(call depends,base/utils): .install/base/logger .install/base/remote $(call depends,base/db): .install/base/logger .install/base/utils -$(call depends,base/settings): .install/base/logger .install/base/utils .install/base/db +$(call depends,base/settings): .install/base/logger .install/base/db $(call depends,base/visualization): .install/base/logger .install/base/db $(call depends,base/qaqc): .install/base/logger $(call depends,modules/data.atmosphere): .install/base/logger .install/base/utils .install/base/remote From 1ae2a5115c8f5a6372504b6d7370ac75b5ab9363 Mon Sep 17 00:00:00 2001 From: istfer Date: Tue, 26 Sep 2017 16:26:05 -0400 Subject: [PATCH 744/771] scale tau prior according to SS --- modules/assim.batch/R/pda.define.llik.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/modules/assim.batch/R/pda.define.llik.R b/modules/assim.batch/R/pda.define.llik.R index b8728b40642..622bc47b888 100644 --- a/modules/assim.batch/R/pda.define.llik.R +++ b/modules/assim.batch/R/pda.define.llik.R @@ -202,8 +202,11 @@ pda.calc.llik.par <-function(settings, n, error.stats){ if (settings$assim.batch$inputs[[k]]$likelihood == "Gaussian" | settings$assim.batch$inputs[[k]]$likelihood == "multipGauss") { - - llik.par[[k]]$par <- rgamma(1, n[k]/2, error.stats[k]/2) + get_order <- log10(error.stats[k]) + # tau prior : gamma(a, b) + a <- 1e-3 + b <- 1e-3 * (10^get_order) # scale prior, make SS >> b + llik.par[[k]]$par <- rgamma(1, a + n[k]/2, b + error.stats[k]/2) names(llik.par[[k]]$par) <- paste0("tau.", names(n)[k]) From 759e980c3b2c8d1c283d717e27b5cf4825fc7257 Mon Sep 17 00:00:00 2001 From: istfer Date: Wed, 27 Sep 2017 10:20:18 -0400 Subject: [PATCH 745/771] pass hyper parameters via settings or default to scaling --- modules/assim.batch/R/pda.define.llik.R | 15 ++++----- modules/assim.batch/R/pda.emulator.R | 5 +++ modules/assim.batch/R/pda.utils.R | 41 +++++++++++++++++++++++++ modules/emulator/R/minimize.GP.R | 14 ++++----- 4 files changed, 59 insertions(+), 16 deletions(-) diff --git a/modules/assim.batch/R/pda.define.llik.R b/modules/assim.batch/R/pda.define.llik.R index 622bc47b888..04b21b280ed 100644 --- a/modules/assim.batch/R/pda.define.llik.R +++ b/modules/assim.batch/R/pda.define.llik.R @@ -185,13 +185,14 @@ pda.calc.llik <- function(pda.errors, llik.fn, llik.par) { ##' @title pda.calc.llik.par ##' ##' @param settings list -##' @param n named vector -##' @param error.stats list +##' @param n named vector, sample sizes of inputs +##' @param error.stats list, Sufficient Statistics +##' @param hyper.pars list, hyperparameters ##' ##' @author Istem Fer ##' @export -pda.calc.llik.par <-function(settings, n, error.stats){ +pda.calc.llik.par <-function(settings, n, error.stats, hyper.pars){ llik.par <- list() @@ -202,14 +203,10 @@ pda.calc.llik.par <-function(settings, n, error.stats){ if (settings$assim.batch$inputs[[k]]$likelihood == "Gaussian" | settings$assim.batch$inputs[[k]]$likelihood == "multipGauss") { - get_order <- log10(error.stats[k]) - # tau prior : gamma(a, b) - a <- 1e-3 - b <- 1e-3 * (10^get_order) # scale prior, make SS >> b - llik.par[[k]]$par <- rgamma(1, a + n[k]/2, b + error.stats[k]/2) + llik.par[[k]]$par <- rgamma(1, hyper.pars[[k]]$parama + n[k]/2, + hyper.pars[[k]]$paramb + error.stats[k]/2) names(llik.par[[k]]$par) <- paste0("tau.", names(n)[k]) - } llik.par[[k]]$n <- n[k] diff --git a/modules/assim.batch/R/pda.emulator.R b/modules/assim.batch/R/pda.emulator.R index d46525b255b..8a3d72efc17 100644 --- a/modules/assim.batch/R/pda.emulator.R +++ b/modules/assim.batch/R/pda.emulator.R @@ -487,6 +487,9 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, mix <- "each" } + # get hyper parameters if any + hyper.pars <- return_hyperpars(settings$assim.batch, inputs) + PEcAn.logger::logger.info(paste0("Starting emulator MCMC. Please wait.")) current.step <- "pre-MCMC" @@ -518,6 +521,7 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, run.block = (run.normal | run.round), n.of.obs = n.of.obs, llik.fn = llik.fn, + hyper.pars = hyper.pars, resume.list = resume.list[[chain]] ) }) @@ -593,6 +597,7 @@ pda.emulator <- function(settings, external.data = NULL, external.priors = NULL, run.block = (run.normal | run.round) n.of.obs = n.of.obs llik.fn = llik.fn + hyper.pars = hyper.pars resume.list = resume.list[[chain]] } diff --git a/modules/assim.batch/R/pda.utils.R b/modules/assim.batch/R/pda.utils.R index d36a0568b8b..95acefd1be0 100644 --- a/modules/assim.batch/R/pda.utils.R +++ b/modules/assim.batch/R/pda.utils.R @@ -736,3 +736,44 @@ return.bias <- function(isbias, model.out, inputs, prior.list.bias, nbias, return(list(bias.params = bias.params, prior.list.bias = prior.list.bias)) } # return.bias + + +##' @title return_hyperpars +##' @author Istem Fer +##' @export +return_hyperpars <- function(assim.settings, inputs){ + + check.hypers <- sapply(assim.settings$inputs, `[[`, "hyper.pars") + + hyper.pars <- list() + + if(length(unlist(check.hypers)) == 0){ + # no hyper parameters passed via settings + # default to scaled hyper params + for(k in seq_along(assim.settings$inputs)){ + hyper.pars[[k]] <- list() + hyper.pars[[k]]$parama <- 0.001 + hyper.pars[[k]]$paramb <- 0.001 * mean(inputs[[k]]$data[,1], na.rm = TRUE) ^ 2 + } + + }else{ + + # hyperparameters at least for one likelihood was passed + for(k in seq_along(assim.settings$inputs)){ + + if(is.null(check.hypers[[k]])){ + hyper.pars[[k]] <- list() + hyper.pars[[k]]$parama <- 0.001 + hyper.pars[[k]]$paramb <- 0.001 * mean(inputs[[k]]$data[,1], na.rm = TRUE) ^ 2 + }else{ + hyper.pars[[k]] <- list() + hyper.pars[[k]]$parama <- as.numeric(assim.settings$inputs[[k]]$hyper.pars$parama) + hyper.pars[[k]]$paramb <- as.numeric(assim.settings$inputs[[k]]$hyper.pars$paramb) + } + + } + + } + + return(hyper.pars) +} # return_hyperpars diff --git a/modules/emulator/R/minimize.GP.R b/modules/emulator/R/minimize.GP.R index c60583727ad..fe88186b25d 100644 --- a/modules/emulator/R/minimize.GP.R +++ b/modules/emulator/R/minimize.GP.R @@ -177,7 +177,7 @@ is.accepted <- function(ycurr, ynew, format = "lin") { ##' @author Michael Dietze mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcns = NULL, jmp0 = 0.35 * (rng[, 2] - rng[, 1]), ar.target = 0.5, priors = NA, settings, - run.block = TRUE, n.of.obs, llik.fn, resume.list = NULL) { + run.block = TRUE, n.of.obs, llik.fn, hyper.pars, resume.list = NULL) { pos.check <- sapply(settings$assim.batch$inputs, `[[`, "ss.positive") @@ -190,7 +190,7 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn from.settings <- sapply(seq_along(pos.check), function(x) !is.null(pos.check[[x]])) tmp.check <- rep(FALSE, length(settings$assim.batch$inputs)) # replace those with the values provided in the settings - tmp.check[from.settings] <- unlist(pos.check) + tmp.check[from.settings] <- as.logical(unlist(pos.check)) pos.check <- tmp.check }else{ pos.check <- as.logical(pos.check) @@ -209,7 +209,7 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn } - currllp <- pda.calc.llik.par(settings, n.of.obs, currSS) + currllp <- pda.calc.llik.par(settings, n.of.obs, currSS, hyper.pars) LLpar <- unlist(sapply(currllp, `[[` , "par")) xcurr <- x0 @@ -288,7 +288,7 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn } - newllp <- pda.calc.llik.par(settings, n.of.obs, newSS) + newllp <- pda.calc.llik.par(settings, n.of.obs, newSS, hyper.pars) ynew <- get_y(newSS, xnew, llik.fn, priors, newllp) if (is.accepted(ycurr, ynew)) { @@ -298,7 +298,7 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn } # now update currllp | xcurr - currllp <- pda.calc.llik.par(settings, n.of.obs, currSS) + currllp <- pda.calc.llik.par(settings, n.of.obs, currSS, hyper.pars) pcurr <- unlist(sapply(currllp, `[[` , "par")) # } mix = each } else { @@ -335,14 +335,14 @@ mcmc.GP <- function(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcn } } - newllp <- pda.calc.llik.par(settings, n.of.obs, newSS) + newllp <- pda.calc.llik.par(settings, n.of.obs, newSS, hyper.pars) ynew <- get_y(newSS, xnew, llik.fn, priors, newllp) if (is.accepted(ycurr, ynew)) { xcurr <- xnew currSS <- newSS } - currllp <- pda.calc.llik.par(settings, n.of.obs, currSS) + currllp <- pda.calc.llik.par(settings, n.of.obs, currSS, hyper.pars) pcurr <- unlist(sapply(currllp, `[[` , "par")) # } From e9d61bb7383a06679823e332f475c1247239e6b1 Mon Sep 17 00:00:00 2001 From: istfer Date: Wed, 27 Sep 2017 10:23:10 -0400 Subject: [PATCH 746/771] update other PDA scripts --- modules/assim.batch/R/pda.bayesian.tools.R | 6 +++++- modules/assim.batch/R/pda.mcmc.R | 6 +++++- modules/assim.batch/R/pda.mcmc.bs.R | 6 +++++- 3 files changed, 15 insertions(+), 3 deletions(-) diff --git a/modules/assim.batch/R/pda.bayesian.tools.R b/modules/assim.batch/R/pda.bayesian.tools.R index a447ab2b9ac..bb93636b70e 100644 --- a/modules/assim.batch/R/pda.bayesian.tools.R +++ b/modules/assim.batch/R/pda.bayesian.tools.R @@ -62,6 +62,9 @@ pda.bayesian.tools <- function(settings, params.id = NULL, param.names = NULL, p inputs <- load.pda.data(settings, bety) n.input <- length(inputs) + # get hyper parameters if any + hyper.pars <- return_hyperpars(settings$assim.batch, inputs) + # efficient sample size calculation # fot BT you might want to run the model once and align inputs & outputs, then calculate n_eff # for now assume they will be same length @@ -167,7 +170,8 @@ pda.bayesian.tools <- function(settings, params.id = NULL, param.names = NULL, p ## calculate error statistics pda.errors <- pda.calc.error(settings, con, model_out = model.out, run.id, inputs, all.bias) llik.par <- pda.calc.llik.par(settings, n = n.of.obs, - error.stats = unlist(pda.errors)) + error.stats = unlist(pda.errors), + hyper.pars) ## Calculate likelihood LL.new <- pda.calc.llik(pda.errors = unlist(pda.errors), llik.fn, llik.par) diff --git a/modules/assim.batch/R/pda.mcmc.R b/modules/assim.batch/R/pda.mcmc.R index 0c323ffcb9b..370df2cd624 100644 --- a/modules/assim.batch/R/pda.mcmc.R +++ b/modules/assim.batch/R/pda.mcmc.R @@ -60,6 +60,9 @@ pda.mcmc <- function(settings, params.id = NULL, param.names = NULL, prior.id = inputs <- load.pda.data(settings, bety) n.input <- length(inputs) + # get hyper parameters if any + hyper.pars <- return_hyperpars(settings$assim.batch, inputs) + ## Set model-specific functions do.call("require", list(paste0("PEcAn.", settings$model$type))) my.write.config <- paste0("write.config.", settings$model$type) @@ -243,7 +246,8 @@ pda.mcmc <- function(settings, params.id = NULL, param.names = NULL, prior.id = ## calculate error statistics pda.errors <- pda.calc.error(settings, con, model_out = model.out, run.id, inputs, all.bias) llik.par <- pda.calc.llik.par(settings, n = n.of.obs, - error.stats = unlist(pda.errors)) + error.stats = unlist(pda.errors), + hyper.pars) # store llik-par parl <- unlist(sapply(llik.par, `[[` , "par")) if(!is.null(parl) & iter.flag == 1 & is.null(all.bias)) { diff --git a/modules/assim.batch/R/pda.mcmc.bs.R b/modules/assim.batch/R/pda.mcmc.bs.R index a2bbdf5bec7..caf71a66a8d 100644 --- a/modules/assim.batch/R/pda.mcmc.bs.R +++ b/modules/assim.batch/R/pda.mcmc.bs.R @@ -67,6 +67,9 @@ pda.mcmc.bs <- function(settings, params.id = NULL, param.names = NULL, prior.id inputs <- load.pda.data(settings, bety) n.input <- length(inputs) + # get hyper parameters if any + hyper.pars <- return_hyperpars(settings$assim.batch, inputs) + ## Set model-specific functions do.call("require", list(paste0("PEcAn.", settings$model$type))) my.write.config <- paste("write.config.", settings$model$type, sep = "") @@ -243,7 +246,8 @@ pda.mcmc.bs <- function(settings, params.id = NULL, param.names = NULL, prior.id ## calculate error statistics pda.errors <- pda.calc.error(settings, con, model_out = model.out, run.id, inputs, all.bias) llik.par <- pda.calc.llik.par(settings, n = n.of.obs, - error.stats = unlist(pda.errors)) + error.stats = unlist(pda.errors), + hyper.pars) # store llik-par parl <- unlist(sapply(llik.par, `[[` , "par")) if(!is.null(parl) & iter.flag == 1 & is.null(all.bias)) { From 977db021b7ec07cc4e990b606055d81e075cb650 Mon Sep 17 00:00:00 2001 From: istfer Date: Wed, 27 Sep 2017 10:26:40 -0400 Subject: [PATCH 747/771] update changelog --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6e6c02f2d20..5d1b2423099 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha ## [Unreleased] ### Fixes +- Fixed hyperparameter draws in PDA - Show workflowid in the URL when run is finshed and user clicks results (#1659) - `PEcAn.BIOCRO` now uses PEcAn-standard variable names. As a result, two output variables have been renamed but keep their existing units and definitions: - `StemBiom` renamed to `AbvGrndWood` @@ -29,6 +30,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - Remote execution is more robust to errors in the submission process, not just the actual model execution ### Added +- Functionality to pass hyperparameters via settings - Created new (and very rudimentary) web interface for downloading data from the dataone federation into the PEcAn database. More updates to come. - Expanded initial conditions workflow for pool-based models, including PEcAn.data.land::prepare_pools to calculate pools from IC file (to be coupled with write.configs) - New `PEcAn.utils::days_in_year(year)` function that should make it easier to work with leap years. From 23b9595840ca83304519d8332e92621701808985 Mon Sep 17 00:00:00 2001 From: istfer Date: Wed, 27 Sep 2017 10:42:30 -0400 Subject: [PATCH 748/771] update doc --- .../adv_user_guide_web/pda.documentation.Rmd | 3 ++ .../vignettes/AssimBatchVignette.Rmd | 35 +++++++++++++++++++ 2 files changed, 38 insertions(+) diff --git a/book_source/adv_user_guide_web/pda.documentation.Rmd b/book_source/adv_user_guide_web/pda.documentation.Rmd index 81f5d85d8ed..325d856cec8 100644 --- a/book_source/adv_user_guide_web/pda.documentation.Rmd +++ b/book_source/adv_user_guide_web/pda.documentation.Rmd @@ -64,3 +64,6 @@ This file contains most of the individual functions used by the main PDA functio ### **get.da.data.*.R, plot.da.R** Old codes written by Carl Davidson. Defunct now, but may contain good ideas so currently left in. +## For a detailed usage of the module, please see the vignette under **/modules/assim.batch/vignettes** + + diff --git a/modules/assim.batch/vignettes/AssimBatchVignette.Rmd b/modules/assim.batch/vignettes/AssimBatchVignette.Rmd index 3df26182734..53ec1259f83 100644 --- a/modules/assim.batch/vignettes/AssimBatchVignette.Rmd +++ b/modules/assim.batch/vignettes/AssimBatchVignette.Rmd @@ -65,6 +65,23 @@ The easiest way to use PEcAn's parameter data assimilation module is to add an ` + + + ... + + ... + + multipGauss + + 0.001 + 0.001 + + TRUE + + ... + + + 0.3 200 @@ -141,6 +158,7 @@ head(trait.dictionary[,c("id", "figid")]) + `` File path to the input. Both `` and `` of the observation data should be supplied for the PDA. + `` A standardized source of input data (e.g., Ameriflux). Not implemented yet, but the idea would be similar to the met workflow, PEcAn would be able to use standard data sources automatically where available. Only used if no `` or `` is given. + `` Identifier for the likelihood to use. E.g., the Ameriflux NEE/FC and LE data use a Laplacian likelihood. + + `` Optional. Hyperparameters for your likelihood. E.g. Prior parameters of the precision for Gaussian likelihood. Defaults to scaled values if not provided. + `` The BETY variable ID associated with this dataset. The idea is that specific preprocessing steps (e.g., estimating heteroskedastic error for tower NEE) would be associated with particular IDs. Could automate further by assigning default `` to variable.id values (allowing `` to be omitted from pecan.xml). NOTE : `` chunk should always be on your xml file regardless of the method you use in the PDA. @@ -194,6 +212,23 @@ If you are using methods other than *bruteforce* and *bruteforce.bs*, some addit + `round` this extension run proposes new points in the parameter space in addition to the previous ones, and builds a new emulator including these additional points for a new MCMC sampling. These new points can come from both your inital PDA prior and the posterior of your first round of emulator run. You can determine the percentage of new knots coming from the posterior of your previous run in the `` tag. If you leave it empty, 75% of your new points will be drawn from the posterior of your previous run by default. +``` + + ... + + ... + + multipGauss + TRUE + ... + + ... + + + +``` + +* `` When using the emulator, it is important to let the algorithm know that you have a likelihood whose sufficient statistics is zero bound. **bayesian.tools** would look for sampler specific settings that can be passed through the pecan.xml as a block under the `` tag. Currently, the available samplers in the BayesianTools package are: From e1953af94b9866fa9a49a54f84ec1041624b7428 Mon Sep 17 00:00:00 2001 From: istfer Date: Wed, 27 Sep 2017 10:44:46 -0400 Subject: [PATCH 749/771] roxygenise --- modules/assim.batch/NAMESPACE | 1 + modules/assim.batch/man/pda.calc.llik.par.Rd | 8 +++++--- modules/emulator/man/mcmc.GP.Rd | 2 +- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/modules/assim.batch/NAMESPACE b/modules/assim.batch/NAMESPACE index 908747a217c..630ac2f28ba 100644 --- a/modules/assim.batch/NAMESPACE +++ b/modules/assim.batch/NAMESPACE @@ -36,6 +36,7 @@ export(pda.postprocess) export(pda.settings) export(pda.settings.bt) export(return.bias) +export(return_hyperpars) export(runModule.assim.batch) export(write_sf_posterior) import(IDPmisc) diff --git a/modules/assim.batch/man/pda.calc.llik.par.Rd b/modules/assim.batch/man/pda.calc.llik.par.Rd index 4fa1b2b1c73..4bc2b872787 100644 --- a/modules/assim.batch/man/pda.calc.llik.par.Rd +++ b/modules/assim.batch/man/pda.calc.llik.par.Rd @@ -4,14 +4,16 @@ \alias{pda.calc.llik.par} \title{pda.calc.llik.par} \usage{ -pda.calc.llik.par(settings, n, error.stats) +pda.calc.llik.par(settings, n, error.stats, hyper.pars) } \arguments{ \item{settings}{list} -\item{n}{named vector} +\item{n}{named vector, sample sizes of inputs} -\item{error.stats}{list} +\item{error.stats}{list, Sufficient Statistics} + +\item{hyper.pars}{list, hyperparameters} } \description{ Calculate likelihood parameters diff --git a/modules/emulator/man/mcmc.GP.Rd b/modules/emulator/man/mcmc.GP.Rd index 16aee21a9d7..0e63c413c71 100644 --- a/modules/emulator/man/mcmc.GP.Rd +++ b/modules/emulator/man/mcmc.GP.Rd @@ -6,7 +6,7 @@ \usage{ mcmc.GP(gp, x0, nmcmc, rng, format = "lin", mix = "joint", splinefcns = NULL, jmp0 = 0.35 * (rng[, 2] - rng[, 1]), ar.target = 0.5, - priors = NA, settings, run.block = TRUE, n.of.obs, llik.fn, + priors = NA, settings, run.block = TRUE, n.of.obs, llik.fn, hyper.pars, resume.list = NULL) } \arguments{ From 9babd33e1ee2a17730a6dc90763cc290502657f3 Mon Sep 17 00:00:00 2001 From: istfer Date: Wed, 27 Sep 2017 11:04:03 -0400 Subject: [PATCH 750/771] commit new man file --- modules/assim.batch/man/return_hyperpars.Rd | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 modules/assim.batch/man/return_hyperpars.Rd diff --git a/modules/assim.batch/man/return_hyperpars.Rd b/modules/assim.batch/man/return_hyperpars.Rd new file mode 100644 index 00000000000..5ec107d66ca --- /dev/null +++ b/modules/assim.batch/man/return_hyperpars.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pda.utils.R +\name{return_hyperpars} +\alias{return_hyperpars} +\title{return_hyperpars} +\usage{ +return_hyperpars(assim.settings, inputs) +} +\author{ +Istem Fer +} From e05e997d19b5776681bdaffbd1ba9db0725879e6 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Wed, 27 Sep 2017 11:30:02 -0400 Subject: [PATCH 751/771] Add template package back into build Some model packages get documentation from here using @InheritParams --- Makefile | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 8ae001ab22f..10ac8b263fd 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ NCPUS ?= 1 BASE := logger utils db settings visualization qaqc remote MODELS := biocro clm45 dalec ed fates gday jules linkages \ - lpjguess maat maespa preles sipnet + lpjguess maat maespa preles sipnet template MODULES := allometry assim.batch assim.sequential benchmark \ data.atmosphere data.hydrology data.land \ @@ -50,6 +50,8 @@ test: $(ALL_PKGS_T) .test/base/all .check/base/all: $(ALL_PKGS_C) .test/base/all: $(ALL_PKGS_T) +$(subst .doc/models/template,,$(MODELS_D)): .doc/models/template + depends = .doc/$(1) .install/$(1) .check/$(1) .test/$(1) $(call depends,base/remote): .install/base/logger From 940d8376351f9a95e8fba3cf7b2f5fb0deaf5c95 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Wed, 27 Sep 2017 11:32:45 -0400 Subject: [PATCH 752/771] fix typo that prevented inheriting param documentation --- models/sipnet/R/read_restart.SIPNET.R | 2 +- models/sipnet/man/read_restart.SIPNET.Rd | 13 +++++++++++++ 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/models/sipnet/R/read_restart.SIPNET.R b/models/sipnet/R/read_restart.SIPNET.R index 413ee154455..3dc40248f28 100644 --- a/models/sipnet/R/read_restart.SIPNET.R +++ b/models/sipnet/R/read_restart.SIPNET.R @@ -11,7 +11,7 @@ ##' ##' @author Ann Raiho \email{araiho@@nd.edu} ##' -##' @inheritParams PEcAn.ModelName::read +##' @inheritParams PEcAn.ModelName::read_restart.ModelName ##' ##' @description Read Restart for SIPNET ##' diff --git a/models/sipnet/man/read_restart.SIPNET.Rd b/models/sipnet/man/read_restart.SIPNET.Rd index 6bbc4d07fdb..7bb8f4553e6 100644 --- a/models/sipnet/man/read_restart.SIPNET.Rd +++ b/models/sipnet/man/read_restart.SIPNET.Rd @@ -6,6 +6,19 @@ \usage{ read_restart.SIPNET(outdir, runid, stop.time, settings, var.names, params) } +\arguments{ +\item{outdir}{Output directory} + +\item{runid}{Run ID} + +\item{stop.time}{Year that is being read} + +\item{settings}{PEcAn settings object} + +\item{var.names}{Variable names to be extracted} + +\item{params}{Any parameters required for state calculations} +} \value{ X.vec vector of forecasts } From d3b965e3d117dd0522f37defd9a6134aab806015 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Wed, 27 Sep 2017 11:33:32 -0400 Subject: [PATCH 753/771] simplify depends calls --- Makefile | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/Makefile b/Makefile index 10ac8b263fd..ba2b4fabf8d 100644 --- a/Makefile +++ b/Makefile @@ -51,24 +51,23 @@ test: $(ALL_PKGS_T) .test/base/all .test/base/all: $(ALL_PKGS_T) $(subst .doc/models/template,,$(MODELS_D)): .doc/models/template +$(subst .install/base/logger,,$(ALL_PKGS_I)): .install/base/logger depends = .doc/$(1) .install/$(1) .check/$(1) .test/$(1) -$(call depends,base/remote): .install/base/logger -$(call depends,base/utils): .install/base/logger .install/base/remote -$(call depends,base/db): .install/base/logger .install/base/utils -$(call depends,base/settings): .install/base/logger .install/base/utils .install/base/db -$(call depends,base/visualization): .install/base/logger .install/base/db -$(call depends,base/qaqc): .install/base/logger -$(call depends,modules/data.atmosphere): .install/base/logger .install/base/utils .install/base/remote -$(call depends,modules/data.land): .install/base/logger .install/base/db .install/base/utils .install/base/remote -$(call depends,modules/meta.analysis): .install/base/logger .install/base/utils .install/base/db .install/base/remote -$(call depends,modules/priors): .install/base/logger .install/base/utils .install/base/remote -$(call depends,modules/assim.batch): .install/base/logger .install/base/utils .install/base/db .install/modules/meta.analysis .install/base/remote -$(call depends,modules/rtm): .install/base/logger .install/modules/assim.batch .install/base/remote -$(call depends,modules/uncertainty): .install/base/logger .install/base/utils .install/modules/priors .install/base/remote -$(call depends,models/template): .install/base/logger .install/base/utils .install/base/remote -$(call depends,models/biocro): .install/base/logger .install/base/utils .install/base/settings .install/base/db .install/modules/data.atmosphere .install/modules/data.land .install/base/remote +$(call depends,base/utils): .install/base/remote +$(call depends,base/db): .install/base/utils +$(call depends,base/settings): .install/base/utils .install/base/db +$(call depends,base/visualization): .install/base/db +$(call depends,modules/data.atmosphere): .install/base/utils .install/base/remote +$(call depends,modules/data.land): .install/base/db .install/base/utils .install/base/remote +$(call depends,modules/meta.analysis): .install/base/utils .install/base/db .install/base/remote +$(call depends,modules/priors): .install/base/utils .install/base/remote +$(call depends,modules/assim.batch): .install/base/utils .install/base/db .install/modules/meta.analysis .install/base/remote +$(call depends,modules/rtm): .install/modules/assim.batch .install/base/remote +$(call depends,modules/uncertainty): .install/base/utils .install/modules/priors .install/base/remote +$(call depends,models/template): .install/base/utils .install/base/remote +$(call depends,models/biocro): .install/base/utils .install/base/settings .install/base/db .install/modules/data.atmosphere .install/modules/data.land .install/base/remote clean: rm -rf .install .check .test .doc From 158d4d506684321c94622570edf728f70de64297 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Wed, 27 Sep 2017 12:51:10 -0400 Subject: [PATCH 754/771] roxygen looks in the installed version --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index ba2b4fabf8d..eb54832e8bb 100644 --- a/Makefile +++ b/Makefile @@ -50,7 +50,7 @@ test: $(ALL_PKGS_T) .test/base/all .check/base/all: $(ALL_PKGS_C) .test/base/all: $(ALL_PKGS_T) -$(subst .doc/models/template,,$(MODELS_D)): .doc/models/template +$(subst .doc/models/template,,$(MODELS_D)): .install/models/template # for models that import Roxygen docs from template $(subst .install/base/logger,,$(ALL_PKGS_I)): .install/base/logger depends = .doc/$(1) .install/$(1) .check/$(1) .test/$(1) From 5af0b25f065a7e0a8ba829c552862427e3e35002 Mon Sep 17 00:00:00 2001 From: Tony Gardella Date: Wed, 27 Sep 2017 14:57:29 -0400 Subject: [PATCH 755/771] missed external function call --- models/maespa/R/met2model.MAESPA.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/models/maespa/R/met2model.MAESPA.R b/models/maespa/R/met2model.MAESPA.R index 0abc97619f4..3e5a231948a 100755 --- a/models/maespa/R/met2model.MAESPA.R +++ b/models/maespa/R/met2model.MAESPA.R @@ -104,7 +104,7 @@ met2model.MAESPA <- function(in.path, in.prefix, outfolder, start_date, end_date ## Process PAR if (!is.numeric(PAR)) { # Function from data.atmosphere will convert SW to par in W/m2 - PAR <- sw2par(RAD) + PAR <- PEcAn.data.atmosphere::sw2par(RAD) } else { # convert PAR <- udunits2::ud.convert(PAR, "mol", "umol") From efc898c25d09af8f4dc96e30c95623a5b8fb0fcc Mon Sep 17 00:00:00 2001 From: adesai Date: Wed, 27 Sep 2017 15:24:01 -0500 Subject: [PATCH 756/771] Update to work with changes to nneo package --- modules/data.atmosphere/R/download.NEONmet.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/modules/data.atmosphere/R/download.NEONmet.R b/modules/data.atmosphere/R/download.NEONmet.R index ea6fc1ec008..030a8fe70dc 100644 --- a/modules/data.atmosphere/R/download.NEONmet.R +++ b/modules/data.atmosphere/R/download.NEONmet.R @@ -363,7 +363,7 @@ neonmet.getVals <- function(dates,product,site,datetime, ncdata <- rep(FillValue,length(datetime)) for (mon in dates) { neonData <- nneo::nneo_data(product_code = product, site_code = site, year_month = mon) - urls <- neonData$data$urls + urls <- neonData$data$files$name if (length(urls)>0) { #Extract and read 30 minute data from the highest vertical level among files returned #If belowground, then take top most level (lowest value) @@ -373,13 +373,13 @@ neonmet.getVals <- function(dates,product,site,datetime, url30 <- tail(sort(urls[grep(urlstring,urls)]),1) } if (length(url30)!=0) { - csvData <- read.csv(url30,stringsAsFactors=FALSE,header=TRUE) + csvData <- nneo::nneo_file(product_code = product, site_code = site, year_month = mon, filename = url30) #Retreive time dimension and figure out where in array to put it csvDateTime <- as.POSIXct(gsub("T"," ",csvData$startDateTime),tz="UTC") arrLoc <- floor(as.numeric(difftime(csvDateTime,datetime[1],tz="UTC",units="hours"))*2)+1 - csvVar <- csvData[,data_col] + csvVar <- csvData[[data_col]] if (length(QF_col)!=0) { - csvQF <- csvData[,QF_col] + csvQF <- csvData[[QF_col]] csvVar[which(csvQF!=QF)] <- NA } if ((length(units)=2)&&(units[1]!=units[2])) { From 4068e3555400228014335f84e410d89b2f4f5c00 Mon Sep 17 00:00:00 2001 From: adesai Date: Wed, 27 Sep 2017 17:34:11 -0500 Subject: [PATCH 757/771] Fix to precipitation query in NEONmet --- modules/data.atmosphere/R/download.NEONmet.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/modules/data.atmosphere/R/download.NEONmet.R b/modules/data.atmosphere/R/download.NEONmet.R index 030a8fe70dc..9500f709e73 100644 --- a/modules/data.atmosphere/R/download.NEONmet.R +++ b/modules/data.atmosphere/R/download.NEONmet.R @@ -211,7 +211,8 @@ download.NEONmet <- function(sitename, outfolder, start_date, end_date, dim = xytdim) nc <- ncdf4::ncvar_add(nc = nc, v = precip.var, verbose = verbose) ncdata <- neonmet.getVals(dates=precipDates,product=availProducts[precipLoc[1]],site=site, - datetime=datetime,data_col="secPrecipBulk",QF_col=NULL, + datetime=datetime,data_col="priPrecipBulk",QF_col="priPrecipFinalQF", + urlstring = "\\.00000\\.900\\.(.*)30min", units=c("kg m-2 1/1800 s-1", "kg m-2 s-1")) #mm per half hour ncdf4::ncvar_put(nc, varid = precip.var, vals = ncdata) } else { From ded6a896af0620b1a3a60264610df2cf0a87194b Mon Sep 17 00:00:00 2001 From: Tess McCabe Date: Thu, 28 Sep 2017 10:04:19 -0400 Subject: [PATCH 758/771] Update CHANGELOG.md --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index b8cfd347972..17c944ccc02 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -45,6 +45,7 @@ For more information about this file see also [Keep a Changelog](http://keepacha - #1594 shiny/workflowPlot Smoothing using geom_smooth (Slider for specifying moving window width) - #1594 shiny/workflowPlot Comparing model output vs loaded data according to [tutorial](https://github.com/PecanProject/pecan/blob/develop/documentation/tutorials/AnalyzeOutput/modelVSdata.Rmd) - Allow SIPNET and DALEC met files and model2netcdf to start or end mid year +- A Pre-release database clean up script that deletes unused/unassosiated entries from the database ### Changed - Clean up directory structure: From 738221ff402b93110843e0dbf7a667278f178d02 Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 28 Sep 2017 10:21:07 -0400 Subject: [PATCH 759/771] Remote: Fix `qstat` job status checking Switching from `system` to `system2` broke this for advanced commands with pipes in them, because these pipes were quoted by `system2` and therefore interpreted as arguments. This reverts to using `system` for local `qsub` calls, and for remote calls, sends the entire command as a single argument. --- base/remote/R/check_qsub_status.R | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/base/remote/R/check_qsub_status.R b/base/remote/R/check_qsub_status.R index 44a141c7711..19689d756b4 100644 --- a/base/remote/R/check_qsub_status.R +++ b/base/remote/R/check_qsub_status.R @@ -14,13 +14,14 @@ qsub_run_finished <- function(run, host, qstat) { } run_id_string <- format(run, scientific = FALSE) check <- gsub("@JOBID", run, qstat) - cmd_list <- strsplit(check, " (?=([^\"']*\"[^\"']*\")*[^\"']*$)", perl = TRUE) - cmd <- cmd_list[[1]] - args <- cmd_list[-1] if (is.localhost(host)) { - out <- system2(cmd, args, stdout = TRUE, stderr = TRUE) + # Need to use `system` to allow commands with pipes + out <- system(command = check, intern = TRUE) } else { - out <- remote.execute.cmd(host = host, cmd = cmd, args = args, stderr = TRUE) + # This uses `system2` under the hood, but that's OK because the entire + # command is passed as a single quoted argument, so the pipes are + # preserved. + out <- remote.execute.cmd(host = host, cmd = check, stderr = TRUE) } if (length(out) > 0 && substring(out, nchar(out) - 3) == "DONE") { @@ -29,4 +30,4 @@ qsub_run_finished <- function(run, host, qstat) { } else { return(FALSE) } -} \ No newline at end of file +} From b346dfb7496a4e6b47b2d8864c363b5a312758ba Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 28 Sep 2017 10:36:54 -0400 Subject: [PATCH 760/771] Remote: Fix `@JOBID@` in qstat check. Add test of qstat. --- base/remote/R/check_qsub_status.R | 2 +- base/remote/tests/testthat/test.check_qsub.R | 15 +++++++++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) create mode 100644 base/remote/tests/testthat/test.check_qsub.R diff --git a/base/remote/R/check_qsub_status.R b/base/remote/R/check_qsub_status.R index 19689d756b4..8fd0d630879 100644 --- a/base/remote/R/check_qsub_status.R +++ b/base/remote/R/check_qsub_status.R @@ -13,7 +13,7 @@ qsub_run_finished <- function(run, host, qstat) { return(FALSE) } run_id_string <- format(run, scientific = FALSE) - check <- gsub("@JOBID", run, qstat) + check <- gsub("@JOBID@", run, qstat) if (is.localhost(host)) { # Need to use `system` to allow commands with pipes out <- system(command = check, intern = TRUE) diff --git a/base/remote/tests/testthat/test.check_qsub.R b/base/remote/tests/testthat/test.check_qsub.R new file mode 100644 index 00000000000..ec493bc7e92 --- /dev/null +++ b/base/remote/tests/testthat/test.check_qsub.R @@ -0,0 +1,15 @@ +library(PEcAn.remote) +library(testthat) + +host <- list(name = "localhost") + +# The `echo` command here is a substitute for what `qstat` would return. +qstat <- 'echo "Job 456 is still running" | grep @JOBID@ || echo "DONE"' + +finished_job <- 123 +unfinished_job <- 456 + +test_that("qstat job status checking works, even with piped commands", { + expect_true(qsub_run_finished(run = finished_job, host = host, qstat = qstat)) + expect_false(qsub_run_finished(run = unfinished_job, host = host, qstat = qstat)) +}) From c3450262cb180f426a0b2559001519aa76f69a3c Mon Sep 17 00:00:00 2001 From: Alexey Shiklomanov Date: Thu, 28 Sep 2017 10:38:22 -0400 Subject: [PATCH 761/771] Remote: Fix progress bar typo. --- base/remote/R/start.model.runs.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/remote/R/start.model.runs.R b/base/remote/R/start.model.runs.R index e9328679b9a..0b4b0d52746 100644 --- a/base/remote/R/start.model.runs.R +++ b/base/remote/R/start.model.runs.R @@ -187,7 +187,7 @@ start.model.runs <- function(settings, write = TRUE, stop.on.error = TRUE) { if (!is_modellauncher) { pbi <- pbi + 1 } - setTxtProgressBar(pb, pb1) + setTxtProgressBar(pb, pbi) } # End check if job finished } # end loop over runs } # end while loop checking runs From 9649564d1fef4f9802dabab67682d302f577b3cb Mon Sep 17 00:00:00 2001 From: "Shawn P. Serbin" Date: Thu, 28 Sep 2017 14:11:20 -0400 Subject: [PATCH 762/771] Update toe check_qsub so that it waits properly --- base/remote/R/check_qsub_status.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/remote/R/check_qsub_status.R b/base/remote/R/check_qsub_status.R index 8fd0d630879..76d744de845 100644 --- a/base/remote/R/check_qsub_status.R +++ b/base/remote/R/check_qsub_status.R @@ -16,7 +16,7 @@ qsub_run_finished <- function(run, host, qstat) { check <- gsub("@JOBID@", run, qstat) if (is.localhost(host)) { # Need to use `system` to allow commands with pipes - out <- system(command = check, intern = TRUE) + out <- system(check, intern = TRUE, ignore.stdout = FALSE, ignore.stderr = FALSE, wait = TRUE) } else { # This uses `system2` under the hood, but that's OK because the entire # command is passed as a single quoted argument, so the pipes are From d36cd0a124925f691e86d226089b103f9a396825 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 30 Sep 2017 10:45:29 -0400 Subject: [PATCH 763/771] Revert "utils no longer depends on settings" 1. I meant to type "settings no longer depends on utils" 2. But that's not true either. Therefore, revert. This reverts commit 5e28d6fee8530e6ae4de42c472fb83e221c104fa. --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 648fef07319..8ae001ab22f 100644 --- a/Makefile +++ b/Makefile @@ -55,7 +55,7 @@ depends = .doc/$(1) .install/$(1) .check/$(1) .test/$(1) $(call depends,base/remote): .install/base/logger $(call depends,base/utils): .install/base/logger .install/base/remote $(call depends,base/db): .install/base/logger .install/base/utils -$(call depends,base/settings): .install/base/logger .install/base/db +$(call depends,base/settings): .install/base/logger .install/base/utils .install/base/db $(call depends,base/visualization): .install/base/logger .install/base/db $(call depends,base/qaqc): .install/base/logger $(call depends,modules/data.atmosphere): .install/base/logger .install/base/utils .install/base/remote From 28404aabfbdbcfe0aa365974f6c34ef9ba8bf74d Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sat, 30 Sep 2017 11:55:01 -0400 Subject: [PATCH 764/771] move workflow dependencies to suggests These packages are all used by PEcAn.utils *only* in functions that will soon be broken out of PEcAn.utils into a new PEcAn.workflow package. Moving the dependencies to Suggests as an initial step, will move functions in a separate PR. --- base/settings/DESCRIPTION | 4 ++-- base/settings/R/check.all.settings.R | 4 ++-- base/utils/DESCRIPTION | 12 ++++++------ tests/testpfts.R | 2 +- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/base/settings/DESCRIPTION b/base/settings/DESCRIPTION index 589e0614fb6..fbb175b7807 100644 --- a/base/settings/DESCRIPTION +++ b/base/settings/DESCRIPTION @@ -14,10 +14,10 @@ Depends: PEcAn.DB Imports: PEcAn.logger, + PEcAn.utils, plyr (>= 1.8.4), lubridate (>= 1.6.0), XML (>= 3.98-1.3) Suggests: - testthat (>= 1.0.2), - PEcAn.utils + testthat (>= 1.0.2) RoxygenNote: 6.0.1 diff --git a/base/settings/R/check.all.settings.R b/base/settings/R/check.all.settings.R index 937fd2ec754..38972a4ebde 100644 --- a/base/settings/R/check.all.settings.R +++ b/base/settings/R/check.all.settings.R @@ -355,7 +355,7 @@ check.settings <- function(settings, force=FALSE) { # Check folder where outputs are written before adding to dbfiles if(is.null(settings$database$dbfiles)) { - settings$database$dbfiles <- full.path("~/.pecan/dbfiles") + settings$database$dbfiles <- PEcAn.utils::full.path("~/.pecan/dbfiles") } else { if (substr(settings$database$dbfiles, 1, 1) != '/'){ PEcAn.logger::logger.warn("settings$database$dbfiles pathname", settings$database$dbfiles, " is invalid\n @@ -813,7 +813,7 @@ check.workflow.settings <- function(settings, dbcon=NULL) { #update workflow if (fixoutdir) { - PEcAn.DB::db.query(paste0("UPDATE workflows SET folder='", full.path(settings$outdir), "' WHERE id=", settings$workflow$id), con=dbcon) + PEcAn.DB::db.query(paste0("UPDATE workflows SET folder='", PEcAn.utils::full.path(settings$outdir), "' WHERE id=", settings$workflow$id), con=dbcon) } return(settings) diff --git a/base/utils/DESCRIPTION b/base/utils/DESCRIPTION index 1d47f34950c..bc8382e8026 100644 --- a/base/utils/DESCRIPTION +++ b/base/utils/DESCRIPTION @@ -19,14 +19,8 @@ Imports: data.table, getPass, ggplot2, - PEcAn.data.atmosphere, - PEcAn.data.land, - PEcAn.DB, - PEcAn.emulator, PEcAn.logger, - PEcAn.priors, PEcAn.remote, - PEcAn.settings, randtoolbox, raster, RCurl, @@ -43,6 +37,12 @@ Imports: PeriodicTable, udunits2 (>= 0.11) Suggests: + PEcAn.data.atmosphere, + PEcAn.data.land, + PEcAn.emulator, + PEcAn.priors, + PEcAn.settings, + PEcAn.DB, MASS, testthat License: FreeBSD + file LICENSE diff --git a/tests/testpfts.R b/tests/testpfts.R index 15821bfe690..91a0adef6c8 100644 --- a/tests/testpfts.R +++ b/tests/testpfts.R @@ -25,7 +25,7 @@ testpft <- function(pftid, pftname, model, dbparam) { }) } -dbparam <- list(dbname="bety", user="bety", password="bety", host="localhost", dbfiles=full.path("testpfts"), write=FALSE, driver="PostgreSQL") +dbparam <- list(dbname="bety", user="bety", password="bety", host="localhost", dbfiles=PEcAn.utils::full.path("testpfts"), write=FALSE, driver="PostgreSQL") pfts <- db.query("SELECT pfts.id AS id, pfts.name AS pft, modeltypes.name AS model FROM pfts, modeltypes WHERE pfts.modeltype_id=modeltypes.id ORDER BY id;", param=dbparam) options(scipen=12) From ebf7f92624410a0eeb83281d9b2260bc820267c1 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Tue, 26 Sep 2017 22:14:17 -0400 Subject: [PATCH 765/771] apparently PEcAn.utils was providing methods load --- base/settings/DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/base/settings/DESCRIPTION b/base/settings/DESCRIPTION index fbb175b7807..ecce0f5a325 100644 --- a/base/settings/DESCRIPTION +++ b/base/settings/DESCRIPTION @@ -11,7 +11,8 @@ LazyData: FALSE Require: hdf5 Description: Contains functions to read PEcAn settings files Depends: - PEcAn.DB + PEcAn.DB, + methods Imports: PEcAn.logger, PEcAn.utils, From 0f18ebc621456c957757d697f6337d4a10144833 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Sun, 1 Oct 2017 20:51:22 -0400 Subject: [PATCH 766/771] utils data now lazy-loaded, so csv not installed with package --- models/biocro/tests/testthat/test.model2netcdf.BIOCRO.R | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/models/biocro/tests/testthat/test.model2netcdf.BIOCRO.R b/models/biocro/tests/testthat/test.model2netcdf.BIOCRO.R index ee12303f8b3..5111876df15 100644 --- a/models/biocro/tests/testthat/test.model2netcdf.BIOCRO.R +++ b/models/biocro/tests/testthat/test.model2netcdf.BIOCRO.R @@ -46,11 +46,7 @@ test_that("dimensions have MsTMIP standard units", { }) test_that("variables have MsTMIP standard units", { - - standard_vars <- read.csv( - file = system.file("data/standard_vars.csv", package = "PEcAn.utils"), - stringsAsFactors = FALSE) - + standard_vars <- PEcAn.utils::standard_vars for (var in vars) { if (var$name %in% standard_vars$Variable.Name) { expect_true(var$units == standard_vars[standard_vars$Variable.Name == var$name, From 6a76caa672d304faddb322709e0b87179af382e8 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Mon, 2 Oct 2017 10:25:58 -0400 Subject: [PATCH 767/771] import ggplot2, formerly provided by PEcAn.utils dependency --- modules/priors/DESCRIPTION | 3 ++- modules/priors/NAMESPACE | 11 +++++++++++ modules/priors/R/plots.R | 3 +++ 3 files changed, 16 insertions(+), 1 deletion(-) diff --git a/modules/priors/DESCRIPTION b/modules/priors/DESCRIPTION index 97280fdee14..b07f98cc2ba 100644 --- a/modules/priors/DESCRIPTION +++ b/modules/priors/DESCRIPTION @@ -13,7 +13,8 @@ LazyData: FALSE Depends: PEcAn.utils Imports: - PEcAn.logger + PEcAn.logger, + ggplot2 Suggests: testthat RoxygenNote: 6.0.1 diff --git a/modules/priors/NAMESPACE b/modules/priors/NAMESPACE index 0119f45854c..b4c0e4c2ae6 100644 --- a/modules/priors/NAMESPACE +++ b/modules/priors/NAMESPACE @@ -10,3 +10,14 @@ export(get.sample) export(pr.dens) export(pr.samp) export(prior.fn) +importFrom(ggplot2,aes) +importFrom(ggplot2,element_blank) +importFrom(ggplot2,element_text) +importFrom(ggplot2,geom_line) +importFrom(ggplot2,geom_point) +importFrom(ggplot2,geom_rug) +importFrom(ggplot2,ggplot) +importFrom(ggplot2,labs) +importFrom(ggplot2,scale_x_continuous) +importFrom(ggplot2,scale_y_continuous) +importFrom(ggplot2,theme_bw) diff --git a/modules/priors/R/plots.R b/modules/priors/R/plots.R index 08bc78afbb9..4622638f501 100644 --- a/modules/priors/R/plots.R +++ b/modules/priors/R/plots.R @@ -32,6 +32,7 @@ plot.prior.density <- function(prior.density, base.plot = NULL, prior.color = "b ##' @param base.plot a ggplot object (grob), created by \code{\link{create.base.plot}} if none provided ##' @return plot with posterior density line added ##' @export +##' @importFrom ggplot2 geom_line aes ##' @author David LeBauer plot.posterior.density <- function(posterior.density, base.plot = NULL) { if (is.null(base.plot)) { @@ -53,6 +54,7 @@ plot.posterior.density <- function(posterior.density, base.plot = NULL) { ##' @param xlim limits for x axis ##' @author David LeBauer ##' @return plot / grob of prior distribution with data used to inform the distribution +##' @importFrom ggplot2 ggplot aes theme_bw scale_x_continuous scale_y_continuous element_blank element_text geom_rug geom_line geom_point priorfig <- function(priordata = NA, priordensity = NA, trait = "", xlim = "auto", fontsize = 18) { if (is.data.frame(priordata)) { colnames(priordata) <- "x" @@ -108,6 +110,7 @@ priorfig <- function(priordata = NA, priordensity = NA, trait = "", xlim = "auto ##' @param fontsize ##' @return plot (grob) object ##' @author David LeBauer +##' @importFrom ggplot2 theme_bw aes scale_x_continuous labs element_text element_blank ##' @export ##' @examples ##' \dontrun{ From 43897b411fc32900fd912d7aa9871258abf7b7d8 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Wed, 4 Oct 2017 23:36:31 -0400 Subject: [PATCH 768/771] more is->inherits --- base/settings/R/MultiSettings.R | 2 +- base/settings/R/Settings.R | 4 ++-- base/settings/R/papply.R | 2 +- base/settings/tests/testthat/test.MultiSettings.class.R | 4 ++-- base/settings/tests/testthat/test.Settings.class.R | 6 +++--- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/base/settings/R/MultiSettings.R b/base/settings/R/MultiSettings.R index 8d6eee09471..31d3b3b0b9d 100644 --- a/base/settings/R/MultiSettings.R +++ b/base/settings/R/MultiSettings.R @@ -37,7 +37,7 @@ as.MultiSettings <- function(x) { ##' @export is.MultiSettings <- function(x) { - return(is(x, "MultiSettings")) + return(inherits(x, "MultiSettings")) } ##' @export diff --git a/base/settings/R/Settings.R b/base/settings/R/Settings.R index 46c617e8b89..7cd168f3856 100644 --- a/base/settings/R/Settings.R +++ b/base/settings/R/Settings.R @@ -15,7 +15,7 @@ ##' @author Ryan Kelly Settings <- function(...) { args <- list(...) - if (length(args) == 1 && is(args[[1]], "Settings")) { + if (length(args) == 1 && inherits(args[[1]], "Settings")) { return(args[[1]]) } @@ -32,5 +32,5 @@ as.Settings <- function(x) { ##' @export is.Settings <- function(x) { - return(is(x, "Settings")) + return(inherits(x, "Settings")) } diff --git a/base/settings/R/papply.R b/base/settings/R/papply.R index 4d6896402f1..410a0a2844c 100644 --- a/base/settings/R/papply.R +++ b/base/settings/R/papply.R @@ -44,7 +44,7 @@ papply <- function(settings, fn, ..., stop.on.error = FALSE) { result.i <- try(fn(settings[[i]], ...), silent = TRUE) - if (!is(result.i, "try-error")) { + if (!inherits(result.i, "try-error")) { ind <- length(result) + 1 if (!is.null(result.i)) { result[[ind]] <- result.i diff --git a/base/settings/tests/testthat/test.MultiSettings.class.R b/base/settings/tests/testthat/test.MultiSettings.class.R index 9fb10d710fc..dff5278d5ad 100644 --- a/base/settings/tests/testthat/test.MultiSettings.class.R +++ b/base/settings/tests/testthat/test.MultiSettings.class.R @@ -36,8 +36,8 @@ test_that("MultiSettings constructor works as expected", { expect_identical(multiSettings[[i]], settings) } - expect_true(is(multiSettings, "list")) - expect_true(is(multiSettings, "MultiSettings")) + expect_true(inherits(multiSettings, "list")) + expect_true(inherits(multiSettings, "MultiSettings")) expect_true(is.MultiSettings(multiSettings)) expect_false(is.MultiSettings(l)) expect_equal(length(class(multiSettings)), 2) diff --git a/base/settings/tests/testthat/test.Settings.class.R b/base/settings/tests/testthat/test.Settings.class.R index 630069b7688..bcf24c2a099 100644 --- a/base/settings/tests/testthat/test.Settings.class.R +++ b/base/settings/tests/testthat/test.Settings.class.R @@ -23,9 +23,9 @@ test_that("Settings constructors work as expected", { expect_identical(settings1, settings3) expect_identical(settings1, settings4) - expect_true(is(settings1, "list")) - expect_true(is(settings1, "SafeList")) - expect_true(is(settings1, "Settings")) + expect_true(inherits(settings1, "list")) + expect_true(inherits(settings1, "SafeList")) + expect_true(inherits(settings1, "Settings")) expect_true(is.Settings(settings1)) expect_false(is.Settings(sl)) expect_false(is.Settings(l)) From 3bcd2be6d43c2995f9ce21c06a763bec512dc401 Mon Sep 17 00:00:00 2001 From: Chris Black Date: Thu, 5 Oct 2017 01:51:36 -0400 Subject: [PATCH 769/771] Supply missing dependencies Note that depending on methods is a workaround for a bug in lubridate (https://github.com/tidyverse/lubridate/issues/499) and we do not use any of its festures directly. --- models/biocro/DESCRIPTION | 2 ++ modules/data.atmosphere/DESCRIPTION | 2 ++ modules/data.land/DESCRIPTION | 3 ++- 3 files changed, 6 insertions(+), 1 deletion(-) diff --git a/models/biocro/DESCRIPTION b/models/biocro/DESCRIPTION index 2ba75ebde70..c5493ddbb08 100644 --- a/models/biocro/DESCRIPTION +++ b/models/biocro/DESCRIPTION @@ -6,6 +6,8 @@ Date: 2017-09-25 Author: David LeBauer, Deepak Jaiswal Maintainer: David LeBauer Description: This module provides functions to link BioCro to PEcAn. +Depends: + methods Imports: PEcAn.logger, PEcAn.remote, diff --git a/modules/data.atmosphere/DESCRIPTION b/modules/data.atmosphere/DESCRIPTION index 15edd34ad75..181f26e5a44 100644 --- a/modules/data.atmosphere/DESCRIPTION +++ b/modules/data.atmosphere/DESCRIPTION @@ -12,6 +12,8 @@ Description: The Predictive Ecosystem Carbon Analyzer (PEcAn) is a scientific integrated into PEcAn. As a standalone package, it provides an interface to access diverse climate data sets. Additional Repositories: http://r-forge.r-project.org/ +Depends: + methods Imports: PEcAn.logger, PEcAn.utils, diff --git a/modules/data.land/DESCRIPTION b/modules/data.land/DESCRIPTION index 201f79c6224..cc528577846 100644 --- a/modules/data.land/DESCRIPTION +++ b/modules/data.land/DESCRIPTION @@ -22,7 +22,8 @@ Imports: udunits2 (>= 0.11), traits, dplyr, - dbplyr + dbplyr, + magrittr Suggests: fields, rgdal, From 2f90f900f26eb3b1274cd4b16c9587229f031e8d Mon Sep 17 00:00:00 2001 From: Betsy Cowdery Date: Thu, 5 Oct 2017 15:29:08 -0400 Subject: [PATCH 770/771] Adding roxygen documentation for function --- base/db/R/utils.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/base/db/R/utils.R b/base/db/R/utils.R index be719136bd0..775ddf804ac 100644 --- a/base/db/R/utils.R +++ b/base/db/R/utils.R @@ -335,6 +335,12 @@ get.id <- function(table, colnames, values, con, create=FALSE, dates=FALSE){ } ##' Convenience function to fix hostname if localhost +##' +##' @title default_hostname +##' @param hostname +##' @return hostname +##' @export +##' @examples default_hostname <- function(hostname) { if (hostname == "localhost") { hostname <- PEcAn.utils::fqdn(); From fb156dc5851d588fa1f90220389392ee2526c832 Mon Sep 17 00:00:00 2001 From: Betsy Cowdery Date: Thu, 5 Oct 2017 16:01:19 -0400 Subject: [PATCH 771/771] Changing the name of utils.R to utils_db.R Because there are were different scripts named utils.R: pecan/base/utils/R/utils.R and pecan/base/db/R/utils.R --- base/db/NAMESPACE | 1 + base/db/R/{utils.R => utils_db.R} | 0 base/db/man/db.close.Rd | 2 +- base/db/man/db.exists.Rd | 2 +- base/db/man/db.getShowQueries.Rd | 2 +- base/db/man/db.open.Rd | 2 +- base/db/man/db.print.connections.Rd | 2 +- base/db/man/db.query.Rd | 2 +- base/db/man/db.showQueries.Rd | 2 +- base/db/man/default_hostname.Rd | 7 +++++-- base/db/man/get.id.Rd | 2 +- 11 files changed, 14 insertions(+), 10 deletions(-) rename base/db/R/{utils.R => utils_db.R} (100%) diff --git a/base/db/NAMESPACE b/base/db/NAMESPACE index fd732f7105e..5b2c4e3b515 100644 --- a/base/db/NAMESPACE +++ b/base/db/NAMESPACE @@ -19,6 +19,7 @@ export(dbfile.input.insert) export(dbfile.insert) export(dbfile.posterior.check) export(dbfile.posterior.insert) +export(default_hostname) export(derive.trait) export(derive.traits) export(dplyr.count) diff --git a/base/db/R/utils.R b/base/db/R/utils_db.R similarity index 100% rename from base/db/R/utils.R rename to base/db/R/utils_db.R diff --git a/base/db/man/db.close.Rd b/base/db/man/db.close.Rd index c34ef04642d..98dfd875206 100644 --- a/base/db/man/db.close.Rd +++ b/base/db/man/db.close.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/utils_db.R \name{db.close} \alias{db.close} \title{Close database connection} diff --git a/base/db/man/db.exists.Rd b/base/db/man/db.exists.Rd index e55f5247ebe..d46f060157a 100644 --- a/base/db/man/db.exists.Rd +++ b/base/db/man/db.exists.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/utils_db.R \name{db.exists} \alias{db.exists} \title{db.exists} diff --git a/base/db/man/db.getShowQueries.Rd b/base/db/man/db.getShowQueries.Rd index 346b1e15f5a..c861bb57cd4 100644 --- a/base/db/man/db.getShowQueries.Rd +++ b/base/db/man/db.getShowQueries.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/utils_db.R \name{db.getShowQueries} \alias{db.getShowQueries} \title{db.getShowQueries} diff --git a/base/db/man/db.open.Rd b/base/db/man/db.open.Rd index 8a76e9e7518..479d1d1dc5d 100644 --- a/base/db/man/db.open.Rd +++ b/base/db/man/db.open.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/utils_db.R \name{db.open} \alias{db.open} \title{Open database connection} diff --git a/base/db/man/db.print.connections.Rd b/base/db/man/db.print.connections.Rd index d19ce0dafab..4f3448b6dfe 100644 --- a/base/db/man/db.print.connections.Rd +++ b/base/db/man/db.print.connections.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/utils_db.R \name{db.print.connections} \alias{db.print.connections} \title{Debug leaked connections} diff --git a/base/db/man/db.query.Rd b/base/db/man/db.query.Rd index 630ac205b10..3a7de2a6e02 100644 --- a/base/db/man/db.query.Rd +++ b/base/db/man/db.query.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/utils_db.R \name{db.query} \alias{db.query} \title{Query database} diff --git a/base/db/man/db.showQueries.Rd b/base/db/man/db.showQueries.Rd index b0b3bd077a7..2b0ee2fb997 100644 --- a/base/db/man/db.showQueries.Rd +++ b/base/db/man/db.showQueries.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/utils_db.R \name{db.showQueries} \alias{db.showQueries} \title{db.showQueries} diff --git a/base/db/man/default_hostname.Rd b/base/db/man/default_hostname.Rd index ce361e1e22c..1c4ac846e54 100644 --- a/base/db/man/default_hostname.Rd +++ b/base/db/man/default_hostname.Rd @@ -1,11 +1,14 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/utils_db.R \name{default_hostname} \alias{default_hostname} -\title{Convenience function to fix hostname if localhost} +\title{default_hostname} \usage{ default_hostname(hostname) } +\value{ +hostname +} \description{ Convenience function to fix hostname if localhost } diff --git a/base/db/man/get.id.Rd b/base/db/man/get.id.Rd index c95e9af09b2..42a9e8e8564 100644 --- a/base/db/man/get.id.Rd +++ b/base/db/man/get.id.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/utils_db.R \name{get.id} \alias{get.id} \title{get.id}