From 0453844a8e842fbd76a82492e566a5bd6ff8551d Mon Sep 17 00:00:00 2001
From: David <david.dorchies@inrae.fr>
Date: Mon, 6 Feb 2023 17:38:14 +0100
Subject: [PATCH] fix(Ungauged): donor and hasUngauged for subnetwork with
 reservoir

Refs #110
---
 R/CreateGRiwrm.R             |  6 ++++--
 R/CreateInputsModel.GRiwrm.R | 34 +++++++++++++++++++---------------
 man/getNodeProperties.Rd     |  4 ++--
 3 files changed, 25 insertions(+), 19 deletions(-)

diff --git a/R/CreateGRiwrm.R b/R/CreateGRiwrm.R
index 7dbdbd5..fe5e93f 100644
--- a/R/CreateGRiwrm.R
+++ b/R/CreateGRiwrm.R
@@ -266,8 +266,10 @@ setDonor <- function(griwrm) {
     if (is.na(model) || model == "Diversion") {
       # Diversion and Direct injection are "Non Applicable"
       return(NA)
-    } else if(model == "RunModel_Reservoir"){
-      # RunModel_Reservoir needs to be its own "donor"
+    } 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)
diff --git a/R/CreateInputsModel.GRiwrm.R b/R/CreateInputsModel.GRiwrm.R
index 8555605..81f319e 100644
--- a/R/CreateInputsModel.GRiwrm.R
+++ b/R/CreateInputsModel.GRiwrm.R
@@ -249,13 +249,15 @@ 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]]
 
   # Set hydraulic parameters
@@ -293,11 +295,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 +336,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 +420,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 +429,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)
diff --git a/man/getNodeProperties.Rd b/man/getNodeProperties.Rd
index 23c38ae..b8f1126 100644
--- a/man/getNodeProperties.Rd
+++ b/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?
-- 
GitLab