From 020ae8478829c53339064ce8da22f3b32b584d55 Mon Sep 17 00:00:00 2001
From: Delaigue Olivier <olivier.delaigue@irstea.priv>
Date: Wed, 6 Mar 2019 09:24:08 +0100
Subject: [PATCH] v1.2.8.0 UPDATE: CreateInputsCrit now returns a idLayer to
indicate which layer to use for SCA or SWE
---
DESCRIPTION | 2 +-
NEWS.rmd | 4 ++-
R/CreateInputsCrit.R | 85 +++++++++++++++++++++++++++++++++++++++-----
3 files changed, 80 insertions(+), 11 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index 5dbd28ba..3616934d 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,7 +1,7 @@
Package: airGR
Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
-Version: 1.2.7.12
+Version: 1.2.8.0
Date: 2019-03-06
Authors@R: c(
person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),
diff --git a/NEWS.rmd b/NEWS.rmd
index a34b6e69..ae751659 100644
--- a/NEWS.rmd
+++ b/NEWS.rmd
@@ -13,7 +13,7 @@ output:
-### 1.2.7.12 Release Notes (2019-03-06)
+### 1.2.8.0 Release Notes (2019-03-06)
@@ -36,6 +36,8 @@ output:
- <code>CreateInputsCrit()</code> now presents a <code>warnings</code> argument to replace the verbose action (the <code>verbose</code> argument is keep to print messages).
+- <code>CreateInputsCrit()</code> now returns a <code>idLayer</code> element to indicate which layer to use for SCA or SWE aggregation.
+
- <code>CreateRunOptions()</code> now presents a <code>warnings</code> argument to replace the verbose action (the <code>verbose</code> argument is keep to print messages).
- <code>Calibration()</code> function now returns an error message if <code>FUN_CALIB</code> is not a function
diff --git a/R/CreateInputsCrit.R b/R/CreateInputsCrit.R
index 02cab174..3d98d517 100644
--- a/R/CreateInputsCrit.R
+++ b/R/CreateInputsCrit.R
@@ -1,14 +1,13 @@
CreateInputsCrit <- function(FUN_CRIT,
InputsModel,
RunOptions,
- Qobs,
+ Qobs, # deprecated
obs,
varObs = "Q",
BoolCrit = NULL,
transfo = "",
- # groupLayer,
weights = NULL,
- Ind_zeroes = NULL,
+ Ind_zeroes = NULL, # deprecated
epsilon = NULL,
warnings = TRUE,
verbose = TRUE) {
@@ -47,25 +46,33 @@ CreateInputsCrit <- function(FUN_CRIT,
LLL <- length(InputsModel$DatesR[RunOptions$IndPeriod_Run])
- ## check 'obs'
+ ## check 'obs' and definition of idLayer
vecObs <- unlist(obs)
if (length(vecObs) %% LLL != 0 | !is.numeric(vecObs)) {
stop(sprintf("'obs' must be a (list of) vector(s) of numeric values of length %i", LLL), call. = FALSE)
}
if (!is.list(obs)) {
+ idLayer <- list(1L)
obs <- list(obs)
} else {
+ idLayer <- lapply(obs, function(i) {
+ if (is.list(i)) {
+ length(i)
+ } else {
+ 1L
+ }
+ })
obs <- lapply(obs, function(x) rowMeans(as.data.frame(x)))
}
-
+
## create list of arguments
listArgs <- list(FUN_CRIT = FUN_CRIT,
obs = obs,
varObs = varObs,
BoolCrit = BoolCrit,
+ idLayer = idLayer,
transfo = transfo,
- # groupLayer = groupLayer,
weights = weights,
epsilon = epsilon)
@@ -90,6 +97,21 @@ CreateInputsCrit <- function(FUN_CRIT,
# }
}
+ ## check 'varObs' + 'RunOptions'
+ if ("Q" %in% varObs & !inherits(RunOptions, "GR")) {
+ stop("'varObs' cannot contain Q if a GR rainfall-runoff model is not used")
+ }
+ if (any(c("SCA", "SWE") %in% varObs) & !inherits(RunOptions, "CemaNeige")) {
+ stop("'varObs' cannot contain SCA or SWE if CemaNeige is not used")
+ }
+ if ("SCA" %in% varObs & inherits(RunOptions, "CemaNeige") & !"Gratio" %in% RunOptions$Outputs_Sim) {
+ stop("'Gratio' is missing in 'Outputs_Sim' of 'RunOptions', which is necessary to output SCA with CemaNeige")
+ }
+ if ("SWE" %in% varObs & inherits(RunOptions, "CemaNeige") & !"SnowPack" %in% RunOptions$Outputs_Sim) {
+ stop("'SnowPack' is missing in 'Outputs_Sim' of 'RunOptions', which is necessary to output SWE with CemaNeige")
+ }
+
+
## check 'transfo'
if (missing(transfo)) {
listArgs$transfo <- as.list(rep("", times = length(listArgs$obs)))
@@ -117,10 +139,11 @@ CreateInputsCrit <- function(FUN_CRIT,
}
+ ## ---------- reformat
+
## reformat list of arguments
listArgs2 <- lapply(seq_along(listArgs$FUN_CRIT), function(i) lapply(listArgs, "[[", i))
-
## preparation of warning messages
inVarObs <- c("Q", "SCA", "SWE")
msgVarObs <- "'varObs' must be a (list of) character vector(s) and one of %s"
@@ -219,7 +242,7 @@ CreateInputsCrit <- function(FUN_CRIT,
obs = iListArgs2$obs,
varObs = iListArgs2$varObs,
BoolCrit = iListArgs2$BoolCrit,
- # groupLayer = iListArgs2$groupLayer,
+ idLayer = iListArgs2$idLayer,
transfo = iListArgs2$transfo,
epsilon = iListArgs2$epsilon,
weights = iListArgs2$weights)
@@ -229,7 +252,51 @@ CreateInputsCrit <- function(FUN_CRIT,
})
names(InputsCrit) <- paste0("IC", seq_along(InputsCrit))
- # if only one criterion --> not a list of InputsCrit but directly an InputsCrit
+
+ listVarObs <- sapply(InputsCrit, FUN = "[[", "varObs")
+ inCnVarObs <- c("SCA", "SWE")
+ if (!"ZLayers" %in% names(InputsModel)) {
+ if(any(listVarObs %in% inCnVarObs)) {
+ stop(sprintf("'varOBS' can not be equal to %i if CemaNeige is not used",
+ paste(sapply(inCnVarObs, shQuote), collapse = " or ")))
+ }
+ } else {
+ listGroupLayer0 <- sapply(InputsCrit, FUN = "[[", "idLayer")
+ listGroupLayer <- rep(listVarObs, times = listGroupLayer0)
+ tabGroupLayer <- as.data.frame(table(listGroupLayer))
+ colnames(tabGroupLayer) <- c("varObs", "freq")
+ nLayers <- length(InputsModel$ZLayers)
+ for (iInCnVarObs in inCnVarObs) {
+ if (any(listVarObs %in% iInCnVarObs)) {
+ if (tabGroupLayer[tabGroupLayer$varObs %in% iInCnVarObs, "freq"] != nLayers) {
+ stop(sprintf("'obs' must contains %i vector(s) about %s", nLayers, iInCnVarObs))
+ }
+ }
+ }
+ }
+
+ ## define idLayer as an index of the layer to use
+ for (iInCnVarObs in unique(listVarObs)) {
+ if (iInCnVarObs == "Q") {
+ k <- 1
+ for (i in which(listVarObs == iInCnVarObs)) {
+ InputsCrit[[i]]$idLayer <- NA
+ k <- k + 1
+ }
+ } else {
+ aa <- listGroupLayer0[listVarObs == iInCnVarObs]
+ bb <- c(0, aa[-length(aa)])
+ cc <- lapply(seq_along(aa), function(x) seq_len(aa[x]) + bb[x])
+ k <- 1
+ for (i in which(listVarObs == iInCnVarObs)) {
+ InputsCrit[[i]]$idLayer <- cc[[k]]
+ k <- k + 1
+ }
+ }
+ }
+
+
+ ## if only one criterion --> not a list of InputsCrit but directly an InputsCrit
if (length(InputsCrit) < 2) {
InputsCrit <- InputsCrit[[1L]]
InputsCrit["weights"] <- list(weights = NULL)
--
GitLab