Commit 020ae847 authored by Delaigue Olivier's avatar Delaigue Olivier
Browse files

v1.2.8.0 UPDATE: CreateInputsCrit now returns a idLayer to indicate which...

v1.2.8.0 UPDATE: CreateInputsCrit now returns a idLayer to indicate which layer to use for SCA or SWE
parent 86eb8039
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")),
......
......@@ -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
......
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)
......
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