Merge branch...

Merge branch '110-ungauged-node-incorrect-definition-of-donor-with-reservoir-and-bug-with-diversion-nodes' into 'dev'

Resolve "Ungauged node: incorrect definition of donor with Reservoir and bug with Diversion nodes"

Closes #111 and #110

See merge request !53

R/Calibration.GRiwrmInputsModel.R

@@ -48,6 +48,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
       l  <- updateParameters4Ungauged(id,
                                       InputsModel,
                                       RunOptions,
+                                      CalibOptions,
                                       OutputsModel,
                                       useUpstreamQsim)
       IM <- l$InputsModel
@@ -84,14 +85,24 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
         subBasinAreas <- calcSubBasinAreas(IM)
       }
       for (uId in Ids) {
-        # Add OutputsCalib for ungauged nodes
-        OutputsCalib[[uId]] <- OutputsCalib[[id]]
-        # Copy parameters and transform X4 relatively to the sub-basin area
-        OutputsCalib[[uId]]$ParamFinalR <-
-          OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$indexParamUngauged]
-        if(IM[[id]]$model$hasX4) {
-          OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$iX4] <-
-            X4 * (subBasinAreas[uId] / sum(subBasinAreas)) ^ 0.3
+        if(!IM[[uId]]$isReservoir) {
+          # Add OutputsCalib for ungauged nodes
+          OutputsCalib[[uId]] <- OutputsCalib[[id]]
+          # Copy parameters and transform X4 relatively to the sub-basin area
+          OutputsCalib[[uId]]$ParamFinalR <-
+            OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$indexParamUngauged]
+          if(IM[[id]]$model$hasX4) {
+            OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$iX4] <-
+              X4 * (subBasinAreas[uId] / sum(subBasinAreas, na.rm = TRUE)) ^ 0.3
+          }
+        } else {
+          OutputsCalib[[uId]] <- Calibration(
+            InputsModel = IM[[uId]],
+            RunOptions = RunOptions[[uId]],
+            InputsCrit = IC,
+            CalibOptions = CalibOptions[[uId]],
+            ...
+          )
         }
       }
       IM <- IM[[id]]
@@ -168,16 +179,30 @@ reduceGRiwrmObj4Ungauged <- function(griwrm, obj) {
   return(obj)
 }
 
