Commit f5c99e75 authored by Delaigue Olivier's avatar Delaigue Olivier
Browse files

v1.1.3.0 NEW: CreatInputsCrit can now process with SCA, SWE and SD observations

parent 761c2d55
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")),
......
......@@ -13,7 +13,7 @@ output:
### 1.1.2.43 Release Notes (2019-02-21)
### 1.1.3.0 Release Notes (2019-02-21)
......
......@@ -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)
......
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