Merge branch '131-createinputsmodel-don-t-allow-ungauged-donor' into 'dev'

Resolve "CreateInputsModel: Don't allow ungauged donor"

Closes #131

See merge request !97

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

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")
+})