Commit 23310224 authored by Dorchies David's avatar Dorchies David
Browse files

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
parents 0b8b6267 76f3921c
Pipeline #26918 passed with stages
in 17 minutes and 45 seconds
......@@ -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))
)
}
}
......@@ -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.
#'
......
......@@ -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, "...")
......
......@@ -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.
......
......@@ -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],
......
......@@ -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
......
......@@ -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
)
})
})
......@@ -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"
)
})
......@@ -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)
})
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment