Merge pull request #3263 from DongchenZ/develop

Fix bug for building H when there is any site that has zero observation.
PecanProject · Feb 25, 2024 · fef3a49 · fef3a49
2 parents 0040347 + 8614011
commit fef3a49
Show file tree

Hide file tree

Showing 2 changed files with 25 additions and 12 deletions.
diff --git a/modules/assim.sequential/R/Analysis_sda_block.R b/modules/assim.sequential/R/Analysis_sda_block.R
@@ -130,6 +130,8 @@ build.block.xy <- function(settings, block.list.all, X, obs.mean, obs.cov, t) {
   }
 
   #Handle observation
+  #observation number per site
+  obs_per_site <- purrr::map_int(obs.mean[[t]], length)
   #if we do free run or the current obs.mean are all NULL.
   if (as.logical(settings$state.data.assimilation$free.run) | all(is.null(unlist(obs.mean[[t]])))) {
     obs.mean[[t]] <- vector("list", length(site.ids)) %>% `names<-`(site.ids)
@@ -167,16 +169,24 @@ build.block.xy <- function(settings, block.list.all, X, obs.mean, obs.cov, t) {
       } else {y.ind[i] <- y.censored[i] <- 0}
     }
     #create H
-    H <- construct_nimble_H(site.ids = site.ids,
-                            var.names = var.names,
-                            obs.t = obs.mean[[t]],
-                            pft.path = settings[[1]]$run$inputs$pft.site$path,
-                            by = "block_pft_var")
+    # if there is any site that has zero observation.
+    if (any(obs_per_site == 0)) {
+      #name matching between observation names and state variable names.
+      f.2.y.ind <- obs.mean[[t]] %>% 
+        purrr::map(\(x)which(var.names %in% names(x))) %>% 
+        base::unlist %>% 
+        base::unique
+      H <- list(ind = f.2.y.ind %>% purrr::map(function(start){
+        seq(start, length(site.ids) * length(var.names), length(var.names))
+      }) %>% unlist() %>% sort)
+    } else {
+      H <- construct_nimble_H(site.ids = site.ids,
+                              var.names = var.names,
+                              obs.t = obs.mean[[t]],
+                              pft.path = settings[[1]]$run$inputs$pft.site$path,
+                              by = "block_pft_var")
+    }
   }
-  #observation number per site
-  obs_per_site <- obs.mean[[t]] %>% 
-    purrr::map(function(site.obs){length(site.obs)}) %>% 
-    unlist()
 
   #start the blocking process
   #should we consider interactions between sites?
@@ -266,7 +276,10 @@ build.block.xy <- function(settings, block.list.all, X, obs.mean, obs.cov, t) {
       # H
       if (any(is.na(y.block))) {
         block.h <- matrix(0, 1, length(ids)*length(var.names))#matrix(1, 1, length(var.names))
-        f.2.y.ind <- which(grepl(unique(names(unlist(obs.mean[[t]] %>% purrr::set_names(NULL)))), var.names, fixed = T))
+        f.2.y.ind <- obs.mean[[t]] %>% 
+          purrr::map(\(x)which(var.names %in% names(x))) %>% 
+          base::unlist %>% 
+          base::unique
         seq.ind <- f.2.y.ind %>% purrr::map(function(start){
           seq(start, dim(block.h)[2], length(var.names))
         }) %>% unlist()

diff --git a/modules/data.remote/R/MODIS_LAI_prep.R b/modules/data.remote/R/MODIS_LAI_prep.R
@@ -76,9 +76,9 @@ MODIS_LAI_prep <- function(site_info, time_points, outdir = NULL, search_window
       if (! "try-error" %in% class(try(mean <- MODISTools::mt_dates(product = "MOD11A2",
                                                                     lat = s$lat,
                                                                     lon = s$lon)))) {
-        return(TRUE)
-      } else {
         return(FALSE)
+      } else {
+        return(TRUE)
       }
     }, .progress = T) %>% unlist
   new_site_info <- new_site_info %>% purrr::map(function(x)x[-which(non.reachable.ind)])