fix: Ungauged nodes Calibration with a Diversion in the donor

Refs #110

R/Calibration.GRiwrmInputsModel.R

@@ -179,6 +179,19 @@ reduceGRiwrmObj4Ungauged <- function(griwrm, obj) {
   return(obj)
 }
 
+
+#' Set a reduced GRiwrm network for calibration of a sub-network with ungauged
+#' hydrological nodes
+#'
+#' @inheritParams Calibration
+#' @param GaugedId [character] Id of the gauged node
+#' @param OutputsModel *GRiwrmOutputsModel* of the complete network
+#'
+#' @return A [list] containing the following items:
+#' - `InputsModel`: a *GRiwrmInputsModel* of the reduced network
+#' - `RunOptions`: a *GRiwrmRunOptions* of the reduced network
+#' @noRd
+#'
 updateParameters4Ungauged <- function(GaugedId,
                                       InputsModel,
                                       RunOptions,
@@ -187,9 +200,9 @@ updateParameters4Ungauged <- function(GaugedId,
                                       useUpstreamQsim) {
 
   ### Set the reduced network of the basin containing ungauged nodes ###
-  # Select nodes identified with the current node as gauged node
+  # Select nodes identified with the current node as donor gauged node
   griwrm <- attr(InputsModel, "GRiwrm")
-  gDonor <- griwrm[griwrm$donor == GaugedId, ]
+  gDonor <- griwrm[!is.na(griwrm$donor) & griwrm$donor == GaugedId, ]
   # Add upstream nodes for routing upstream flows
   upIds <- griwrm$id[griwrm$down %in% gDonor$id & !griwrm$id %in% gDonor$id]
   g <- rbind(griwrm[griwrm$id %in% upIds, ], gDonor)

R/CreateInputsModel.GRiwrm.R

@@ -258,7 +258,8 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs, Qmin) {
   }
   node <- griwrm[griwrm$id == id,]
 
-  FUN_MOD <- griwrm$model[griwrm$id == griwrm$donor[griwrm$id == id]]
+  g2 <- griwrm[getDiversionRows(griwrm, TRUE), ]
+  FUN_MOD <- g2$model[g2$id == g2$donor[g2$id == id]]
 
   # Set hydraulic parameters
   UpstreamNodeRows <- which(griwrm$down == id & !is.na(griwrm$down))

tests/testthat/test-RunModel_Ungauged.R

 skip_on_cran()
+
+# data set up
+nodes <- loadSevernNodes()
+
+nodes <- nodes[!nodes$id %in% c("54002", "54057", "54095"), ]
+nodes[nodes$id == "54032", c("down", "length")] <- c(NA, NA)
+nodes$model[nodes$id == "54029"] <- "Ungauged"
+
+g <- CreateGRiwrm(nodes)
+e <- setupRunModel(runRunModel = FALSE, griwrm = g)
+for(x in ls(e)) assign(x, get(x, e))
+
+np <- getAllNodesProperties(griwrm)
+
+IC <- CreateInputsCrit(
+  InputsModel,
+  FUN_CRIT = ErrorCrit_KGE2,
+  RunOptions = RunOptions,
+  Obs = Qobs[IndPeriod_Run, np$id[np$RunOff & np$calibration == "Gauged"]],
+  AprioriIds = c("54032" = "54001"),
+  transfo = "sqrt",
+  k = 0.15
+)
+
+CO <- CreateCalibOptions(InputsModel)
+OC <- Calibration(InputsModel, RunOptions, IC, CO)
+
 test_that("RunModel_Ungauged works for intermediate basin with ungauged station", {
-  # data set up
-  nodes <- loadSevernNodes()
+  expect_true(all(sapply(OC, "[[", "CritFinal") > 0.96))
+})
 
-  nodes <- nodes[!nodes$id %in% c("54002", "54057", "54095"), ]
-  nodes[nodes$id == "54032", c("down", "length")] <- c(NA, NA)
-  nodes$model[nodes$id == "54029"] <- "Ungauged"
+test_that("RunModel_Ungauged works with a diversion as donor (#110)", {
+  nodes <- rbind(nodes,
+                 data.frame(id = "54032", down = NA, length = NA, area = NA, model = "Diversion"))
   g <- CreateGRiwrm(nodes)
-
-  e <- setupRunModel(runRunModel = FALSE, griwrm = g)
+  Qobs2 <- matrix(0, ncol = 1, nrow = 11536)
+  colnames(Qobs2) <- "54032"
+  e <- setupRunModel(griwrm = g, runRunModel = FALSE, Qobs2 = Qobs2)
   for(x in ls(e)) assign(x, get(x, e))
-
   np <- getAllNodesProperties(griwrm)
 
   IC <- CreateInputsCrit(
     InputsModel,
     FUN_CRIT = ErrorCrit_KGE2,
     RunOptions = RunOptions,
-    Obs = Qobs[IndPeriod_Run, np$id[np$hydrology == "Gauged"]],
+    Obs = Qobs[IndPeriod_Run, np$id[np$RunOff & np$calibration == "Gauged"], drop = FALSE],
     AprioriIds = c("54032" = "54001"),
     transfo = "sqrt",
     k = 0.15
   )
 
   CO <- CreateCalibOptions(InputsModel)
-  OC <- suppressWarnings(Calibration(InputsModel, RunOptions, IC, CO))
-  expect_true(all(sapply(OC, "[[", "CritFinal") > 0.96))
+  OCdiv <- Calibration(InputsModel, RunOptions, IC, CO)
+  expect_equal(OCdiv, OC)
 })