diff --git a/R/Calibration.GRiwrmInputsModel.R b/R/Calibration.GRiwrmInputsModel.R index 9ef40e5c0dda5c7c8b038a9413785b36567b4bf1..e91a2d49b6cb2f35c2af3eb798dbb702ca3ea923 100644 --- a/R/Calibration.GRiwrmInputsModel.R +++ b/R/Calibration.GRiwrmInputsModel.R @@ -31,7 +31,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel, OutputsModel <- list() class(OutputsModel) <- append("GRiwrmOutputsModel", class(OutputsModel)) - b <- sapply(InputsModel, function(IM) !IM$isUngauged) + b <- sapply(InputsModel, function(IM) !IM$inUngaugedCluster) gaugedIds <- names(b[b]) for (id in gaugedIds) { @@ -156,13 +156,15 @@ getInputsCrit_Lavenne <- function(id, OutputsModel, InputsCrit) { Lavenne_FUN <- attr(InputsCrit[[id]], "Lavenne_FUN") AprParamR <- OutputsModel[[AprioriId]]$RunOptions$Param if (!inherits(OutputsModel[[AprioriId]], "SD")) { - # Add default velocity parameter for a priori upstream catchment + # Add Celerity parameter if apriori is an upstream node AprParamR <- c(AprCelerity, AprParamR) } - if (attr(InputsCrit[[id]], "model")$hasX4) { - featMod <- attr(InputsCrit[[id]], "model") + featMod <- attr(InputsCrit[[id]], "model") + if (featMod$hasX4) { AprParamR[featMod$iX4] <- AprParamR[featMod$iX4] * featMod$X4Ratio } + AprParamR <- AprParamR[featMod$indexParamUngauged] + message("A priori parameters from node ", AprioriId, ": ", paste(round(AprParamR, 3), collapse = ", ")) AprCrit <- ErrorCrit(InputsCrit[[AprioriId]], OutputsModel[[AprioriId]])$CritValue return(Lavenne_FUN(AprParamR, AprCrit)) } diff --git a/R/CreateInputsCrit.GRiwrmInputsModel.R b/R/CreateInputsCrit.GRiwrmInputsModel.R index bc234ed35b9f11d6c8f3616119042a2115c3902d..c8b0e754a4fa362a3567cf4501d8e84dd9c062c2 100644 --- a/R/CreateInputsCrit.GRiwrmInputsModel.R +++ b/R/CreateInputsCrit.GRiwrmInputsModel.R @@ -59,7 +59,7 @@ CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel, "\nIf possible, set this apriori id as the donor of the node \"", id,"\" to force the calibration sequence order") } - if (InputsModel[[AprioriIds[id]]]$isUngauged & + if (InputsModel[[AprioriIds[id]]]$inUngaugedCluster & InputsModel[[AprioriIds[id]]]$gaugedId == id) { stop("'AprioriIds': the node \"", AprioriIds[id], "\" is ungauged, use a gauged node instead") diff --git a/R/CreateInputsModel.GRiwrm.R b/R/CreateInputsModel.GRiwrm.R index 2d60245353a1590a50e4282d28dfd279e6bdd573..387bfee26639d1149c443348ebd5db630ea5bf7d 100644 --- a/R/CreateInputsModel.GRiwrm.R +++ b/R/CreateInputsModel.GRiwrm.R @@ -331,10 +331,14 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, DatesR, ..., Qobs, Qmin, Qrel # Add the model function InputsModel$FUN_MOD <- FUN_MOD featModel <- .GetFeatModel(InputsModel, IsHyst) - InputsModel$isUngauged <- node$id != node$donor && - isNodeDownstream(griwrm, id, node$donor) - InputsModel$isReceiver <- node$id != node$donor && - !isNodeDownstream(griwrm, id, node$donor) + # inUngaugedCluster: Ungauged node with downstream donor + # including reservoirs between ungauged nodes and donor + InputsModel$inUngaugedCluster <- (node$model == "Ungauged" || np$Reservoir) && + node$id != node$donor && + isNodeDownstream(griwrm, id, node$donor) + # isReceiver: Ungauged node with not downstream donor + InputsModel$isReceiver <- node$model == "Ungauged" && + !isNodeDownstream(griwrm, id, node$donor) InputsModel$gaugedId <- node$donor InputsModel$hasUngaugedNodes <- hasUngaugedNodes(id, griwrm) InputsModel$model <- diff --git a/tests/testthat/test-CreateInputsCrit.R b/tests/testthat/test-CreateInputsCrit.R index 8c3ad5ad973cf94b07ef47b2611c8b9ed1968a86..84d8ddd7e2dcd5683ce2b92aeb0f483d733ce412 100644 --- a/tests/testthat/test-CreateInputsCrit.R +++ b/tests/testthat/test-CreateInputsCrit.R @@ -122,6 +122,48 @@ test_that("Lavenne criterion: not upstream a priori nodes are allow if processed transfo = "sqrt" ) expect_equal(attr(IC156$`54029`, "AprioriId"), c("54029" = "54095")) + e <- runCalibration( + nodes = nodes, + Qobs2 = NULL, + InputsCrit = IC156, + CalibOptions = NULL, + FUN_CRIT = ErrorCrit_KGE2, + runRunModel = FALSE, + IsHyst = FALSE + ) + for (x in ls(e)) assign(x, get(x, e)) + # 54029 not processed as ungauged + expect_false(is.null(OutputsCalib$`54029`$CritFinal)) +}) + +test_that("Lavenne criterion: redefined calibration order works #157", { + nodes$donor <- nodes$id + nodes$donor[nodes$id == "54095"] <- "54029" + e <- setupRunModel(runRunModel = FALSE, + griwrm = CreateGRiwrm(nodes)) + for (x in ls(e)) assign(x, get(x, e)) + IC157 <- CreateInputsCrit( + InputsModel = InputsModel, + RunOptions = RunOptions, + Obs = Qobs[IndPeriod_Run, ], + AprioriIds = c( + "54057" = "54032", + "54032" = "54001", + "54095" = "54029" + ), + transfo = "sqrt" + ) + e <- runCalibration( + nodes = nodes, + Qobs2 = NULL, + InputsCrit = IC157, + CalibOptions = NULL, + FUN_CRIT = ErrorCrit_KGE2, + runRunModel = FALSE, + IsHyst = FALSE + ) + for (x in ls(e)) assign(x, get(x, e)) + expect_false(is.null(OutputsCalib$`54095`$CritFinal)) }) test_that("Lavenne criterion: current node and a priori node must use the same model", {