diff --git a/R/CreateInputsCrit.GRiwrmInputsModel.R b/R/CreateInputsCrit.GRiwrmInputsModel.R
index 718938ed6665ca15b2c3a39416ee40689c3d6bfb..1430274b2245739e360102c6eb7ba260c2fb56c8 100644
--- a/R/CreateInputsCrit.GRiwrmInputsModel.R
+++ b/R/CreateInputsCrit.GRiwrmInputsModel.R
@@ -56,6 +56,11 @@ CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel,
stop("'AprioriIds': the node \"", AprioriIds[id],
"\" is not upstream the node \"", id,"\"")
}
+ if (InputsModel[[AprioriIds[id]]]$isUngauged &
+ InputsModel[[AprioriIds[id]]]$gaugedId == id) {
+ stop("'AprioriIds': the node \"", AprioriIds[id],
+ "\" is an ungauged upstream node of the node \"", id,"\"")
+ }
})
}
diff --git a/tests/testthat/helper_RunModel.R b/tests/testthat/helper_RunModel.R
index 7c0913f7e21f4ea40715463f180be6272550e65a..fa1265a3e3bd5758d0eaddec1341bb364e642f83 100644
--- a/tests/testthat/helper_RunModel.R
+++ b/tests/testthat/helper_RunModel.R
@@ -10,57 +10,120 @@
# https://stackoverflow.com/questions/9965577/r-copy-move-one-environment-to-another
#' for(x in ls(e)) assign(x, get(x, e))
#'
-setupRunModel <- function() {
- data(Severn)
+setupRunModel <-
+ function(runInputsModel = TRUE,
+ runRunOptions = TRUE,
+ runRunModel = TRUE,
+ griwrm = NULL) {
- # Format observation
- BasinsObs <- Severn$BasinsObs
- DatesR <- BasinsObs[[1]]$DatesR
- PrecipTot <- cbind(sapply(BasinsObs, function(x) {x$precipitation}))
- PotEvapTot <- cbind(sapply(BasinsObs, function(x) {x$peti}))
- Qobs <- cbind(sapply(BasinsObs, function(x) {x$discharge_spec}))
+ data(Severn)
- # Set network
- nodes <- Severn$BasinsInfo[, c("gauge_id", "downstream_id", "distance_downstream", "area")]
- nodes$distance_downstream <- nodes$distance_downstream
- nodes$model <- "RunModel_GR4J"
- griwrm <- CreateGRiwrm(nodes, list(id = "gauge_id", down = "downstream_id", length = "distance_downstream"))
+ # Format observation
+ BasinsObs <- Severn$BasinsObs
+ DatesR <- BasinsObs[[1]]$DatesR
+ PrecipTot <-
+ cbind(sapply(BasinsObs, function(x) {
+ x$precipitation
+ }))
+ PotEvapTot <- cbind(sapply(BasinsObs, function(x) {
+ x$peti
+ }))
+ Qobs <- cbind(sapply(BasinsObs, function(x) {
+ x$discharge_spec
+ }))
- # Convert meteo data to SD (remove upstream areas)
- Precip <- ConvertMeteoSD(griwrm, PrecipTot)
- PotEvap <- ConvertMeteoSD(griwrm, PotEvapTot)
+ # Set network
+ if(is.null(griwrm)) {
+ nodes <-
+ Severn$BasinsInfo[, c("gauge_id", "downstream_id", "distance_downstream", "area")]
+ nodes$distance_downstream <- nodes$distance_downstream
+ nodes$model <- "RunModel_GR4J"
+ griwrm <-
+ CreateGRiwrm(nodes,
+ list(
+ id = "gauge_id",
+ down = "downstream_id",
+ length = "distance_downstream"
+ ))
+ }
- # Calibration parameters
- ParamMichel <- list(
- `54057` = c(0.779999999999999, 57.9743110789593, -1.23788116619639, 0.960789439152323, 2.47147147147147),
- `54032` = c(1.37562057772709, 1151.73462496385, -0.379248293750608, 6.2243898378232, 8.23716221550954),
- `54001` = c(1.03, 24.7790862245877, -1.90430150145153, 21.7584023961971, 1.37837837837838),
- `54095` = c(256.844150254651, 0.0650458497009288, 57.523675209819, 2.71809513102128),
- `54002` = c(419.437754485522, 0.12473266292168, 13.0379482833606, 2.12230907892238),
- `54029` = c(219.203385553954, 0.389211590110934, 48.4242150713452, 2.00300300300301)
- )
+ # Convert meteo data to SD (remove upstream areas)
+ Precip <- ConvertMeteoSD(griwrm, PrecipTot)
+ PotEvap <- ConvertMeteoSD(griwrm, PotEvapTot)
+
+ # set up inputs
+ if (!runInputsModel)
+ return(environment())
+ InputsModel <-
+ suppressWarnings(CreateInputsModel(griwrm, DatesR, Precip, PotEvap, Qobs))
+
+ # RunOptions
+ if (!runRunOptions)
+ return(environment())
+ e <- setupRunOptions(InputsModel)
+ for (x in ls(e)) assign(x, get(x, e))
+ rm(e)
- # set up inputs
- InputsModel <- suppressWarnings(CreateInputsModel(griwrm, DatesR, Precip, PotEvap, Qobs))
+ # RunModel.GRiwrmInputsModel
+ if (!runRunModel)
+ return(environment())
+ OM_GriwrmInputs <- RunModel(InputsModel,
+ RunOptions = RunOptions,
+ Param = ParamMichel)
+ return(environment())
+ }
- # RunOptions
+setupRunOptions <- function(InputsModel) {
nTS <- 365
- IndPeriod_Run <- seq(
- length(InputsModel[[1]]$DatesR) - nTS + 1,
- length(InputsModel[[1]]$DatesR)
- )
- IndPeriod_WarmUp = seq(IndPeriod_Run[1]-365,IndPeriod_Run[1]-1)
- RunOptions <- CreateRunOptions(
- InputsModel,
- IndPeriod_WarmUp = IndPeriod_WarmUp,
- IndPeriod_Run = IndPeriod_Run
- )
+ IndPeriod_Run <- seq(length(InputsModel[[1]]$DatesR) - nTS + 1,
+ length(InputsModel[[1]]$DatesR))
+ IndPeriod_WarmUp = seq(IndPeriod_Run[1] - 365, IndPeriod_Run[1] - 1)
+ RunOptions <- CreateRunOptions(InputsModel,
+ IndPeriod_WarmUp = IndPeriod_WarmUp,
+ IndPeriod_Run = IndPeriod_Run)
- # RunModel.GRiwrmInputsModel
- OM_GriwrmInputs <- RunModel(
- InputsModel,
- RunOptions = RunOptions,
- Param = ParamMichel
+ # Calibration parameters
+ ParamMichel <- list(
+ `54057` = c(
+ 0.779999999999999,
+ 57.9743110789593,
+ -1.23788116619639,
+ 0.960789439152323,
+ 2.47147147147147
+ ),
+ `54032` = c(
+ 1.37562057772709,
+ 1151.73462496385,
+ -0.379248293750608,
+ 6.2243898378232,
+ 8.23716221550954
+ ),
+ `54001` = c(
+ 1.03,
+ 24.7790862245877,
+ -1.90430150145153,
+ 21.7584023961971,
+ 1.37837837837838
+ ),
+ `54095` = c(
+ 256.844150254651,
+ 0.0650458497009288,
+ 57.523675209819,
+ 2.71809513102128
+ ),
+ `54002` = c(
+ 419.437754485522,
+ 0.12473266292168,
+ 13.0379482833606,
+ 2.12230907892238
+ ),
+ `54029` = c(
+ 219.203385553954,
+ 0.389211590110934,
+ 48.4242150713452,
+ 2.00300300300301
+ )
)
+
return(environment())
}
diff --git a/tests/testthat/test-CreateInputsCrit.R b/tests/testthat/test-CreateInputsCrit.R
index 36b0eef1f4c22cd11f832dcd3543c3c330b8b88c..26f910fdaf83eb19334836ed62a76a765737c445 100644
--- a/tests/testthat/test-CreateInputsCrit.R
+++ b/tests/testthat/test-CreateInputsCrit.R
@@ -34,6 +34,7 @@ e <- setupRunModel()
# variables are copied from environment 'e' to the current environment
# https://stackoverflow.com/questions/9965577/r-copy-move-one-environment-to-another
for(x in ls(e)) assign(x, get(x, e))
+rm(e)
context("CreateInputsCrit.GRiwrmInputsModel")
@@ -107,3 +108,21 @@ test_that("Lavenne criterion: wrong sub-catchment order should throw error", {
regexp = "is not upstream the node"
)
})
+
+test_that("Ungauged node as Apriori node should throw an error", {
+ nodes$model[nodes$gauge_id == "54001"] <- "Ungauged"
+ griwrm <- CreateGRiwrm(
+ nodes,
+ list(id = "gauge_id", down = "downstream_id", length = "distance_downstream")
+ )
+ InputsModel <-
+ suppressWarnings(CreateInputsModel(griwrm, DatesR, Precip, PotEvap, Qobs))
+ expect_error(
+ CreateInputsCrit(InputsModel = InputsModel,
+ RunOptions = RunOptions,
+ Obs = Qobs[IndPeriod_Run,],
+ AprioriIds = c("54057" = "54032", "54032" = "54001", "54001" = "54029"),
+ transfo = "sqrt"),
+ regexp = "\"54001\" is an ungauged upstream node of the node \"540032\""
+ )
+})