diff --git a/R/Calibration.GRiwrmInputsModel.R b/R/Calibration.GRiwrmInputsModel.R index 6e0cdd38f9cd53dd4f0f5afa52c9b9d2233465c8..ef44dfd80d70d587df25f93b4aa58c10bcbcae24 100644 --- a/R/Calibration.GRiwrmInputsModel.R +++ b/R/Calibration.GRiwrmInputsModel.R @@ -78,7 +78,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel, if (hasUngauged) { # Select nodes with model in the sub-network g <- attr(IM, "GRiwrm") - Ids <- g$id[g$donor == id & !is.na(g$model)] + Ids <- g$id[!is.na(g$donor) & g$donor == id] # Extract the X4 calibrated for the whole intermediate basin if(IM[[id]]$model$hasX4) { X4 <- OutputsCalib[[id]]$ParamFinalR[IM[[id]]$model$iX4] # Global parameter @@ -167,7 +167,8 @@ getInputsCrit_Lavenne <- function(id, OutputsModel, InputsCrit) { reduceGRiwrmObj4Ungauged <- function(griwrm, obj) { objAttributes <- attributes(obj) obj <- lapply(obj, function(o) { - if(o$id %in% griwrm$id && !is.na(griwrm$model[griwrm$id == o$id])) { + if (o$id %in% griwrm$id && + !is.na(griwrm$model[griwrm$id == o$id & griwrm$model != "Diversion"])) { o } else { NULL @@ -204,9 +205,9 @@ updateParameters4Ungauged <- function(GaugedId, griwrm <- attr(InputsModel, "GRiwrm") 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] + upIds <- unique(griwrm$id[griwrm$down %in% gDonor$id & !griwrm$id %in% gDonor$id]) g <- rbind(griwrm[griwrm$id %in% upIds, ], gDonor) - g$model[g$id %in% upIds] <- NA + g$model[g$id %in% upIds & g$model != "Diversion"] <- NA # Set downstream node g$down[!g$down %in% g$id] <- NA @@ -221,21 +222,21 @@ updateParameters4Ungauged <- function(GaugedId, } # Update griwrm attr(InputsModel, "GRiwrm") <- g - # Update Qupstream already modeled in the reduced network upstream nodes + # Update Qupstream already modelled in the reduced network upstream nodes idIM <- unique(g$down[g$id %in% upIds]) for (id in idIM) { if(useUpstreamQsim && any(InputsModel[[id]]$UpstreamIsModeled)) { # Temporarily switch off upstream nodes belonging to the donor basin - UpIsModeledBackUp <- InputsModel[[idIM]]$UpstreamIsModeled - ImUpIds <- InputsModel[[idIM]]$UpstreamNodes - InputsModel[[idIM]]$UpstreamIsModeled[!ImUpIds %in% upIds] <- FALSE + UpIsModeledBackUp <- InputsModel[[id]]$UpstreamIsModeled + ImUpIds <- InputsModel[[id]]$UpstreamNodes + InputsModel[[id]]$UpstreamIsModeled[!ImUpIds %in% upIds] <- FALSE # Update InputsModel$Qupstream with simulated upstream flows - InputsModel[[idIM]] <- UpdateQsimUpstream(InputsModel[[idIM]], - RunOptions[[idIM]], + InputsModel[[id]] <- UpdateQsimUpstream(InputsModel[[id]], + RunOptions[[id]], OutputsModel) # Restore initial UpstreamIsModeled and switch off already modelled nodes - InputsModel[[idIM]]$UpstreamIsModeled <- UpIsModeledBackUp - InputsModel[[idIM]]$UpstreamIsModeled[ImUpIds %in% upIds] <- FALSE + InputsModel[[id]]$UpstreamIsModeled <- UpIsModeledBackUp + InputsModel[[id]]$UpstreamIsModeled[ImUpIds %in% upIds] <- FALSE } } diff --git a/tests/testthat/test-RunModel_Ungauged.R b/tests/testthat/test-RunModel_Ungauged.R index 02e4d98399b4b9ff34eed433e8c3313accc3ea1b..559053fc8351415096628f1c75c45295391d83b1 100644 --- a/tests/testthat/test-RunModel_Ungauged.R +++ b/tests/testthat/test-RunModel_Ungauged.R @@ -55,31 +55,51 @@ test_that("RunModel_Ungauged works with a diversion as donor (#110)", { expect_equal(OCdiv, OC) }) +# 3 nodes on one branch with ungauged node in the middle +nodes <- loadSevernNodes() +nodes <- nodes[!nodes$id %in% c("54002", "54057", "54029"), ] +nodes[nodes$id == "54032", c("down", "length")] <- c(NA, NA) +nodes$model[nodes$id == "54001"] <- "Ungauged" +g <- CreateGRiwrm(nodes) +e <- setupRunModel(griwrm = g, runRunModel = FALSE) +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"], drop = FALSE], + transfo = "sqrt", + k = 0.15 +) + +CO <- CreateCalibOptions(InputsModel) +OC <- Calibration(InputsModel, RunOptions, IC, CO) +Param <- sapply(OC, "[[", "ParamFinalR") +OM <- RunModel( + InputsModel, + RunOptions = RunOptions, + Param = Param +) +CritValue <- ErrorCrit_KGE2( + InputsCrit = IC$`54032`, + OutputsModel = OM$`54032` +)$CritValue + +test_that("Ungauged node with gauged upstream node should works", { + expect_equal(OC$`54032`$CritFinal, CritValue) +}) + test_that("RunModel_Ungauged works with a diversion as upstream node (#113)", { - nodes <- loadSevernNodes() - nodes <- nodes[!nodes$id %in% c("54002", "54057"), ] - nodes[nodes$id == "54032", c("down", "length")] <- c(NA, NA) - nodes$model[nodes$id == "54001"] <- "Ungauged" nodes <- rbind(nodes, - data.frame(id = "54095", down = "54029", length = 30, area = NA, model = "Diversion")) + data.frame(id = "54095", down = "54032", length = 100, area = NA, model = "Diversion")) g <- CreateGRiwrm(nodes) Qobs2 <- matrix(0, ncol = 1, nrow = 11536) colnames(Qobs2) <- "54095" 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$RunOff & np$calibration == "Gauged"], drop = FALSE], - AprioriIds = c("54032" = "54029"), - transfo = "sqrt", - k = 0.15 - ) - - CO <- CreateCalibOptions(InputsModel) OCdiv <- Calibration(InputsModel, RunOptions, IC, CO) - expect_s3_class(OCdiv, "GRiwrmOutputsCalib") + expect_equal(OCdiv$`54032`$CritFinal, CritValue) })