+
+#' Set a reduced GRiwrm network for calibration of a sub-network with ungauged
+#' hydrological nodes
+#'
+#' @inheritParams Calibration
+#' @param GaugedId [character] Id of the gauged node
+#' @param OutputsModel *GRiwrmOutputsModel* of the complete network
+#'
+#' @return A [list] containing the following items:
+#' - `InputsModel`: a *GRiwrmInputsModel* of the reduced network
+#' - `RunOptions`: a *GRiwrmRunOptions* of the reduced network
+#' @noRd
+#'
 updateParameters4Ungauged <- function(GaugedId,
                                       InputsModel,
                                       RunOptions,
+                                      CalibOptions,
                                       OutputsModel,
                                       useUpstreamQsim) {
 
   ### Set the reduced network of the basin containing ungauged nodes ###
-  # Select nodes identified with the current node as gauged node
+  # Select nodes identified with the current node as donor gauged node
   griwrm <- attr(InputsModel, "GRiwrm")
-  gDonor <- griwrm[griwrm$donor == GaugedId, ]
+  gDonor <- griwrm[!is.na(griwrm$donor) & griwrm$donor == GaugedId, ]
   # Add upstream nodes for routing upstream flows
   upIds <- griwrm$id[griwrm$down %in% gDonor$id & !griwrm$id %in% gDonor$id]
   g <- rbind(griwrm[griwrm$id %in% upIds, ], gDonor)
@@ -188,9 +213,15 @@ updateParameters4Ungauged <- function(GaugedId,
   ### Modify InputsModel for the reduced network ###
   # Remove nodes outside of reduced network
   InputsModel <- reduceGRiwrmObj4Ungauged(g, InputsModel)
+  # Copy fixed parameters for Reservoirs
+  for (id in names(InputsModel)) {
+    if (InputsModel[[id]]$isReservoir) {
+      InputsModel[[id]]$FixedParam <- CalibOptions[[id]]$FixedParam
+    }
+  }
   # Update griwrm
   attr(InputsModel, "GRiwrm") <- g
-  # Update Qupstream already modelled in the reduced network upstream nodes
+  # Update Qupstream already modeled in the reduced network upstream nodes
   idIM <- unique(g$down[g$id %in% upIds])
   for (id in idIM) {
     if(useUpstreamQsim && any(InputsModel[[id]]$UpstreamIsModeled)) {
@@ -258,9 +289,12 @@ calcSubBasinAreas <- function(IM) {
 #' @noRd
 RunModel_Ungauged <- function(InputsModel, RunOptions, Param) {
   InputsModel$FUN_MOD <- NULL
-  SBVI <- sum(calcSubBasinAreas(InputsModel))
+  SBVI <- sum(calcSubBasinAreas(InputsModel), na.rm = TRUE)
   # Compute Param for each sub-basin
   P <- lapply(InputsModel, function(IM) {
+    if (IM$isReservoir) {
+      return(IM$FixedParam)
+    }
     p <- Param[IM$model$indexParamUngauged]
     if(IM$model$hasX4) {
       p[IM$model$iX4] <- Param[IM$model$iX4] * (IM$BasinAreas[length(IM$BasinAreas)] / SBVI) ^ 0.3

R/CreateCalibOptions.GRiwrmInputsModel.R

@@ -6,7 +6,7 @@ CreateCalibOptions.GRiwrmInputsModel <- function(x, ...) {
   class(CalibOptions) <- c("GRiwrmCalibOptions", class(CalibOptions))
 
   np <- getAllNodesProperties(attr(x, "GRiwrm"))
-  gaugedIds <- np$id[np$hydrology == "Gauged"]
+  gaugedIds <- np$id[np$calibration == "Gauged"]
   for(id in gaugedIds) {
     IM <- x[[id]]
     CalibOptions[[IM$id]] <- CreateCalibOptions(

R/CreateGRiwrm.R

@@ -85,8 +85,8 @@ CreateGRiwrm <- function(db,
                         area = "double"),
                    keep_all)
   checkNetworkConsistency(griwrm)
-  griwrm$donor <- sapply(griwrm$id, getGaugedId, griwrm = griwrm)
   class(griwrm) <- c("GRiwrm", class(griwrm))
+  griwrm$donor <- setDonor(griwrm)
   griwrm
 }
 
@@ -176,11 +176,6 @@ checkNetworkConsistency <- function(db) {
       nodeError(db[i, ],
                 "A Diversion node must have the same `id` of one (and only one) node with a model")
     }
-    if (length(unique(db$down[db$id == x])) != 2) {
-      nodeError(db[i, ], paste(
-        "The downstream node of a Diversion node must be different",
-        "than the downstream node of the node is attached to"))
-    }
   })
   id_reservoirs <- db3$id[db3$model == "RunModel_Reservoir"]
   sapply(id_reservoirs, function(id) {
@@ -230,19 +225,24 @@ nodeError <- function(node, s) {
 #' @param id [character] Id of the current node
 #' @param griwrm See [CreateGRiwrm])
 #'
-#' @return [character] Id of the first node with a model
+#' @return [character] Id of the first node with a model of `FALSE` if not found
 #'
 #' @noRd
 getGaugedId <- function(id, griwrm) {
-  griwrm <- griwrm[getDiversionRows(griwrm, TRUE), ]
-  if (!is.na(griwrm$model[griwrm$id == id]) &
-    griwrm$model[griwrm$id == id] != "Ungauged") {
+  np <- getNodeProperties(id, griwrm)
+  if (np$RunOff && np$calibration == "Gauged") {
+    # Match with au gauged station!
     return(id)
-  } else if (!is.na(griwrm$down[griwrm$id == id])) {
-    return(getGaugedId(griwrm$down[griwrm$id == id], griwrm))
   } else {
-    stop("The model of the downstream node of a network",
-      " cannot be `NA` or \"Ungauged\"")
+    # Otherwise we need to search downstream on the natural network
+    g2 <- griwrm[getDiversionRows(griwrm, TRUE), ]
+    id_down <- g2$down[g2$id == id]
+    if (!is.na(id_down)) {
+      return(getGaugedId(id_down, griwrm))
+    } else {
+      #If we already are at the downstream end, we have a problem...
+      return(FALSE)
+    }
   }
 }
 
@@ -258,3 +258,24 @@ getDiversionRows <- function(griwrm, inverse = FALSE) {
   }
   return(rows)
 }
+
+setDonor <- function(griwrm) {
+  sapply(seq(nrow(griwrm)), function(i) {
+    id <- griwrm$id[i]
+    model <- griwrm$model[i]
+    if (is.na(model) || model == "Diversion") {
+      # Diversion and Direct injection are "Non Applicable"
+      return(NA)
+    } else if(model == "RunModel_Reservoir" && is.na(griwrm$down[i])){
+      # RunModel_Reservoir needs to be its own "donor" only if at downstream
+      # Otherwise we search the first gauged station downstream to allow
+      # calibration with ungauged upstream nodes
+      return(id)
+    }
+    gaugedId <- getGaugedId(id, griwrm = griwrm)
+    if (gaugedId == FALSE) {
+      stop("No Gauged node found downstream the node '", id, "'")
+    }
+    return(gaugedId)
+  })
+}

R/CreateInputsCrit.GRiwrmInputsModel.R

@@ -73,7 +73,7 @@ CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel,
   class(InputsCrit) <- append("GRiwrmInputsCrit", class(InputsCrit))
 
   np <- getAllNodesProperties(attr(InputsModel, "GRiwrm"))
-  gaugedIds <- np$id[np$hydrology == "Gauged"]
+  gaugedIds <- np$id[np$calibration == "Gauged"]
   for(id in gaugedIds) {
     if (id %in% colnames(Obs)) {
       IM <- InputsModel[[id]]

R/CreateInputsModel.GRiwrm.R

@@ -230,7 +230,7 @@ CreateEmptyGRiwrmInputsModel <- function(griwrm) {
   InputsModel <- list()
   class(InputsModel) <- c("GRiwrmInputsModel", class(InputsModel))
   # Update griwrm in case of manual change in model column
-  griwrm$donor <- sapply(griwrm$id, getGaugedId, griwrm = griwrm)
+  griwrm$donor <- setDonor(griwrm)
   attr(InputsModel, "GRiwrm") <- griwrm
   return(InputsModel)
 }
@@ -249,14 +249,17 @@ CreateEmptyGRiwrmInputsModel <- function(griwrm) {
 #' @return \emph{InputsModel} object for one.
 #' @noRd
 CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs, Qmin) {
-  hasDiversion <- getNodeProperties(id, griwrm)$Diversion
-  if (hasDiversion) {
+  np <- getNodeProperties(id, griwrm)
+
+  if (np$Diversion) {
     rowDiv <- which(griwrm$id == id & griwrm$model == "Diversion")
     diversionOutlet <- griwrm$down[rowDiv]
     griwrm <- griwrm[-rowDiv, ]
   }
   node <- griwrm[griwrm$id == id,]
-  FUN_MOD <- griwrm$model[griwrm$id == griwrm$donor[griwrm$id == id]]
+
+  g2 <- griwrm[getDiversionRows(griwrm, TRUE), ]
+  FUN_MOD <- g2$model[g2$id == g2$donor[g2$id == id]]
 
   # Set hydraulic parameters
   UpstreamNodeRows <- which(griwrm$down == id & !is.na(griwrm$down))
@@ -293,11 +296,8 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs, Qmin) {
     names(BasinAreas) <- c(griwrm$id[UpstreamNodeRows], id)
   }
 
-  if (identical(match.fun(FUN_MOD), RunModel_Reservoir)) {
-    isReservoir <- TRUE
+  if (np$Reservoir) {
     FUN_MOD <- "RunModel_Lag"
-  } else {
-    isReservoir <- FALSE
   }
   # Set model inputs with the **airGR** function
   InputsModel <- CreateInputsModel(
@@ -337,15 +337,17 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs, Qmin) {
       hasX4 = grepl("RunModel_GR[456][HJ]", FUN_MOD),
       iX4 = ifelse(inherits(InputsModel, "SD"), 5, 4)
     )
-  InputsModel$hasDiversion <- hasDiversion
-  InputsModel$isReservoir <- isReservoir
+  InputsModel$hasDiversion <- np$Diversion
+  InputsModel$isReservoir <- np$Reservoir
 
   # Add specific properties for Diversion and Reservoir nodes
-  if (hasDiversion) {
+  if (np$Diversion) {
     InputsModel$diversionOutlet <- diversionOutlet
     InputsModel$Qdiv <- -Qobs[, id]
     InputsModel$Qmin <- Qmin
-  } else if(isReservoir) {
+  } else if(np$Reservoir) {
+    # If an upstream node is ungauged then we are in an ungauged reduced network
+    InputsModel$isUngauged <- any(griwrm$model[UpstreamNodeRows] == "Ungauged")
     InputsModel$Qrelease <- Qobs[, id]
   }
   return(InputsModel)
@@ -419,6 +421,7 @@ getInputBV <- function(x, id, unset = NULL) {
 #'
 #' @noRd
 hasUngaugedNodes <- function(id, griwrm) {
+  nps <- getAllNodesProperties(griwrm)
   upIds <- griwrm$id[griwrm$down == id]
   upIds <- upIds[!is.na(upIds)]
   # No upstream nodes
@@ -427,11 +430,13 @@ hasUngaugedNodes <- function(id, griwrm) {
   UngNodes <- griwrm$model[griwrm$id %in% upIds] == "Ungauged"
   UngNodes <- UngNodes[!is.na(UngNodes)]
   if(length(UngNodes) > 0 && any(UngNodes)) return(TRUE)
-  # At least one node's model is NA need to investigate next level
-  if(any(is.na(griwrm$model[griwrm$id %in% upIds]))) {
-    g <- griwrm[griwrm$id %in% upIds, ]
-    NaIds <- g$id[is.na(g$model)]
-    out <- sapply(NaIds, hasUngaugedNodes, griwrm = griwrm)
+
+  upNps <- nps[nps$id %in% upIds, ]
+  if(any(upNps$DirectInjection) || any(upNps$Reservoir)) {
+    # At least one node's model is NA or Reservoir, we need to investigate next level
+    out <- sapply(upNps$id[upNps$DirectInjection | upNps$Reservoir],
+                  hasUngaugedNodes,
+                  griwrm = griwrm)
     return(any(out))
   }
   return(FALSE)

R/getNodeProperties.R

@@ -5,8 +5,8 @@
 #'
 #' @return A [list] with the following items:
 #' - "position" ([character]): Position of the node in the network ("Upstream" or "Intermediate")
-#' - "hydrology" ([character]): describe if the node is a "Gauged" or an "Ungauged" station
-#'   modelled with an hydrological model, or a "DirectionInjection" node
+#' - "calibration" ([character]): describe if the node is a "Gauged", or an "Ungauged" station,
+#'   modelled with an hydrological model, or "NA" otherwise
 #' - "Upstream" ([logical]): is the node an upstream node?
 #' - "DirectInjection" ([logical]): is the node a Direct Injection node?
 #' - "Diversion" ([logical]): is the node a Diversion node?
@@ -16,21 +16,24 @@
 #' @example man-examples/getNodeProperties.R
 getNodeProperties <- function(id, griwrm) {
   stopifnot(inherits(griwrm, "GRiwrm"))
-  g_div <- griwrm[getDiversionRows(griwrm), , drop = FALSE]
   g2 <- griwrm[getDiversionRows(griwrm, TRUE), , drop = FALSE]
   upstreamIds <- griwrm$id[!griwrm$id %in% griwrm$down]
-  gaugedIds <- g2$id[!is.na(g2$model) & !g2$model %in% c("Ungauged")]
-  divertedIds <- g_div$id
+  model <- g2$model[g2$id == id]
   p <- list(
     position = ifelse(id %in% upstreamIds, "Upstream", "Intermediate"),
-    hydrology = ifelse(id %in% gaugedIds, "Gauged",
-                       ifelse(is.na(g2$model[g2$id == id]), "NA", "Ungauged")),
-    DirectInjection = is.na(g2$model[g2$id == id]),
-    Diversion = id %in% divertedIds,
-    Reservoir = !is.na(g2$model[g2$id == id]) && g2$model[g2$id == id] == "RunModel_Reservoir"
+    DirectInjection = is.na(model),
+    Diversion = "Diversion" %in% griwrm$model[griwrm$id == id],
+    Reservoir = !is.na(model) && model == "RunModel_Reservoir"
   )
+  if (p$DirectInjection) {
+    p$calibration <- "NA"
+  } else if (model == "Ungauged") {
+    p$calibration <- "Ungauged"
+  } else {
+    p$calibration <- "Gauged"
+  }
   p$Upstream <- p$position == "Upstream"
-  p$RunOff <- p$hydrology != "NA" & !p$Reservoir
+  p$RunOff <- !p$DirectInjection && !p$Reservoir
   return(p)
 }
 

R/plot.GRiwrm.R

@@ -91,7 +91,7 @@ getNodeClass <- function(id, griwrm) {
   }  else if (props$Reservoir) {
     nc <- "Reservoir"
   }  else {
-    nc <- paste0(props["position"], props["hydrology"])
+    nc <- paste0(props$position, props$calibration)
   }
   if (props$Diversion) nc <- paste0(nc, "Diversion")
   return(nc)

man/getNodeProperties.Rd

@@ -15,8 +15,8 @@ getNodeProperties(id, griwrm)
 A \link{list} with the following items:
 \itemize{
 \item "position" (\link{character}): Position of the node in the network ("Upstream" or "Intermediate")
-\item "hydrology" (\link{character}): describe if the node is a "Gauged" or an "Ungauged" station
-modelled with an hydrological model, or a "DirectionInjection" node
+\item "calibration" (\link{character}): describe if the node is a "Gauged", or an "Ungauged" station,
+modelled with an hydrological model, or "NA" otherwise
 \item "Upstream" (\link{logical}): is the node an upstream node?
 \item "DirectInjection" (\link{logical}): is the node a Direct Injection node?
 \item "Diversion" (\link{logical}): is the node a Diversion node?

tests/testthat/test-RunModel_Reservoir.R

@@ -11,27 +11,31 @@ test_that("Checks on GRiwrm object with Runmodel_Reservoir", {
 
 skip_on_cran()
 
+nodes <- loadSevernNodes()
+
+# Reduce the network
+nodes <- nodes[nodes$id %in% c("54095", "54001"), ]
+nodes$down[nodes$id == "54001"] <- NA
+nodes$length[nodes$id == "54001"] <- NA
+# Insert a dam downstream the location the gauging station 54095
+# The dam is a direct injection node
+nodes$down[nodes$id == "54095"] <- "Dam"
+nodes$length[nodes$id == "54095"] <- 0
+nodes <- rbind(nodes,
+               data.frame(id = "Dam",
+                          down = "54001",
+                          length = 42,
+                          area = NA,
+                          model = "RunModel_Reservoir"))
+
+Qobs2 <- data.frame(
+  Dam = rep(0,11536)
+)
+
 test_that("Calibration with Runmodel_Reservoir works!", {
-  nodes <- loadSevernNodes()
-
-  # Reduce the network
-  nodes <- nodes[nodes$id %in% c("54095", "54001"), ]
-  nodes$down[nodes$id == "54001"] <- NA
-  nodes$length[nodes$id == "54001"] <- NA
-  # Insert a dam downstream the location the gauging station 54095
-  # The dam is a direct injection node
-  nodes$down[nodes$id == "54095"] <- "Dam"
-  nodes$length[nodes$id == "54095"] <- 0
-  nodes <- rbind(nodes,
-                 data.frame(id = "Dam",
-                            down = "54001",
-                            length = 42,
-                            area = NA,
-                            model = "RunModel_Reservoir"))
+
   g <- CreateGRiwrm(nodes)
-  Qobs2 <- data.frame(
-    Dam = rep(0,11536)
-  )
+
   e <- setupRunModel(griwrm = g, runRunModel = FALSE, Qobs2 = Qobs2)
   for(x in ls(e)) assign(x, get(x, e))
 
@@ -67,3 +71,30 @@ test_that("Calibration with Runmodel_Reservoir works!", {
   expect_equal(OC[["Dam"]]$ParamFinalR, CalibOptions[["Dam"]]$FixedParam)
   expect_gt(OC[["54001"]]$CritFinal, 0.96)
 })
+
+test_that("Calibration with ungauged node and reservoir in the middle works", {
+
+  nodes$model[nodes$id == "54095"] <- "Ungauged"
+  g <- CreateGRiwrm(nodes)
+
+  expect_equal(g$donor[g$id == "54095"], "54001")
+
+  e <- setupRunModel(griwrm = g, runRunModel = FALSE, Qobs2 = Qobs2)
+  for(x in ls(e)) assign(x, get(x, e))
+
+  InputsCrit <- CreateInputsCrit(InputsModel,
+                                 ErrorCrit_KGE2,
+                                 RunOptions = RunOptions,
+                                 Obs = Qobs[IndPeriod_Run, ])
+  CalibOptions <- CreateCalibOptions(InputsModel)
+  CalibOptions[["Dam"]]$FixedParam <- c(650E6, 1)
+  OC <- Calibration(
+    InputsModel = InputsModel,
+    RunOptions = RunOptions,
+    InputsCrit = InputsCrit,
+    CalibOptions = CalibOptions
+  )
+  # X1, X2, X3 are identical
+  expect_equal(OC$`54001`$ParamFinalR[2:4], OC$`54095`$ParamFinalR[1:3])
+  expect_equal(OC$Dam$ParamFinalR, CalibOptions[["Dam"]]$FixedParam)
+})

tests/testthat/test-RunModel_Ungauged.R

 skip_on_cran()
+
+# data set up
+nodes <- loadSevernNodes()
+
+nodes <- nodes[!nodes$id %in% c("54002", "54057", "54095"), ]
+nodes[nodes$id == "54032", c("down", "length")] <- c(NA, NA)
+nodes$model[nodes$id == "54029"] <- "Ungauged"
+
+g <- CreateGRiwrm(nodes)
+e <- setupRunModel(runRunModel = FALSE, griwrm = g)
+for(x in ls(e)) assign(x, get(x, e))
+
+np <- getAllNodesProperties(griwrm)
+
+IC <- CreateInputsCrit(
+  InputsModel,
+  FUN_CRIT = ErrorCrit_KGE2,
+  RunOptions = RunOptions,
+  Obs = Qobs[IndPeriod_Run, np$id[np$RunOff & np$calibration == "Gauged"]],
+  AprioriIds = c("54032" = "54001"),
+  transfo = "sqrt",
+  k = 0.15
+)
+
+CO <- CreateCalibOptions(InputsModel)
+OC <- Calibration(InputsModel, RunOptions, IC, CO)
+
 test_that("RunModel_Ungauged works for intermediate basin with ungauged station", {
-  # data set up
-  nodes <- loadSevernNodes()
+  expect_true(all(sapply(OC, "[[", "CritFinal") > 0.96))
+})
 
-  nodes <- nodes[!nodes$id %in% c("54002", "54057", "54095"), ]
-  nodes[nodes$id == "54032", c("down", "length")] <- c(NA, NA)
-  nodes$model[nodes$id == "54029"] <- "Ungauged"
+test_that("RunModel_Ungauged works with a diversion as donor (#110)", {
+  nodes <- rbind(nodes,
+                 data.frame(id = "54032", down = NA, length = NA, area = NA, model = "Diversion"))
   g <- CreateGRiwrm(nodes)
-
-  e <- setupRunModel(runRunModel = FALSE, griwrm = g)
+  Qobs2 <- matrix(0, ncol = 1, nrow = 11536)
+  colnames(Qobs2) <- "54032"
+  e <- setupRunModel(griwrm = g, runRunModel = FALSE, Qobs2 = Qobs2)
   for(x in ls(e)) assign(x, get(x, e))
-
   np <- getAllNodesProperties(griwrm)
 
   IC <- CreateInputsCrit(
     InputsModel,
     FUN_CRIT = ErrorCrit_KGE2,
     RunOptions = RunOptions,
-    Obs = Qobs[IndPeriod_Run, np$id[np$hydrology == "Gauged"]],
+    Obs = Qobs[IndPeriod_Run, np$id[np$RunOff & np$calibration == "Gauged"], drop = FALSE],
     AprioriIds = c("54032" = "54001"),
     transfo = "sqrt",
     k = 0.15
   )
 
   CO <- CreateCalibOptions(InputsModel)
-  OC <- suppressWarnings(Calibration(InputsModel, RunOptions, IC, CO))
-  expect_true(all(sapply(OC, "[[", "CritFinal") > 0.96))
+  OCdiv <- Calibration(InputsModel, RunOptions, IC, CO)
+  expect_equal(OCdiv, OC)
 })

tests/testthat/test-createGRiwrm.R

@@ -34,13 +34,10 @@ test_that("Duplicated nodes",  {
                regexp = "Duplicated nodes detected")
 })
 
-test_that("NA or Ungauged nodes at downstream should throw an error", {
+test_that("Ungauged nodes without gauged node at downstream should throw an error", {
   nodes$model[nodes$id == "54057"] <- "Ungauged"
   expect_error(CreateGRiwrm(nodes),
-               regexp = "downstream node")
-  nodes$model[nodes$gauge_id == "54057"] <- NA
-  expect_error(CreateGRiwrm(nodes),
-               regexp = "downstream node")
+               regexp = "downstream the node")
 })
 
 test_that("Diversion node", {
@@ -55,10 +52,6 @@ test_that("Diversion node", {
   n_orphan$id[n_orphan$model == "Diversion"] <- "54999"
   expect_error(CreateGRiwrm(n_orphan),
                regexp = "Diversion node must have the same `id` of")
-  n_samedown <- nodes
-  n_samedown$down[n_samedown$model == "Diversion"] <- "54032"
-  expect_error(CreateGRiwrm(n_samedown),
-               regexp = "downstream node of a Diversion node must be different")
 })
 
 test_that("Allow several downstream ends", {

tests/testthat/test-getNodeProperties.R

@@ -8,20 +8,20 @@ test_that("All nodes should have property: Diversion and DirectInjection == FALS
                                 function(id) getNodeProperties(id, griwrm)[[p]])
     expect_equal(all(prop_value), FALSE)
   })
-  prop_hydrology <- sapply(griwrm$id,
-                           function(id) getNodeProperties(id, griwrm)$hydrology)
-  expect_equal(as.character(prop_hydrology), rep("Gauged", nrow(griwrm)))
+  prop_calibration <- sapply(griwrm$id,
+                           function(id) getNodeProperties(id, griwrm)$calibration)
+  expect_equal(as.character(prop_calibration), rep("Gauged", nrow(griwrm)))
 })
 
-test_that("Ungauged station has 'hydrology:Ungauged' property", {
+test_that("Ungauged station has 'calibration:Ungauged' property", {
   nodes$model[nodes$id == "54029"] <- "Ungauged"
-  expect_equal(getNodeProperties("54029", CreateGRiwrm(nodes))$hydrology, "Ungauged")
+  expect_equal(getNodeProperties("54029", CreateGRiwrm(nodes))$calibration, "Ungauged")
 })
 
-test_that("Direct injection node has 'hydrology:NA' property", {
+test_that("Direct injection node has 'calibration:NA' property", {
   nodes$model[nodes$id == "54002"] <- NA
   np <- getNodeProperties("54002", CreateGRiwrm(nodes))
-  expect_equal(np$hydrology, "NA")
+  expect_equal(np$calibration, "NA")
   expect_equal(np$DirectInjection, TRUE)
 })