From 4247870702f63f5b37920f1196a9dee9600dbfd7 Mon Sep 17 00:00:00 2001
From: David <david.dorchies@inrae.fr>
Date: Fri, 5 Apr 2024 11:47:07 +0200
Subject: [PATCH] fix: Reservoir with Diversion in ungauged cluster should
return a single donor
Refs #146
---
R/CreateGRiwrm.R | 11 ++++++++---
tests/testthat/test-createGRiwrm.R | 10 ++++++++++
2 files changed, 18 insertions(+), 3 deletions(-)
diff --git a/R/CreateGRiwrm.R b/R/CreateGRiwrm.R
index 9fb0f55..dbe64fa 100644
--- a/R/CreateGRiwrm.R
+++ b/R/CreateGRiwrm.R
@@ -319,10 +319,15 @@ refineReservoirDonor <- function(i, griwrm) {
return(griwrm$donor[i])
}
upIds <- griwrm$id[!is.na(griwrm$down) & griwrm$down == griwrm$id[i]]
- if (any(!is.na(griwrm$model[griwrm$id %in% upIds]) &
- griwrm$model[griwrm$id %in% upIds] == "Ungauged")) {
+ g_up <- griwrm[griwrm$id %in% upIds, ]
+ if (any(!is.na(g_up$model) & g_up$model == "Ungauged")) {
# Upstream ungauged nodes found: keep downstream donor
- return(griwrm$donor[i])
+ donor <- unique(g_up$donor[!is.na(g_up$model) & g_up$model == "Ungauged"])
+ if (length(donor) > 1) {
+ stop("Ungauged nodes located upstream the node '", id,
+ "' cannot have different donors")
+ }
+ return(donor)
} else {
# No upstream ungauged nodes: Reservoir is its own donor!
return(griwrm$id[i])
diff --git a/tests/testthat/test-createGRiwrm.R b/tests/testthat/test-createGRiwrm.R
index c6d806a..659ad53 100644
--- a/tests/testthat/test-createGRiwrm.R
+++ b/tests/testthat/test-createGRiwrm.R
@@ -83,3 +83,13 @@ test_that("Reservoir supplied by derivated ungauged node should have the first d
g <- CreateGRiwrm(n_derived_rsrvr) # Network provided by helper_RunModel_Reservoir.R
expect_equal(g$donor[g$id == "Dam"], "54001")
})
+
+test_that("Reservoir and Diversion on reservoir should have same donor", {
+ nodes <- n_rsrvr
+ nodes[nodes$id == "Dam", c("down", "length")] <- NA
+ nodes$model[nodes$id == "54095"] <- "Ungauged"
+ nodes <- rbind(nodes,
+ data.frame(id = "Dam", down = "54001", length = 42, area = NA, model = "Diversion"))
+ g <- CreateGRiwrm(nodes)
+ expect_equal(g$donor[g$id == "Dam"], c("54001", "54001"))
+})
--
GitLab