From 57ff61e00acff667aa4c42573e3e37995a63cf9d Mon Sep 17 00:00:00 2001
From: David <david.dorchies@inrae.fr>
Date: Wed, 31 Jul 2024 11:26:08 +0200
Subject: [PATCH] feat(CreateGRiwrm): add checks on nature of donor nodes
Also improve error messages by using nodeError function.
Refs #131
---
R/CreateGRiwrm.R | 23 +++++++++++++++--------
tests/testthat/test-createGRiwrm.R | 18 +++++++++++++++++-
2 files changed, 32 insertions(+), 9 deletions(-)
diff --git a/R/CreateGRiwrm.R b/R/CreateGRiwrm.R
index 38ba017..9173974 100644
--- a/R/CreateGRiwrm.R
+++ b/R/CreateGRiwrm.R
@@ -166,14 +166,21 @@ checkNetworkConsistency <- function(db) {
stop("At least one node must be a network downstream node",
" specified by 'down = NA'")
}
- sapply(db$down[!is.na(db$down)], function(x) {
- if (!(x %in% db$id)) {
- stop("The 'down' id ", x, " is not found in the 'id' column")
+ lapply(which(!is.na(db$down)), function(i) {
+ node <- db[i, ]
+ if (!(node$down %in% db$id)) {
+ nodeError(node, "The 'down' id ", node$down, " is not found in the 'id' column")
}
})
- sapply(db$donor[!is.na(db$donor)], function(x) {
- if (!(x %in% db$id)) {
- stop("The 'donor' id ", x, " is not found in the 'id' column")
+ lapply(which(!is.na(db$donor)), function(i) {
+ node <- db[i, ]
+ if (!(node$donor %in% db$id)) {
+ nodeError(node, "The 'donor' id ", node$donor, " is not found in the 'id' column")
+ }
+ donor_model <- db$model[db$id == node$donor]
+ if (is.na(donor_model) || donor_model %in% c("RunModel_Reservoir", "Ungauged")) {
+ nodeError(node, "The 'donor' node ", node$donor, " must be an hydrological model",
+ " (Found model = '", donor_model, "')")
}
})
db3 <- db2[!is.na(db2$model), ]
@@ -223,8 +230,8 @@ displayNodeDetails <- function(node) {
sep = "\n")
}
-nodeError <- function(node, s) {
- stop(displayNodeDetails(node), "\n", s)
+nodeError <- function(node, ...) {
+ stop(displayNodeDetails(node), "\n", ...)
}
#' Get the Id of the nearest gauged model at downstream
diff --git a/tests/testthat/test-createGRiwrm.R b/tests/testthat/test-createGRiwrm.R
index 4d84315..4308f3a 100644
--- a/tests/testthat/test-createGRiwrm.R
+++ b/tests/testthat/test-createGRiwrm.R
@@ -109,7 +109,8 @@ test_that("Several Diversion on same node should raise error", {
test_that("Upstream donor works", {
nupd <- loadSevernNodes()
nupd$donor[nupd$id == "54032"] <- "Wrong_node"
- expect_error(CreateGRiwrm(nupd))
+ expect_error(CreateGRiwrm(nupd),
+ regexp = "The 'donor' id Wrong_node is not found in the 'id' column")
nupd$donor[nupd$id == "54032"] <- "54001"
nupd$model[nupd$id == "54032"] <- "Ungauged"
g <- CreateGRiwrm(nupd)
@@ -119,3 +120,18 @@ test_that("Upstream donor works", {
g <- CreateGRiwrm(nupd)
expect_equal(g$donor[g$id == "54002"], "54029")
})
+
+test_that("Donor node can't be Ungauged nor DirectInjection nor Reservoir", {
+ n <- loadSevernNodes()
+ n$model[n$id == "54001"] <- "Ungauged"
+ n$donor[n$id == "54001"] <- "54032"
+ n$model[n$id == "54032"] <- "Ungauged"
+ expect_error(CreateGRiwrm(n),
+ regexp = "must be an hydrological model")
+ n$model[n$id == "54032"] <- NA
+ expect_error(CreateGRiwrm(n),
+ regexp = "must be an hydrological model")
+ n$model[n$id == "54032"] <- "RunModel_Reservoir"
+ expect_error(CreateGRiwrm(n),
+ regexp = "must be an hydrological model")
+})
--
GitLab