diff --git a/R/CreateGRiwrm.R b/R/CreateGRiwrm.R index 38ba017311e46cd145e85ae10ba89cb2e2dbd7d5..91739744c8265494e6323a74d3e1200adc288e4a 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 4d84315fc52b2f628eeb201df6881047c6e30c23..4308f3a005a6af41ec8693264d4abf6fc1a1fff1 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") +})