diff --git a/R/Calibration.GRiwrmInputsModel.R b/R/Calibration.GRiwrmInputsModel.R index 88715a5aea436db88fef884a112c8e25d09a8c73..6e0cdd38f9cd53dd4f0f5afa52c9b9d2233465c8 100644 --- a/R/Calibration.GRiwrmInputsModel.R +++ b/R/Calibration.GRiwrmInputsModel.R @@ -179,6 +179,19 @@ 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, @@ -187,9 +200,9 @@ updateParameters4Ungauged <- function(GaugedId, 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) diff --git a/R/CreateInputsModel.GRiwrm.R b/R/CreateInputsModel.GRiwrm.R index 81f319e25801f91eb7af16195498f9fb0e7bf2c5..927862e874d466219859d60204c75b7c9e0bad2a 100644 --- a/R/CreateInputsModel.GRiwrm.R +++ b/R/CreateInputsModel.GRiwrm.R @@ -258,7 +258,8 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs, Qmin) { } 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)) diff --git a/tests/testthat/test-RunModel_Ungauged.R b/tests/testthat/test-RunModel_Ungauged.R index f91acd03e46104e3409c9a839641d106026e3162..54b1335a98c8d3bdac22b288b772493e809fdc56 100644 --- a/tests/testthat/test-RunModel_Ungauged.R +++ b/tests/testthat/test-RunModel_Ungauged.R @@ -1,29 +1,56 @@ 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) })