Add codes to extract SoilGrids soil texture data and derive ensemble …

docker/depends/pecan_package_dependencies.csv

@@ -41,6 +41,7 @@
 "doParallel","*","modules/data.atmosphere","Suggests",FALSE
 "doParallel","*","modules/data.remote","Imports",FALSE
 "doSNOW","*","base/remote","Suggests",FALSE
+"doSNOW","*","modules/data.land","Imports",FALSE
 "doSNOW","*","modules/data.remote","Suggests",FALSE
 "dplR","*","modules/data.land","Imports",FALSE
 "dplyr","*","base/qaqc","Imports",FALSE
@@ -65,6 +66,7 @@
 "exactextractr","*","modules/assim.sequential","Suggests",FALSE
 "foreach","*","base/remote","Imports",FALSE
 "foreach","*","modules/data.atmosphere","Suggests",FALSE
+"foreach","*","modules/data.land","Imports",FALSE
 "foreach","*","modules/data.remote","Imports",FALSE
 "fs","*","base/db","Imports",FALSE
 "fs","*","modules/data.land","Imports",FALSE
@@ -187,6 +189,7 @@
 "mclust","*","modules/rtm","Suggests",FALSE
 "MCMCpack","*","modules/allometry","Imports",FALSE
 "MCMCpack","*","modules/assim.batch","Imports",FALSE
+"MCMCpack","*","modules/data.land","Imports",FALSE
 "MCMCpack","*","modules/emulator","Imports",FALSE
 "methods","*","base/db","Imports",FALSE
 "methods","*","base/settings","Depends",FALSE

models/sipnet/R/write.configs.SIPNET.R

@@ -20,7 +20,6 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs
 
   ### WRITE *.clim
   template.clim <- settings$run$inputs$met$path  ## read from settings
-
   if (!is.null(inputs)) {
     ## override if specified in inputs
     if ("met" %in% names(inputs)) {
@@ -490,20 +489,48 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs
     }
   } ## end loop over PFTS
   ####### end parameter update
