Implement the join_inputs_design into the current SDA workflows.

base/utils/R/combine_model_netcdf.R

@@ -224,7 +224,7 @@ extract_nc_sda <- function (site.id, start.date, end.date, var.name, nc.path) {
     return(0)
   }
   # grab outputs.
-  res <- ncdf4::ncvar_get(nc, var.name, start = c(time.inds[1], site.ind, 1), count = c(length(time.inds), 1, ensemble.size))
+  res <- ncdf4::ncvar_get(nc, var.name, start = c(site.ind, 1, time.inds[1]), count = c(1, ensemble.size, length(time.inds)))
   # close NC connection.
   ncdf4::nc_close(nc)
   # prepare outputs.

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

@@ -535,6 +535,14 @@ write.config.SIPNET <- function(defaults, trait.values, settings, run.id, inputs
       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)) {
+          # reduce estimates to the pre-defined soil depth.
+          if (!is.null(settings$run$inputs$soil_physics$soil_depth)) {
+            inds.depth <- which(soil_IC_list$dims$depth <= as.numeric(settings$run$inputs$soil_physics$soil_depth))
+            soil_IC_list$dims$depth <- soil_IC_list$dims$depth[inds.depth]
+            for (soil.val in names(soil_IC_list$vals)) {
+              soil_IC_list$vals[[soil.val]] <- soil_IC_list$vals[[soil.val]][inds.depth]
+            }
+          }
           # 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")

modules/assim.sequential/R/Adjustment.R

@@ -15,7 +15,7 @@
 ##' @export
 
 adj.ens<-function(Pf, X, mu.f, mu.a, Pa){
-
+  X <- as.matrix(X)
   S_f  <- svd(Pf)
   L_f  <- S_f$d
   V_f  <- S_f$v
@@ -25,7 +25,7 @@ adj.ens<-function(Pf, X, mu.f, mu.a, Pa){
 
   for(i in seq_len(nrow(X))){
 
-    Z[i,] <- 1/sqrt(L_f) * t(V_f)%*%(X[i,]-mu.f)
+    Z[i,] <- 1/sqrt(L_f) * t(V_f)%*%matrix(X[i,]-mu.f) %>% t
 
   }
   Z[is.na(Z)]<-0

modules/assim.sequential/R/Analysis_sda_block.R

@@ -21,11 +21,12 @@ analysis_sda_block <- function (settings, block.list.all, X, obs.mean, obs.cov,
   # grab cores from settings.
   cores <- as.numeric(settings$state.data.assimilation$batch.settings$general.job$cores)
   # if we didn't assign number of CPUs in the settings.
-  if (is.null(cores)) {
-    cores <- parallel::detectCores() - 1
-    # if we only have one CPU.
-    if (cores < 1) cores <- 1
+  if (length(cores) == 0 | is.null(cores)) {
+    cores <- parallel::detectCores()
   }
+  cores <- cores - 1
+  # if we only have one CPU.
+  if (cores < 1) cores <- 1
   #convert from vector values to block lists.
   if ("try-error" %in% class(try(block.results <- build.block.xy(settings = settings, 
                                                                  block.list.all = block.list.all, 
@@ -84,7 +85,7 @@ analysis_sda_block <- function (settings, block.list.all, X, obs.mean, obs.cov,
   PEcAn.logger::logger.info("Completed!")
 
   #convert from block lists to vector values.
-  if ("try-error" %in% class(try(V <- block.2.vector(block.list.all[[t]], X, H)))) {
+  if ("try-error" %in% class(try(V <- block.2.vector(block.list.all[[t]], X, H, settings$state.data.assimilation$adjustment)))) {
     PEcAn.logger::logger.severe("Something wrong within the block.2.vector function.")
     return(0)
   }
@@ -571,6 +572,14 @@ update_q <- function (block.list.all, t, nt, aqq.Init = NULL, bqq.Init = NULL, M
   if (is.null(MCMC_dat)) {
     #loop over blocks
     if (t == 1) {
+      fresh.run <- TRUE
+    } else if (t > 1 & is.null(block.list.all[[t-1]])) {
+      fresh.run <- TRUE
+    } else {
+      fresh.run <- FALSE
+    }
+    #if t=1 or if it's a fresh run.
+    if (fresh.run) {
       for (i in seq_along(block.list)) {
         nvar <- length(block.list[[i]]$data$muf)
         nobs <- length(block.list[[i]]$data$y.censored)
@@ -596,7 +605,7 @@ update_q <- function (block.list.all, t, nt, aqq.Init = NULL, bqq.Init = NULL, M
           block.list[[i]]$data$bq <- block.list[[i]]$bqq[t]
         }
       }
-    } else if (t > 1) {
+    } else {
       if (!is.null(block.list.all.pre)) {
         block.list.pre <- block.list.all.pre[[t - 1]]
       } else {
@@ -643,31 +652,34 @@ update_q <- function (block.list.all, t, nt, aqq.Init = NULL, bqq.Init = NULL, M
 ##' @param block.list  lists of blocks generated by the `build.block.xy` function.
 ##' @param X A matrix contains ensemble forecasts.
 ##' @param H H index created by the `construct_nimble_H` function.
+##' @param adjustment logical variable determine if we want to adjust the analysis ensembles based on likelihood.
 ##' 
 ##' @return It returns a list of analysis results by MCMC sampling.
-block.2.vector <- function (block.list, X, H) {
+block.2.vector <- function (block.list, X, H, adjustment) {
+  # initialize site.ids, mu.a, mu.f, pa, and pf.
   site.ids <- attributes(X)$Site
   mu.f <- mu.a <- c()
   Pf <- Pa <- matrix(0, length(site.ids), length(site.ids))
   analysis <- X
+  # loop over blocks.
   for (L in block.list) {
+    # grab index for the locations within the current block.
     ind <- c()
     for (id in L$site.ids) {
       ind <- c(ind, which(site.ids == id))
     }
-    #convert mu.f and pf
-    mu.a[ind] <- mu.f[ind] <- L$update$mufa
-    Pa[ind, ind] <- Pf[ind, ind] <- L$update$pfa
-    # MVN sample based on block.
-    sample <- as.data.frame(mvtnorm::rmvnorm(nrow(X), 
-                                             L$update$mufa, 
-                                             L$update$pfa, 
-                                             method = "svd"))
+    # grab mu.a, mu.f, pa, and pf from the MCMC updates.
+    mu.a[ind] <- L$update$mufa
+    Pa[ind, ind] <- L$update$pfa
+    mu.f[ind] <- L$data$muf
+    Pf[ind, ind] <- L$data$pf
+    # adjustment.
+    if (as.logical(adjustment)) {
+      sample <- as.data.frame(adj.ens(Pf[ind, ind], X[,ind], mu.f[ind], mu.a[ind], Pa[ind, ind]))
+    } else {
+      sample <- as.data.frame(mvtnorm::rmvnorm(nrow(X), L$update$mufa, L$update$pfa, method = "svd"))
+    }
     analysis[,ind] <- sample
-    #convert mu.a and pa
-    ind <- intersect(ind, H$H.ind)
-    mu.a[ind] <- L$update$mua
-    Pa[ind, ind] <- L$update$pa
   }
   return(list(mu.f = mu.f,
               Pf = Pf,