An error occurred while loading the file. Please try again.
-
Delaigue Olivier authoredec035622
CreateInputsCrit <- function(FUN_CRIT, InputsModel, RunOptions, Qobs, obs, varObs = "Qobs", BoolCrit = NULL, transfo = "", # groupLayer, weights = NULL, Ind_zeroes = NULL, epsilon = NULL, warnings = TRUE, verbose = TRUE) { ObjectClass <- NULL ## ---------- check arguments if (!missing(Qobs)) { if (missing(obs)) { if (warnings) { warning("argument 'Qobs' is deprecated. Please use 'obs' and 'varObs' instead") } obs <- Qobs # varObs <- "Qobs" } else { warning("argument 'Qobs' is deprecated. The values set in 'obs' will be used instead") } } if (!missing(Ind_zeroes) & warnings) { warning("Deprecated 'Ind_zeroes' argument") } if (!missing(verbose)) { warning("Deprecated 'verbose' argument. Use 'warnings', instead") } ## create list of arguments listArgs <- list(FUN_CRIT = FUN_CRIT, obs = obs, varObs = varObs, BoolCrit = BoolCrit, transfo = transfo, # groupLayer = groupLayer, weights = weights, epsilon = epsilon) ## check lists lengths for (iArgs in names(listArgs)) { if (iArgs %in% c("weights", "BoolCrit", "epsilon")) { if (any(is.null(listArgs[[iArgs]]))) { listArgs[[iArgs]] <- lapply(seq_along(listArgs$FUN_CRIT), function(x) NULL) } } if (!is.list(listArgs[[iArgs]])) { listArgs[[iArgs]] <- list(listArgs[[iArgs]]) } } ## check 'varObs' if (missing(varObs)) { listArgs$varObs <- as.list(rep("Qobs", times = length(listArgs$obs))) if (warnings) { warning("'varObs' automatically set to \"Qobs\"") } }7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
## check 'transfo'
if (missing(transfo)) {
listArgs$transfo <- as.list(rep("", times = length(listArgs$obs)))
if (warnings) {
warning("'transfo' automatically set to \"\"")
}
}
## check length of each args
if (length(unique(sapply(listArgs, FUN = length))) != 1) {
stopListArgs <- paste(sapply(names(listArgs), shQuote), collapse = ", ")
stop(sprintf("arguments %s must have the same length", stopListArgs))
}
## 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")
}
## reformat list of arguments
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")
msgVarObs <- "'varObs' must be a (list of) character vector(s) and one of %s \n"
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 = ","))
## ---------- loop on the list of inputs
InputsCrit <- lapply(listArgs2, function(iListArgs2) {
## check 'FUN_CRIT'
if (!(identical(iListArgs2$FUN_CRIT, ErrorCrit_NSE ) | identical(iListArgs2$FUN_CRIT, ErrorCrit_KGE ) |
identical(iListArgs2$FUN_CRIT, ErrorCrit_KGE2) | identical(iListArgs2$FUN_CRIT, ErrorCrit_RMSE))) {
stop("incorrect 'FUN_CRIT' for use in 'CreateInputsCrit' \n", call. = FALSE)
return(NULL)
}
if (identical(iListArgs2$FUN_CRIT, ErrorCrit_RMSE) & length(listArgs$weights) > 1 & all(!is.null(unlist(listArgs$weights)))) {
stop("calculating a composite criterion with the RMSE is not allowed since RMSE is not an adimensional measure \n", call. = FALSE)
return(NULL)
}
## check 'obs'
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)
141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210
}
## check 'BoolCrit'
if (is.null(iListArgs2$BoolCrit)) {
iListArgs2$BoolCrit <- rep(TRUE, length(iListArgs2$obs))
}
if (!is.logical(iListArgs2$BoolCrit)) {
stop("'BoolCrit' must be a (list of) vector(s) of boolean \n", call. = FALSE)
return(NULL)
}
if (length(iListArgs2$BoolCrit) != LLL) {
stop("'BoolCrit' and 'InputsModel' series must have the same length \n", call. = FALSE)
return(NULL)
}
## check 'varObs'
if (!is.vector(iListArgs2$varObs) | length(iListArgs2$varObs) != 1 | !is.character(iListArgs2$varObs) | !all(iListArgs2$varObs %in% inVarObs)) {
stop(msgVarObs, call. = FALSE)
return(NULL)
}
## 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)
return(NULL)
}
## check 'weights'
if (!is.null(iListArgs2$weights)) {
if (!is.vector(iListArgs2$weights) | length(iListArgs2$weights) != 1 | !is.numeric(iListArgs2$weights) | any(iListArgs2$weights < 0)) {
stop("'weights' must be a single (list of) positive or equal to zero value(s) \n", call. = FALSE)
return(NULL)
}
}
## check 'epsilon'
if (!is.null(iListArgs2$epsilon)) {
if (!is.vector(iListArgs2$epsilon) | length(iListArgs2$epsilon) != 1 | !is.numeric(iListArgs2$epsilon) | any(iListArgs2$epsilon <= 0)) {
stop("'epsilon' must be a single (list of) positive value(s) \n", call. = FALSE)
return(NULL)
}
} else if (iListArgs2$transfo %in% c("log", "inv") & any(iListArgs2$obs %in% 0) & warnings) {
warning("zeroes detected in obs: the corresponding time-steps will be excluded by the 'ErrorCrit*' functions if the epsilon agrument = NULL", call. = FALSE)
}
## check 'transfo' + 'FUN_CRIT'
if (iListArgs2$transfo == "log" & warnings) {
warn_log_kge <- "we do not advise using the %s with a log transformation on obs (see the details part in the 'CreateInputsCrit' help)"
if (identical(iListArgs2$FUN_CRIT, ErrorCrit_KGE)) {
warning(sprintf(warn_log_kge, "KGE"), call. = FALSE)
}
if (identical(iListArgs2$FUN_CRIT, ErrorCrit_KGE2)) {
warning(sprintf(warn_log_kge, "KGE'"), call. = FALSE)
}
}
## Create InputsCrit
iInputsCrit <- list(FUN_CRIT = iListArgs2$FUN_CRIT,
obs = iListArgs2$obs,
varObs = iListArgs2$varObs,
BoolCrit = iListArgs2$BoolCrit,
# groupLayer = iListArgs2$groupLayer,
transfo = iListArgs2$transfo,
epsilon = iListArgs2$epsilon,
weights = iListArgs2$weights)
class(iInputsCrit) <- c("Single", "InputsCrit", ObjectClass)
return(iInputsCrit)
})
names(InputsCrit) <- paste0("IC", seq_along(InputsCrit))
211212213214215216217218219220221222223224225226227228229230231232233234235236237238
# 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)
} else {
if (any(sapply(listArgs$weights, is.null))) {
for (iListArgs in InputsCrit) {
iListArgs$weights <- NULL
}
class(InputsCrit) <- c("Multi", "InputsCrit", ObjectClass)
} else {
class(InputsCrit) <- c("Compo", "InputsCrit", ObjectClass)
}
combInputsCrit <- combn(x = length(InputsCrit), m = 2)
apply(combInputsCrit, MARGIN = 2, function(i) {
equalInputsCrit <- identical(InputsCrit[[i[1]]], InputsCrit[[i[2]]])
if(equalInputsCrit) {
warning(sprintf("Elements %i and %i of the criteria list are identical. This might not be necessary", i[1], i[2]), call. = FALSE)
}
return(NULL)
})
}
return(InputsCrit)
}