diff --git a/R/CreateInputsModel.GRiwrm.R b/R/CreateInputsModel.GRiwrm.R index d4a266f4ace72d41f03d9a18b3c4ce050b72e0ab..2d215f82a1fc4236e7f46a5f3d42befe9fb1dfc4 100644 --- a/R/CreateInputsModel.GRiwrm.R +++ b/R/CreateInputsModel.GRiwrm.R @@ -481,9 +481,10 @@ hasUngaugedNodes <- function(id, griwrm) { getNodeBasinArea <- function(i, griwrm) { area <- griwrm$area[i] if (!is.na(area)) return(area) - - griwrm <- griwrm[getDiversionRows(griwrm, inverse = TRUE), ] - UpstreamNodeRows <- which(griwrm$down == griwrm$id[i] & !is.na(griwrm$down)) + Diversions <- !is.na(griwrm$model) & griwrm$model == "Diversion" + if (i %in% which(Diversions)) return(NA) + UpstreamNodeRows <- + which(griwrm$down == griwrm$id[i] & !is.na(griwrm$down) & !Diversions) if(length(UpstreamNodeRows) > 0) { upstreamAreas <- sapply(UpstreamNodeRows, getNodeBasinArea, griwrm = griwrm) return(sum(upstreamAreas, na.rm = TRUE)) diff --git a/tests/testthat/test-CreateInputsModel.R b/tests/testthat/test-CreateInputsModel.R index 92e15fdbd619755cb6875ddf4aba5aff478293e4..f8695a76068709e601d1413ed788cacfc7b087c6 100644 --- a/tests/testthat/test-CreateInputsModel.R +++ b/tests/testthat/test-CreateInputsModel.R @@ -202,11 +202,14 @@ test_that("Ungauged node should inherits its FUN_MOD from the downstream gauged }) test_that("Network with Diversion works", { - n_div <- rbind(nodes, data.frame(id = "54029", - down = "54002", - length = 20, - model = "Diversion", - area = NA)) + n_div <- rbind( + data.frame(id = "54029", + down = "54002", + length = 20, + model = "Diversion", + area = NA), + nodes + ) g <- CreateGRiwrm(n_div) Qobs = matrix(-1, nrow = length(DatesR), ncol = 1) colnames(Qobs) = "54029"