From f5c99e75b0a01b6bcc128e92f4b3bff62a778f2c Mon Sep 17 00:00:00 2001
From: Delaigue Olivier <olivier.delaigue@irstea.priv>
Date: Thu, 21 Feb 2019 11:13:54 +0100
Subject: [PATCH] v1.1.3.0 NEW: CreatInputsCrit can now process with SCA, SWE
and SD observations
---
DESCRIPTION | 2 +-
NEWS.rmd | 2 +-
R/CreateInputsCrit.R | 81 ++++++++++++++++++++++++++++++++------------
3 files changed, 61 insertions(+), 24 deletions(-)
diff --git a/DESCRIPTION b/DESCRIPTION
index 81030809..ef21726d 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.1.2.43
+Version: 1.1.3.0
Date: 2019-02-21
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 d26d4414..afa57c48 100644
--- a/NEWS.rmd
+++ b/NEWS.rmd
@@ -13,7 +13,7 @@ output:
-### 1.1.2.43 Release Notes (2019-02-21)
+### 1.1.3.0 Release Notes (2019-02-21)
diff --git a/R/CreateInputsCrit.R b/R/CreateInputsCrit.R
index 2c59f625..269eb92b 100644
--- a/R/CreateInputsCrit.R
+++ b/R/CreateInputsCrit.R
@@ -3,7 +3,7 @@ CreateInputsCrit <- function(FUN_CRIT,
RunOptions,
Qobs,
obs,
- varObs = "Qobs",
+ varObs = "Q",
BoolCrit = NULL,
transfo = "",
# groupLayer,
@@ -37,6 +37,29 @@ CreateInputsCrit <- function(FUN_CRIT,
}
+ ## check 'InputsModel'
+ if (!inherits(InputsModel, "InputsModel")) {
+ stop("'InputsModel' must be of class 'InputsModel' \n")
+ return(NULL)
+ }
+
+
+ ## length of index of period to be used for the model run
+ LLL <- length(InputsModel$DatesR[RunOptions$IndPeriod_Run])
+
+
+ ## check 'obs'
+ 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 \n", LLL), call. = FALSE)
+ }
+ if (!is.list(obs)) {
+ obs <- list(obs)
+ } else {
+ obs <- lapply(obs, function(x) rowMeans(as.data.frame(x)))
+ }
+
+
## create list of arguments
listArgs <- list(FUN_CRIT = FUN_CRIT,
obs = obs,
@@ -62,18 +85,18 @@ CreateInputsCrit <- function(FUN_CRIT,
## check 'varObs'
if (missing(varObs)) {
- listArgs$varObs <- as.list(rep("Qobs", times = length(listArgs$obs)))
- if (warnings) {
- warning("'varObs' automatically set to \"Qobs\"")
- }
+ listArgs$varObs <- as.list(rep("Q", times = length(listArgs$obs)))
+ # if (warnings) {
+ # warning("'varObs' automatically set to \"Q\"")
+ # }
}
## check 'transfo'
if (missing(transfo)) {
listArgs$transfo <- as.list(rep("", times = length(listArgs$obs)))
- if (warnings) {
- warning("'transfo' automatically set to \"\"")
- }
+ # if (warnings) {
+ # warning("'transfo' automatically set to \"\"")
+ # }
}
## check length of each args
@@ -83,19 +106,13 @@ CreateInputsCrit <- function(FUN_CRIT,
}
- ## check "InputsModel"
- if (!inherits(InputsModel, "InputsModel")) {
- stop("'InputsModel' must be of class 'InputsModel' \n")
- return(NULL)
- }
-
-
## check 'RunOptions'
if (!inherits(RunOptions , "RunOptions")) {
stop("'RunOptions' must be of class 'RunOptions' \n")
return(NULL)
}
+
## check 'weights'
if (length(listArgs$weights) > 1 & sum(unlist(listArgs$weights)) == 0 & !any(sapply(listArgs$weights, is.null))) {
stop("sum of 'weights' cannot be equal to zero \n")
@@ -106,17 +123,13 @@ CreateInputsCrit <- function(FUN_CRIT,
listArgs2 <- lapply(seq_along(listArgs$FUN_CRIT), function(i) lapply(listArgs, "[[", i))
- ## length of index of period to be used for the model run
- LLL <- length(InputsModel$DatesR[RunOptions$IndPeriod_Run])
-
-
## preparation of warning messages
- inVarObs <- c("Qobs") ##, "SCAobs")
+ inVarObs <- c("Q", "SCA", "SWE", "SD")
msgVarObs <- "'varObs' must be a (list of) character vector(s) and one of %s \n"
- msgVarObs <- sprintf(msgVarObs, paste(sapply(inVarObs, shQuote), collapse = ","))
+ msgVarObs <- sprintf(msgVarObs, paste(sapply(inVarObs, shQuote), collapse = ", "))
inTransfo <- c("", "sqrt", "log", "inv", "sort")
msgTransfo <- "'transfo' must be a (list of) character vector(s) and one of %s \n"
- msgTransfo <- sprintf(msgTransfo, paste(sapply(inTransfo, shQuote), collapse = ","))
+ msgTransfo <- sprintf(msgTransfo, paste(sapply(inTransfo, shQuote), collapse = ", "))
## ---------- loop on the list of inputs
@@ -135,6 +148,12 @@ CreateInputsCrit <- function(FUN_CRIT,
}
## check 'obs'
+ # lapply(iListArgs2$obs, function(iObs) {
+ # if (!is.vector(iObs) | length(iObs) != LLL | !is.numeric(iObs)) {
+ # stop(sprintf("'obs' must be a (list of) vector(s) of numeric values of length %i \n", LLL), call. = FALSE)
+ # return(NULL)
+ # }
+ # })
if (!is.vector(iListArgs2$obs) | length(iListArgs2$obs) != LLL | !is.numeric(iListArgs2$obs)) {
stop(sprintf("'obs' must be a (list of) vector(s) of numeric values of length %i \n", LLL), call. = FALSE)
return(NULL)
@@ -159,6 +178,24 @@ CreateInputsCrit <- function(FUN_CRIT,
return(NULL)
}
+ ## check 'varObs' + 'obs'
+ if (any(iListArgs2$varObs %in% "SCA")) {
+ idSCA <- which(iListArgs2$varObs == "SCA")
+ vecSCA <- unlist(iListArgs2$obs[idSCA])
+ if (min(vecSCA, na.rm = TRUE) < 0 | max(vecSCA, na.rm = TRUE) > 1) {
+ stop("'obs' outside [0,1] for \"SCA\" for 'varObs'", call. = FALSE)
+ }
+ }
+ inPosVarObs <- c("Q", "SWE", "SD")
+ if (any(iListArgs2$varObs %in% inPosVarObs)) {
+ idQSS <- which(iListArgs2$varObs %in% inPosVarObs)
+ vecQSS <- unlist(iListArgs2$obs[idQSS])
+ if (min(vecQSS, na.rm = TRUE) < 0) {
+ stop(sprintf("'obs' outside [0,Inf[ for \"%s\" for 'varObs'", iListArgs2$varObs), call. = FALSE)
+ }
+ }
+
+
## check 'transfo'
if (is.null(iListArgs2$transfo) | !is.vector(iListArgs2$transfo) | length(iListArgs2$transfo) != 1 | !is.character(iListArgs2$transfo) | !all(iListArgs2$transfo %in% inTransfo)) {
stop(msgTransfo, call. = FALSE)
--
GitLab