diff --git a/R/CreateInputsModel.GRiwrm.R b/R/CreateInputsModel.GRiwrm.R index d82ad827d917166c077f0304b95fdcf3f8b03038..d3e8b3244fe0977a498c0d2ff3b70388af542e2a 100644 --- a/R/CreateInputsModel.GRiwrm.R +++ b/R/CreateInputsModel.GRiwrm.R @@ -344,7 +344,8 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, DatesR, ..., Qobs, Qmin, Qrel InputsModel$diversionOutlet <- diversionOutlet InputsModel$Qdiv <- -Qobs[, id] InputsModel$Qmin <- Qmin - } else if(np$Reservoir) { + } + if (np$Reservoir) { # If an upstream node is ungauged and the donor is downstream then we are in an ungauged reduced network iUpstreamUngaugedNodes <- which(griwrm$id %in% griwrm$id[UpstreamNodeRows] & griwrm$model == "Ungauged") diff --git a/R/utils.CreateInputsModel.R b/R/utils.CreateInputsModel.R index e94abe2a6bb42171d4d4af0be9245eb118837478..c5a4ab9481327ec8df388d96361540e45ea50f34 100644 --- a/R/utils.CreateInputsModel.R +++ b/R/utils.CreateInputsModel.R @@ -3,23 +3,23 @@ updateQObsQrelease <- function(g, Qobs, Qrelease) { # Fill Qrelease with Qobs warn_ids <- NULL for(id in reservoirIds) { - if (!id %in% names(Qrelease)) { - if (id %in% names(Qobs)) { + if (!id %in% colnames(Qrelease)) { + if (id %in% colnames(Qobs)) { if (!any(g$id == id & (!is.na(g$model) & g$model == "Diversion"))) { if (is.null(Qrelease)) { Qrelease = Qobs[, id, drop = FALSE] } else { Qrelease = cbind(Qrelease, Qobs[, id, drop = FALSE]) } - Qobs <- Qobs[, names(Qobs) != id] + Qobs <- Qobs[, colnames(Qobs) != id, drop = FALSE] warn_ids = c(warn_ids, id) } } } } if (!is.null(warn_ids)) { - warning("Use of the `Qobs` parameter for reservoir releases is depracated\n", - "Processing `Qrelease <- cbind(Qrelease, Qobs[, c(", paste(warn_ids, collapse = "\", `"), "\"))`") + warning("Use of the `Qobs` parameter for reservoir releases is deprecated, please use `Qrelease` instead.\n", + "Processing `Qrelease <- cbind(Qrelease, Qobs[, c(\"", paste(warn_ids, collapse = "\", `"), "\"])`...") } return(list(Qobs = Qobs, Qrelease = Qrelease)) } diff --git a/tests/testthat/helper_1_RunModel.R b/tests/testthat/helper_1_RunModel.R index 6db2a92ac21ebb1bded8fdebe629a116cfa74f1a..67033c4ae943cc65e496bf903bd5425d3f38a72b 100644 --- a/tests/testthat/helper_1_RunModel.R +++ b/tests/testthat/helper_1_RunModel.R @@ -16,6 +16,7 @@ setupRunModel <- runRunModel = TRUE, griwrm = NULL, Qobs2 = NULL, + Qrelease = NULL, IsHyst = FALSE) { data(Severn) @@ -57,6 +58,7 @@ setupRunModel <- suppressWarnings(CreateInputsModel(griwrm, DatesR, Precip, PotEvap, TempMean = TempMean, Qobs = Qobs2, + Qrelease = Qrelease, IsHyst = IsHyst)) # RunOptions diff --git a/tests/testthat/test-CreateSupervisor.R b/tests/testthat/test-CreateSupervisor.R index 3ba3e848c467626651b4147bec5d774bcda3d480..a484f708895b9a646ce0fdf56eeaac600e360bbb 100644 --- a/tests/testthat/test-CreateSupervisor.R +++ b/tests/testthat/test-CreateSupervisor.R @@ -54,7 +54,7 @@ test_that("CreateSupervisor using reservoir and diversion", { )) g <- CreateGRiwrm(nodes) # Add Qobs for the 2 new nodes and create InputsModel - Qobs <- matrix(data = rep(0, 2*length(DatesR)), ncol = 2) + Qobs <- matrix(data = 0, ncol = 2, nrow = length(DatesR)) colnames(Qobs) <- c("54029", "Reservoir") InputsModel <- suppressWarnings( CreateInputsModel(g, DatesR, Precip, PotEvap, Qobs) diff --git a/tests/testthat/test-RunModel_Reservoir.R b/tests/testthat/test-RunModel_Reservoir.R index bd227a0947ed96808fe4934c159e356ca97355c9..76ac4ec7cc87ad99ed2f431e374175c2aa71a494 100644 --- a/tests/testthat/test-RunModel_Reservoir.R +++ b/tests/testthat/test-RunModel_Reservoir.R @@ -98,3 +98,31 @@ test_that("Calibration with ungauged node and reservoir filled by a diversion wo colnames(Qobs2) <- c("Dam", "54095") expect_dam(n_derived_rsrvr, Qobs2) }) + +test_that("Diversion on a reservoir works #146", { + e <- setupRunModel(runInputsModel = FALSE) + for (x in ls(e)) assign(x, get(x, e)) + nodes <- rbind( + n_rsrvr, + data.frame( + id = "Dam", + down = NA, + length = NA, + area = NA, + model = "Diversion" + ) + ) + Qrelease <- data.frame(Dam = rep(3508465, length(DatesR))) + Qobs2 <- Qrelease / 10 + g <- CreateGRiwrm(nodes) + e <- setupRunModel(griwrm = g, + runRunModel = FALSE, + Qobs2 = Qobs2, + Qrelease = Qrelease) + for (x in ls(e)) assign(x, get(x, e)) + Param <- c(ParamMichel[names(ParamMichel) %in% griwrm$id], list(Dam = c(10E6, 1))) + OM <- RunModel(InputsModel, + RunOptions = RunOptions, + Param = Param) + expect_true(max(OM$Dam$Vsim) - min(OM$Dam$Vsim) > 0) +})