diff --git a/R/CreateGRiwrm.R b/R/CreateGRiwrm.R index 9fb0f55ebb2fe3ab98c32651080eb406154c746f..dbe64fa183716fd6bc0a20bd4312d1cd80ffbc83 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 c6d806a97a6a8b8d0d00ff56d66cdf2330b0ba3d..659ad5381dd0f1e26226abdf2f580f8489f05c83 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")) +})