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