feat: use an ungauged node as a priori node is forbidden

Refs #42

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,"\"")
+      }
     })
   }
 

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())
 }

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\""
+  )
+})