Merge branch '57-wrong-qobs-use-in-lavenne-function-criteria' into 'dev'

Resolve "Wrong Qobs use in Lavenne function criteria"

Closes #56 and #57

See merge request !25

R/CreateInputsCrit.GRiwrmInputsModel.R

@@ -11,9 +11,8 @@ CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel,
 
   # We invoke the mandatory arguments here for avoiding
   # a messy error message on "get(x)" if an argument is missing
-  InputsModel
-  RunOptions
-  Obs
+  # We also list all arguments in order to check arguments even in "..."
+  arguments <- c(as.list(environment()), list(...))
 
   # Checking argument classes
   lVars2Check <- list(InputsModel = "GRiwrmInputsModel",
@@ -36,6 +35,12 @@ CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel,
     if (length(unique(names(AprioriIds))) != length(names(AprioriIds))) {
       stop("Each name of AprioriIds items must be unique: duplicate entry detected")
     }
+    if ("Weights" %in% names(arguments)) {
+      stop("Argument 'Weights' cannot be used when using Lavenne criterion")
+    }
+    if (!"transfo" %in% names(arguments)) {
+      stop("Argument 'transfo' must be defined when using Lavenne criterion (Using \"sqrt\" is recommended)")
+    }
     lapply(names(AprioriIds), function(id) {
       if (!id %in% names(InputsModel)) {
         stop("'Each item of names(AprioriIds) must be an id of a simulated node:",
@@ -82,15 +87,29 @@ CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel,
   return(InputsCrit)
 }
 
+#' Generate a `CreateInputsCrit_Lavenne` function which embeds know parameters
+#'
+#' The created function will be used in calibration for injecting necessary `AprParamR` and `AprCrit`
+#' parameters, which can be known only during calibration process, in the call of `CreateInputsCrit_Lavenne`.
+#'
+#' @param InputsModel See [CreateInputsCrit] parameters
+#' @param FUN_CRIT See [CreateInputsCrit] parameters
+#' @param RunOptions See [CreateInputsCrit] parameters
+#' @param Obs See [CreateInputsCrit] parameters
+#' @param k See [CreateInputsCrit] parameters
+#' @param ... further arguments for [airGR::CreateInputsCrit_Lavenne]
+#'
+#' @return A function with `AprParamR` and `AprCrit`
+#' @noRd
+#'
 CreateLavenneFunction <- function(InputsModel, FUN_CRIT, RunOptions, Obs, k, ...) {
+  # The following line solve the issue #57 by forcing the evaluation of all the parameters.
+  # See also: https://stackoverflow.com/questions/69016698/is-there-a-bug-on-closures-embedded-in-a-list-in-r/69028161#69028161
+  arguments <- c(as.list(environment()), list(...))
   function(AprParamR, AprCrit) {
-    CreateInputsCrit_Lavenne(FUN_CRIT = FUN_CRIT,
-                               InputsModel = InputsModel,
-                               RunOptions = RunOptions,
-                               Obs = Obs,
-                               AprParamR = AprParamR,
-                               AprCrit = AprCrit,
-                               k = k,
-                               ...)
+    do.call(
+      CreateInputsCrit_Lavenne,
+      c(arguments, list(AprParamR = AprParamR, AprCrit = AprCrit))
+    )
   }
 }

R/CreateInputsCrit.R

@@ -12,7 +12,8 @@
 #'
 #' @details See [airGR::CreateInputsCrit] documentation for a complete list of arguments.
 #'
-#' `Obs` argument is equivalent to the same argument in [airGR::CreateInputsCrit] except that it must a [matrix] or a [data.frame] if `InputsModel` is a \emph{GRiwrmInputsModel} object. Then, each column of the [matrix] or [data.frame] represents the observations of one of the simulated node with the name of the columns representing the id of each node.
+#' `Obs` argument is equivalent to the same argument in [airGR::CreateInputsCrit] except that it must be a [matrix] or a [data.frame] if `InputsModel` is a \emph{GRiwrmInputsModel} object.
+#' Then, each column of the [matrix] or [data.frame] represents the observations of one of the simulated node with the name of the columns representing the id of each node.
 #'
 #' With a \emph{GRiwrmInputsModel} object, all arguments are applied on each sub-catchments of the network.
 #'

R/CreateInputsModel.GRiwrm.R

@@ -99,7 +99,6 @@ CreateInputsModel.GRiwrm <- function(x, DatesR,
   })
 
   InputsModel <- CreateEmptyGRiwrmInputsModel(x)
-  Qobs[is.na(Qobs)] <- -99 # airGR::CreateInputsModel doesn't accept NA values
 
   for(id in getNodeRanking(x)) {
     message("CreateInputsModel.GRiwrm: Treating sub-basin ", id, "...")

man/CreateInputsCrit.Rd

@@ -49,7 +49,8 @@ This function can be used either for a catchment (with an \emph{InputsModel} obj
 \details{
 See \link[airGR:CreateInputsCrit]{airGR::CreateInputsCrit} documentation for a complete list of arguments.
 
-\code{Obs} argument is equivalent to the same argument in \link[airGR:CreateInputsCrit]{airGR::CreateInputsCrit} except that it must a \link{matrix} or a \link{data.frame} if \code{InputsModel} is a \emph{GRiwrmInputsModel} object. Then, each column of the \link{matrix} or \link{data.frame} represents the observations of one of the simulated node with the name of the columns representing the id of each node.
+\code{Obs} argument is equivalent to the same argument in \link[airGR:CreateInputsCrit]{airGR::CreateInputsCrit} except that it must be a \link{matrix} or a \link{data.frame} if \code{InputsModel} is a \emph{GRiwrmInputsModel} object.
+Then, each column of the \link{matrix} or \link{data.frame} represents the observations of one of the simulated node with the name of the columns representing the id of each node.
 
 With a \emph{GRiwrmInputsModel} object, all arguments are applied on each sub-catchments of the network.
 

man/plot.Qm3s.Rd

@@ -8,7 +8,7 @@
   x,
   type = "l",
   xlab = "Date",
-  ylab = expression("Flow (m"^"3"*"/s)"),
+  ylab = expression("Flow (m"^"3" * "/s)"),
   main = "Simulated flows",
   col = rainbow(ncol(x) - 1),
   legend = colnames(x)[-1],

tests/testthat/helper_RunModel.R

@@ -41,7 +41,7 @@ setupRunModel <- function() {
   )
 
   # set up inputs
-  InputsModel <- CreateInputsModel(griwrm, DatesR, Precip, PotEvap, Qobs)
+  InputsModel <- suppressWarnings(CreateInputsModel(griwrm, DatesR, Precip, PotEvap, Qobs))
 
   # RunOptions
   nTS <- 365

tests/testthat/test-Calibration.R

@@ -37,7 +37,8 @@ test_that("Calibration with regularisation is OK", {
       "54057" = "54032",
       "54032" = "54001",
       "54001" = "54095"
-    )
+    ),
+    transfo = "sqrt"
   )
 
   OC <- Calibration(
@@ -59,7 +60,7 @@ test_that("Calibration with regularisation is OK", {
         InputsCrit[[id]],
         OM[[id]]
       )$CritValue,
-      0.9
+      0.89
     )
   })
 })

tests/testthat/test-CreateInputsCrit.R

@@ -25,11 +25,33 @@ test_that("Wrong argument class should throw error", {
                regexp = "matrix or data.frame")
 })
 
-test_that("De Lavenne criterion is OK", {
-  IC <- CreateInputsCrit(InputsModel = InputsModel,
-                         RunOptions = RunOptions,
-                         Obs = Qobs[IndPeriod_Run,],
-                         AprioriIds = c("54057" = "54032", "54032" = "54001", "54001" = "54095"))
+test_that("Using Lavenne criterion with 'weight' should throw error", {
+  expect_error(
+    CreateInputsCrit(InputsModel = InputsModel,
+                     RunOptions = RunOptions,
+                     Obs = Qobs[IndPeriod_Run,],
+                     AprioriIds = c("54057" = "54032", "54032" = "54001", "54001" = "54095"),
+                     Weights = c(0.85)),
+    regexp = "Lavenne"
+  )
+})
+
+test_that("Lavenne criterion without defining `transfo` should throw error", {
+  expect_error(CreateInputsCrit(InputsModel = InputsModel,
+                                      RunOptions = RunOptions,
+                                      Obs = Qobs[IndPeriod_Run,],
+                                      AprioriIds = c("54057" = "54032")),
+               regexp = "transfo")
+})
+
+AprioriIds <- c("54057" = "54032", "54032" = "54001", "54001" = "54095")
+IC <- CreateInputsCrit(InputsModel = InputsModel,
+                       RunOptions = RunOptions,
+                       Obs = Qobs[IndPeriod_Run,],
+                       AprioriIds = AprioriIds,
+                       transfo = "sqrt")
+
+test_that("Lavenne criterion is OK", {
   expect_s3_class(IC[["54057"]], "InputsCritLavenneFunction")
   Lavenne_FUN <- attr(IC[["54057"]], "Lavenne_FUN")
   IC57 <- Lavenne_FUN(ParamMichel[["54032"]], 0.9)
@@ -37,12 +59,20 @@ test_that("De Lavenne criterion is OK", {
   expect_s3_class(IC57, "Compo")
 })
 
-test_that("De Lavenne criterion: wrong sub-catchment order should throw error", {
+test_that("Lavenne embedded data is correct #57", {
+  lapply(names(AprioriIds), function(id) {
+    p <- as.list(environment(attr(IC[[id]], "Lavenne_FUN")))
+    expect_equal(id, p$InputsModel$id)
+  })
+})
+
+test_that("Lavenne criterion: wrong sub-catchment order should throw error", {
   expect_error(
     CreateInputsCrit(InputsModel = InputsModel,
                      RunOptions = RunOptions,
                      Obs = Qobs[IndPeriod_Run,],
-                     AprioriIds = c("54057" = "54032", "54032" = "54001", "54001" = "54029")),
+                     AprioriIds = c("54057" = "54032", "54032" = "54001", "54001" = "54029"),
+                     transfo = "sqrt"),
     regexp = "is not upstream the node"
   )
 })

tests/testthat/test-CreateInputsModel.R

@@ -3,14 +3,16 @@ context("CreateInputsModel")
 l <- setUpCemaNeigeData()
 
 test_that("CemaNeige data should be in InputsModel", {
-  InputsModels <- CreateInputsModel(l$griwrm,
-                                    DatesR = l$DatesR,
-                                    Precip = l$Precip,
-                                    PotEvap = l$PotEvap,
-                                    TempMean = l$TempMean,
-                                    ZInputs = l$ZInputs,
-                                    HypsoData = l$HypsoData,
-                                    Qobs = l$Qobs)
+  InputsModels <- suppressWarnings(
+    CreateInputsModel(l$griwrm,
+                      DatesR = l$DatesR,
+                      Precip = l$Precip,
+                      PotEvap = l$PotEvap,
+                      TempMean = l$TempMean,
+                      ZInputs = l$ZInputs,
+                      HypsoData = l$HypsoData,
+                      Qobs = l$Qobs)
+  )
   l$DatesR <- as.data.frame(l$DatesR)
   lapply(InputsModels, function(IM) {
     lapply(c("DatesR", "Precip", "PotEvap"), function(varName) {
@@ -40,14 +42,16 @@ test_that("handles mix of with and without CemaNeige nodes", {
   l$ZInputs <- l$ZInputs[1:2]
   l$TempMean <- l$TempMean[,1:2]
   l$HypsoData <- l$HypsoData[,1:2]
-  InputsModels <- CreateInputsModel(l$griwrm,
-                                    DatesR = l$DatesR,
-                                    Precip = l$Precip,
-                                    PotEvap = l$PotEvap,
-                                    TempMean = l$TempMean,
-                                    ZInputs = l$ZInputs,
-                                    HypsoData = l$HypsoData,
-                                    Qobs = l$Qobs)
+  InputsModels <- suppressWarnings(
+    CreateInputsModel(l$griwrm,
+                      DatesR = l$DatesR,
+                      Precip = l$Precip,
+                      PotEvap = l$PotEvap,
+                      TempMean = l$TempMean,
+                      ZInputs = l$ZInputs,
+                      HypsoData = l$HypsoData,
+                      Qobs = l$Qobs)
+  )
   expect_false(inherits(InputsModels$Down, "CemaNeige"))
   expect_null(InputsModels$Down$LayerPrecip)
 })