From 485be9f0e72e135197eedefc0dbc407f05ee902a Mon Sep 17 00:00:00 2001
From: David <david.dorchies@inrae.fr>
Date: Fri, 24 May 2024 16:53:50 +0200
Subject: [PATCH] fix(getNodeRanking): wrong sorting between sibling and
upstream ungauged with same donor
- fix & test
Refs #155
---
R/getNodeRanking.R | 5 ++++-
tests/testthat/test-getNodeRanking.R | 11 +++++++++++
2 files changed, 15 insertions(+), 1 deletion(-)
diff --git a/R/getNodeRanking.R b/R/getNodeRanking.R
index e4c6cf4..792c081 100644
--- a/R/getNodeRanking.R
+++ b/R/getNodeRanking.R
@@ -40,7 +40,10 @@ getNodeRanking <- function(griwrm) {
# Check if upstream nodes have already been processed
immediate_upstream_nodes <- g$id[!is.na(g$down) & g$down %in% g2$id]
immediate_upstream_nodes <- immediate_upstream_nodes[!immediate_upstream_nodes %in% g2$id]
- if (all(immediate_upstream_nodes %in% r)) {
+ if (all(immediate_upstream_nodes %in% r) &&
+ (upDonor %in% r || isNodeDownstream(g2, upId, upDonor))) {
+ areNodesUpstreamDonor <- sapply(g2$id, function(id) isNodeDownstream(g2, id, upDonor))
+ g2 <- g2[upDonor %in% r | g2$id == upDonor | areNodesUpstreamDonor, ]
g2$donor <- g2$id
ungaugedIds <- getNodeRanking(g2)
r <- c(r, ungaugedIds)
diff --git a/tests/testthat/test-getNodeRanking.R b/tests/testthat/test-getNodeRanking.R
index 5019347..18ace82 100644
--- a/tests/testthat/test-getNodeRanking.R
+++ b/tests/testthat/test-getNodeRanking.R
@@ -55,3 +55,14 @@ test_that("Impossible case detected: ungauged node with diversion to an upstream
area = NA))
expect_error(CreateGRiwrm(nodes_div))
})
+
+test_that("donor of ungauged cluster is processed before sibling ungauged nodes (#155)", {
+ n155 <- data.frame(id = c("UngSib", "UngUp", "Donor", "Down"),
+ down = c("Down", "Donor", "Down", NA),
+ length = c(rep(1, 3), NA),
+ model = c("Ungauged", "Ungauged", "RunModel_GR4J", "RunModel_GR4J"),
+ area = rep(1,4),
+ donor = c("Donor", NA, NA, NA))
+ g155 <- CreateGRiwrm(n155)
+ expect_equal(getNodeRanking(g155), c("UngUp", "Donor", "UngSib", "Down"))
+})
--
GitLab