fix(test): Reservoir + Release on same node

Refs #146

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

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

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

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)

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