-  #working on reading soil file (only working for 1 soil file)
-  if(length(settings$run$inputs$soilinitcond$path)==1){
-    soil_IC_list <- PEcAn.data.land::pool_ic_netcdf2list(settings$run$inputs$soilinitcond$path)
-    #SoilWHC and LitterWHC
-    if("volume_fraction_of_water_in_soil_at_saturation"%in%names(soil_IC_list$vals)){
-      #SoilWHC
-      param[which(param[, 1] == "soilWHC"), 2] <- mean(unlist(soil_IC_list$vals["volume_fraction_of_water_in_soil_at_saturation"]))*100
-
-      #LitterWHC
-      #param[which(param[, 1] == "litterWHC"), 2] <- unlist(soil_IC_list$vals["volume_fraction_of_water_in_soil_at_saturation"])[1]*100
+  #working on reading soil file
+  if (length(settings$run$inputs$soil_physics$path) > 0) {
+    template.soil_physics <- settings$run$inputs$soil_physics$path  ## read from settings
+
+    if (!is.null(inputs)) {
+      ## override if specified in inputs
+      if ("soil_physics" %in% names(inputs)) {
+        template.soil_physics <- inputs$soil_physics$path
+      }
     }
-    if("soil_hydraulic_conductivity_at_saturation"%in%names(soil_IC_list$vals)){
-      #litwaterDrainrate
-      param[which(param[, 1] == "litWaterDrainRate"), 2] <- unlist(soil_IC_list$vals["soil_hydraulic_conductivity_at_saturation"])[1]*100/(3600*24)
+
+    if (length(template.soil_physics)!=1) {
+      PEcAn.logger::logger.warn(
+        paste0("No single soil physical parameter file was found for ",
+               run.id))
+    } else {
+      soil_IC_list <- PEcAn.data.land::pool_ic_netcdf2list(template.soil_physics)
+      #SoilWHC
+      if ("volume_fraction_of_water_in_soil_at_saturation" %in% names(soil_IC_list$vals)) {
+        #if depth is provided in the file
+        if ("depth" %in% names(soil_IC_list$dims)) {
+          # Calculate the thickness of soil layers based on the assumption that the depth values are at bottoms and the first layer top is at 0
+          thickness<-c(soil_IC_list$dims$depth[1],diff(soil_IC_list$dims$depth))
+          thickness<-PEcAn.utils::ud_convert(thickness, "m", "cm")
+          # Calculate the soilWHC for the whole soil profile in cm
+          soilWHC_total <- sum(unlist(soil_IC_list$vals["volume_fraction_of_water_in_soil_at_saturation"])*thickness)
+          if (thickness[1]<=10) {
+            #LitterWHC in cm, assuming the litter depth is within the top 10 cm
+            param[which(param[, 1] == "litterWHC"), 2] <- unlist(soil_IC_list$vals["volume_fraction_of_water_in_soil_at_saturation"])[1]*thickness[1]
+          }
+        } else {
+          #if no depth/thickness is provided
+          PEcAn.logger::logger.warn("No depth info was found in the soil file. Will use the default or user-specified soil depth")
+          thickness <- 100 #assume the default soil depth is the plant rooting depth of 100 cm, or use the user-specified value
+          soilWHC_total <- soil_IC_list$vals["volume_fraction_of_water_in_soil_at_saturation"]*thickness
+        }
+        param[which(param[, 1] == "soilWHC"), 2] <- soilWHC_total
+      }
+      if ("soil_hydraulic_conductivity_at_saturation" %in% names(soil_IC_list$vals)) {
+         #litwaterDrainrate in cm/day
+         param[which(param[, 1] == "litWaterDrainRate"), 2] <- PEcAn.utils::ud_convert(unlist(soil_IC_list$vals["soil_hydraulic_conductivity_at_saturation"])[1], "m s-1", "cm day-1")
+       }
     }
   }
   if (!is.null(IC)) {

modules/assim.sequential/R/metSplit.R

@@ -31,18 +31,19 @@ metSplit <- function(conf.settings, inputs, settings, model, no_split = FALSE, o
     furrr::future_pmap(list(conf.settings %>% `class<-`(c("list")), inputs, model), function(settings, inputs, model) {
       # Loading the model package - this is required bc of the furrr
       library(paste0("PEcAn.",model), character.only = TRUE)
-
-      inputs.split <- list()
+
+      #Split function only works for met in inputs
+      inputs.split <- inputs
       if (!no_split) {
         for (i in seq_len(nens)) {
           #---------------- model specific split inputs
-          inputs.split$samples[i] <- do.call(
+          inputs.split$met$samples[[i]] <- do.call(
             my.split_inputs,
             args = list(
               settings = settings,
               start.time = (lubridate::ymd_hms(start.time, truncated = 3) + lubridate::second(lubridate::hms("00:00:01"))),
               stop.time =   lubridate::ymd_hms(stop.time, truncated = 3),
-              inputs = inputs$samples[[i]])
+              inputs = inputs$met$samples[[i]])
           )
         }
       } else{

modules/assim.sequential/R/sda.enkf_MultiSite.R

@@ -355,17 +355,47 @@ sda.enkf.multisite <- function(settings,
       #reformatting params
       new.params <- sda_matchparam(settings, ensemble.samples, site.ids, nens)
     }
-      #sample met ensemble members
-      #TODO: incorporate Phyllis's restart work
-      #      sample all inputs specified in the settings$ensemble not just met
-      inputs <- PEcAn.settings::papply(conf.settings,function(setting) {
-        PEcAn.uncertainty::input.ens.gen(
-          settings = setting,
-          input = "met",
-          method = setting$ensemble$samplingspace$met$method,
-          parent_ids = NULL 
-        )
-       })
+
+
+  #TODO: incorporate Phyllis's restart work
+  #sample all inputs specified in the settings$ensemble
+  #now looking into the xml
+  samp <- conf.settings$ensemble$samplingspace
+  #finding who has a parent
+  parents <- lapply(samp,'[[', 'parent')
+  #order parents based on the need of who has to be first
+  order <- names(samp)[lapply(parents, function(tr) which(names(samp) %in% tr)) %>% unlist()] 
+  #new ordered sampling space
+  samp.ordered <- samp[c(order, names(samp)[!(names(samp) %in% order)])]
+  #performing the sampling
+  inputs <- vector("list", length(conf.settings))
+  #for the tags specified in the xml, do the sampling for a random site and then replicate the same sample ids for the remaining sites for each ensemble member 
+  for (i in seq_along(samp.ordered)) {
+    random_site <- sample(1:length(conf.settings),1)
+    if (is.null(inputs[[random_site]])) {
+      inputs[[random_site]] <- list() 
+    }
+    input_tag<-names(samp.ordered)[i]
+    #call the function responsible for generating the ensemble for the random site
+    inputs[[random_site]][[input_tag]] <- PEcAn.uncertainty::input.ens.gen(settings=conf.settings[[random_site]],
+                                                        input=input_tag,
+                                                        method=samp.ordered[[i]]$method,
+                                                        parent_ids=NULL)
+    #replicate the same ids for the remaining sites
+    for (s in seq_along(conf.settings)) {
+      if (s!= random_site) {
+        if (is.null(inputs[[s]])) {
+          inputs[[s]] <- list() 
+        }
+        input_path <- conf.settings[[s]]$run$inputs[[tolower(input_tag)]]$path
+        inputs[[s]][[input_tag]]$ids<-inputs[[random_site]][[input_tag]]$ids
+        inputs[[s]][[input_tag]]$samples<- input_path[inputs[[random_site]][[input_tag]]$ids]
+      }
+    }
+  }
+
+
+
   ###------------------------------------------------------------------------------------------------###
   ### loop over time                                                                                 ###
   ###------------------------------------------------------------------------------------------------###
@@ -380,7 +410,7 @@ sda.enkf.multisite <- function(settings,
         #for next time step split the met if model requires
         #-Splitting the input for the models that they don't care about the start and end time of simulations and they run as long as their met file.
         inputs.split <- metSplit(conf.settings, inputs, settings, model, no_split = FALSE, obs.times, t, nens, restart_flag = FALSE, my.split_inputs)
-        
+
         #---------------- setting up the restart argument for each site separately and keeping them in a list
         restart.list <-
           furrr::future_pmap(list(out.configs, conf.settings %>% `class<-`(c("list")), params.list, inputs.split),
@@ -412,9 +442,8 @@ sda.enkf.multisite <- function(settings,
         X <- X
       }else{
         if (control$debug) browser()
-        out.configs <- conf.settings %>%
-          `class<-`(c("list")) %>%
-          furrr::future_map2(restart.list, function(settings, restart.arg) {
+
+        out.configs <-furrr::future_pmap(list(conf.settings %>% `class<-`(c("list")),restart.list, inputs), function(settings, restart.arg, inputs) {
             # Loading the model package - this is required bc of the furrr
             library(paste0("PEcAn.",settings$model$type), character.only = TRUE)
             # wrtting configs for each settings - this does not make a difference with the old code
@@ -425,6 +454,7 @@ sda.enkf.multisite <- function(settings,
               model = settings$model$type,
               write.to.db = settings$database$bety$write,
               restart = restart.arg,
+              samples=inputs,
               rename = TRUE
             )
           }) %>%
@@ -767,4 +797,5 @@ sda.enkf.multisite <- function(settings,
 #    }
       ## MCD: I commented the above "if" out because if you are restarting from a previous forecast, this might delete the files in that earlier folder
   } ### end loop over time
-} # sda.enkf
+} # sda.enkf
+

modules/assim.sequential/inst/MultiSite-Exs/SDA/Create_Multi_settings.R

@@ -229,7 +229,8 @@ template <- PEcAn.settings::Settings(list(
   ###########################################################################
   ensemble = structure(list(size = 25, variable = "NPP", 
                             samplingspace = structure(list(
-                              parameters = structure(list(method = "lhc")),
+                              parameters = structure(list(method = "sampling")),
+                              soil_physics = structure(list(method = "sampling")),
                               met = structure(list(method = "sampling"))
                             ))
   )),

modules/data.land/DESCRIPTION

@@ -25,14 +25,17 @@ Depends: R (>= 3.5.0)
 Imports:
     coda,
     curl,
+    doSNOW,
     dplyr,
     dplR,
+    foreach,
     fs,
     future,
     furrr,
     httr,
     lubridate,
     magrittr,
+    MCMCpack,
     mvtnorm,
     ncdf4 (>= 1.15),
     neonUtilities,

modules/data.land/NAMESPACE

@@ -54,6 +54,7 @@ export(soil2netcdf)
 export(soil_params)
 export(soil_process)
 export(soilgrids_soilC_extract)
+export(soilgrids_texture_extraction)
 export(subset_layer)
 export(to.Tag)
 export(to.TreeCode)

modules/data.land/R/extract_soil_nc.R

@@ -348,6 +348,7 @@ extract_soil_nc <- function(in.file,outdir,lat,lon){
 #'  * `soil_thermal_conductivity_at_saturation`
 #'  * `soil_thermal_capacity`
 #'  * `soil_albedo`
+
 #'
 #' @param varname character vector. See details
 #'
@@ -383,6 +384,7 @@ soil.units <- function(varname = NA){
                                       "soil_thermal_conductivity_at_saturation","W m-1 K-1", 
                                       "soil_thermal_capacity","J kg-1 K-1",
                                       "soil_albedo","1"
+
   ),
   ncol=2,byrow = TRUE))
   colnames(variables) <- c('var','unit')