Commit 4fc3f135 authored by David's avatar David
Browse files

fix: Ungauged nodes Calibration with a Diversion in the donor

Refs #110
2 merge requests!93Draft: Version 0.7.0,!53Resolve "Ungauged node: incorrect definition of donor with Reservoir and bug with Diversion nodes"
Pipeline #44170 passed with stage
in 9 minutes and 28 seconds
Showing with 55 additions and 14 deletions
+55 -14
...@@ -179,6 +179,19 @@ reduceGRiwrmObj4Ungauged <- function(griwrm, obj) { ...@@ -179,6 +179,19 @@ reduceGRiwrmObj4Ungauged <- function(griwrm, obj) {
return(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, updateParameters4Ungauged <- function(GaugedId,
InputsModel, InputsModel,
RunOptions, RunOptions,
...@@ -187,9 +200,9 @@ updateParameters4Ungauged <- function(GaugedId, ...@@ -187,9 +200,9 @@ updateParameters4Ungauged <- function(GaugedId,
useUpstreamQsim) { useUpstreamQsim) {
### Set the reduced network of the basin containing ungauged nodes ### ### 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") 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 # Add upstream nodes for routing upstream flows
upIds <- griwrm$id[griwrm$down %in% gDonor$id & !griwrm$id %in% gDonor$id] upIds <- griwrm$id[griwrm$down %in% gDonor$id & !griwrm$id %in% gDonor$id]
g <- rbind(griwrm[griwrm$id %in% upIds, ], gDonor) g <- rbind(griwrm[griwrm$id %in% upIds, ], gDonor)
......
...@@ -258,7 +258,8 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs, Qmin) { ...@@ -258,7 +258,8 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs, Qmin) {
} }
node <- griwrm[griwrm$id == id,] 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 # Set hydraulic parameters
UpstreamNodeRows <- which(griwrm$down == id & !is.na(griwrm$down)) UpstreamNodeRows <- which(griwrm$down == id & !is.na(griwrm$down))
......
skip_on_cran() 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", { test_that("RunModel_Ungauged works for intermediate basin with ungauged station", {
# data set up expect_true(all(sapply(OC, "[[", "CritFinal") > 0.96))
nodes <- loadSevernNodes() })
nodes <- nodes[!nodes$id %in% c("54002", "54057", "54095"), ] test_that("RunModel_Ungauged works with a diversion as donor (#110)", {
nodes[nodes$id == "54032", c("down", "length")] <- c(NA, NA) nodes <- rbind(nodes,
nodes$model[nodes$id == "54029"] <- "Ungauged" data.frame(id = "54032", down = NA, length = NA, area = NA, model = "Diversion"))
g <- CreateGRiwrm(nodes) g <- CreateGRiwrm(nodes)
Qobs2 <- matrix(0, ncol = 1, nrow = 11536)
e <- setupRunModel(runRunModel = FALSE, griwrm = g) colnames(Qobs2) <- "54032"
e <- setupRunModel(griwrm = g, runRunModel = FALSE, Qobs2 = Qobs2)
for(x in ls(e)) assign(x, get(x, e)) for(x in ls(e)) assign(x, get(x, e))
np <- getAllNodesProperties(griwrm) np <- getAllNodesProperties(griwrm)
IC <- CreateInputsCrit( IC <- CreateInputsCrit(
InputsModel, InputsModel,
FUN_CRIT = ErrorCrit_KGE2, FUN_CRIT = ErrorCrit_KGE2,
RunOptions = RunOptions, 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"), AprioriIds = c("54032" = "54001"),
transfo = "sqrt", transfo = "sqrt",
k = 0.15 k = 0.15
) )
CO <- CreateCalibOptions(InputsModel) CO <- CreateCalibOptions(InputsModel)
OC <- suppressWarnings(Calibration(InputsModel, RunOptions, IC, CO)) OCdiv <- Calibration(InputsModel, RunOptions, IC, CO)
expect_true(all(sapply(OC, "[[", "CritFinal") > 0.96)) expect_equal(OCdiv, OC)
}) })
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment