diff --git a/R/Calibration.GRiwrmInputsModel.R b/R/Calibration.GRiwrmInputsModel.R index 8b39f0c3ca9085530b4daf04f83870ed976ed737..0807d7361891dc7008f8d750102d69d066a804e1 100644 --- a/R/Calibration.GRiwrmInputsModel.R +++ b/R/Calibration.GRiwrmInputsModel.R @@ -54,11 +54,6 @@ Calibration.GRiwrmInputsModel <- function(InputsModel, IM <- l$InputsModel IM$FUN_MOD <- "RunModel_Ungauged" attr(RunOptions[[id]], "GRiwrmRunOptions") <- l$RunOptions - if(IM[[id]]$model$hasX4) { - subBasinAreas <- calcSubBasinAreas(IM) - donorArea <- subBasinAreas[id] - attr(RunOptions[[id]], "donorArea") <- donorArea - } } else { if (useUpstreamQsim && any(IM$UpstreamIsModeled)) { # Update InputsModel$Qupstream with simulated upstream flows @@ -96,8 +91,9 @@ Calibration.GRiwrmInputsModel <- function(InputsModel, OutputsCalib[[uId]]$ParamFinalR <- OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$indexParamUngauged] if(IM[[id]]$model$hasX4) { + subBasinAreas <- calcSubBasinAreas(IM) OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$iX4] <- max( - X4 * (subBasinAreas[uId] / donorArea) ^ 0.3, + X4 * (subBasinAreas[uId] / subBasinAreas[id]) ^ 0.3, 0.5 ) } @@ -302,7 +298,8 @@ calcSubBasinAreas <- function(IM) { #' @noRd RunModel_Ungauged <- function(InputsModel, RunOptions, Param, output.all = FALSE) { InputsModel$FUN_MOD <- NULL - donorArea <- attr(RunOptions, "donorArea") + donor <- RunOptions$id + donorArea <- InputsModel[[donor]]$BasinAreas[length(InputsModel[[donor]]$BasinAreas)] # Compute Param for each sub-basin P <- lapply(InputsModel, function(IM) { if (IM$isReservoir) { @@ -311,7 +308,8 @@ RunModel_Ungauged <- function(InputsModel, RunOptions, Param, output.all = FALSE p <- Param[IM$model$indexParamUngauged] if(IM$model$hasX4) { p[IM$model$iX4] <- max( - Param[IM$model$iX4] * (IM$BasinAreas[length(IM$BasinAreas)] / donorArea) ^ 0.3, + Param[InputsModel[[donor]]$model$iX4] * + (IM$BasinAreas[length(IM$BasinAreas)] / donorArea) ^ 0.3, 0.5 ) } diff --git a/tests/testthat/test-RunModel_Ungauged.R b/tests/testthat/test-RunModel_Ungauged.R index 4d7a6da75f0a18da9cb160ee192a28d5563b0237..c85301e9fabf2fc2d2bbd9c57a4bba5fba5e7cac 100644 --- a/tests/testthat/test-RunModel_Ungauged.R +++ b/tests/testthat/test-RunModel_Ungauged.R @@ -1,5 +1,34 @@ skip_on_cran() +# data set up +test_that("RunModel_Ungauged should act as RunModel", { + nodes <- loadSevernNodes() + nodes <- nodes[nodes$id %in% c("54001", "54095"), ] + nodes[nodes$id == "54001", c("down", "length")] <- c(NA, NA) + nodes$model[nodes$id == "54095"] <- "Ungauged" + g <- CreateGRiwrm(nodes) + e <- setupRunModel(runRunModel = FALSE, griwrm = g) + for(x in ls(e)) assign(x, get(x, e)) + + Param <- ParamMichel["54001"] + Param[["54095"]] <- + ParamMichel[["54001"]][InputsModel[["54095"]]$model$indexParamUngauged] + donorArea <- tail(InputsModel[["54001"]]$BasinAreas, 1) + X4 <- Param[["54001"]][InputsModel[["54001"]]$model$iX4] + Param[["54095"]][InputsModel[["54095"]]$model$iX4] <- + max( + X4 * (tail(InputsModel[["54095"]]$BasinAreas, 1) / donorArea) ^ 0.3, + 0.5 + ) + OM <- RunModel(InputsModel, RunOptions = RunOptions, Param = Param) + attr(RunOptions[["54001"]], "GRiwrmRunOptions") <- RunOptions + OMU <- RunModel_Ungauged(InputsModel, + RunOptions = RunOptions[["54001"]], + Param = Param[["54001"]], + output.all = TRUE) + expect_equal(OMU, OM) +}) + # data set up nodes <- loadSevernNodes() @@ -38,9 +67,9 @@ CritValue <- ErrorCrit_KGE2( OutputsModel = OM$`54032` )$CritValue -# test_that("Ungauged node with gauged upstream node should works", { -# expect_equal(OC$`54032`$CritFinal, 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 donor (#110)", { nodes <- rbind(nodes, @@ -151,11 +180,13 @@ test_that("Ungauged node with diversion outside the sub-network should work", { RunOptions = RunOptions, Param = Param1 ) - CritValue <- ErrorCrit_KGE2( - InputsCrit = IC$`54032`, - OutputsModel = OM$`54032` - )$CritValue - # expect_equal(OC1$`54032`$CritFinal, CritValue) + sapply(c("54001", "54032"), function(id) { + CritValue <- ErrorCrit_KGE2( + InputsCrit = IC[[id]], + OutputsModel = OM[[id]] + )$CritValue + expect_equal(OC1[[id]]$CritFinal, CritValue) + }) # Second with Diversion with zero flow diverted for comparison nodes <- rbind(nodes, @@ -186,9 +217,11 @@ test_that("Ungauged node with diversion outside the sub-network should work", { RunOptions = RunOptions, Param = Param2 ) - CritValue <- ErrorCrit_KGE2( - InputsCrit = IC$`54032`, - OutputsModel = OM$`54032` - )$CritValue - # expect_equal(OC2$`54032`$CritFinal, CritValue) + sapply(c("54001", "54032"), function(id) { + CritValue <- ErrorCrit_KGE2( + InputsCrit = IC[[id]], + OutputsModel = OM[[id]] + )$CritValue + expect_equal(OC1[[id]]$CritFinal, CritValue) + }) })