An error occurred while loading the file. Please try again.
-
Guillaume Perréal authoreda73e273c
CreateInputsCrit <- function(FUN_CRIT, InputsModel, RunOptions, Qobs, # deprecated Obs, VarObs = "Q", BoolCrit = NULL, transfo = "", Weights = NULL, Ind_zeroes = NULL, # deprecated 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") } ## check 'InputsModel' if (!inherits(InputsModel, "InputsModel")) { stop("'InputsModel' must be of class 'InputsModel'") } ## length of index of period to be used for the model run LLL <- length(InputsModel$DatesR[RunOptions$IndPeriod_Run]) ## 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 arguments7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
listArgs <- list(FUN_CRIT = FUN_CRIT,
Obs = Obs,
VarObs = VarObs,
BoolCrit = BoolCrit,
idLayer = idLayer,
transfo = as.character(transfo),
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 (iArgs %in% c("FUN_CRIT", "VarObs", "transfo", "Weights") & length(listArgs[[iArgs]]) > 1L) {
listArgs[[iArgs]] <- as.list(listArgs[[iArgs]])
}
if (!is.list(listArgs[[iArgs]])) {
listArgs[[iArgs]] <- list(listArgs[[iArgs]])
}
}
## check 'FUN_CRIT'
listArgs$FUN_CRIT <- lapply(listArgs$FUN_CRIT, FUN = match.fun)
## check 'VarObs'
if (missing(VarObs)) {
listArgs$VarObs <- as.list(rep("Q", times = length(listArgs$Obs)))
# if (warnings) {
# warning("'VarObs' automatically set to \"Q\"")
# }
}
## 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)))
# 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 'RunOptions'
if (!inherits(RunOptions , "RunOptions")) {
141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210
stop("'RunOptions' must be of class 'RunOptions'")
}
## 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")
}
## ---------- 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"
msgVarObs <- sprintf(msgVarObs, paste(sapply(inVarObs, shQuote), collapse = ", "))
inTransfo <- c("", "sqrt", "log", "inv", "sort", "boxcox") # pow is not checked by inTransfo, but appears in the warning message and checkef after (see ## check 'transfo')
msgTransfo <- "'transfo' must be a (list of) character vector(s) and one of %s, or numeric value for power transformation"
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'", call. = FALSE)
}
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 a dimensionless metric", call. = FALSE)
}
## 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", LLL), call. = FALSE)
}
## 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", call. = FALSE)
}
if (length(iListArgs2$BoolCrit) != LLL) {
stop("'BoolCrit' and the period defined in 'RunOptions' must have the same length", call. = FALSE)
}
## check 'VarObs'
if (!is.vector(iListArgs2$VarObs) | length(iListArgs2$VarObs) != 1 | !is.character(iListArgs2$VarObs) | !all(iListArgs2$VarObs %in% inVarObs)) {
stop(msgVarObs, call. = FALSE)
}
## check 'VarObs' + 'Obs'
if (any(iListArgs2$VarObs %in% "SCA")) {
idSCA <- which(iListArgs2$VarObs == "SCA")
if (length(idSCA) == 1L) {
vecSCA <- iListArgs2$Obs
} else {
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\"", call. = FALSE)
}
}
211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280
inPosVarObs <- c("Q", "SWE")
if (any(iListArgs2$VarObs %in% inPosVarObs)) {
idQSS <- which(iListArgs2$VarObs %in% inPosVarObs)
if (length(idQSS) == 1L) {
vecQSS <- iListArgs2$Obs
} else {
vecQSS <- unlist(iListArgs2$Obs[idQSS])
}
if (all(is.na(vecQSS))) {
stop("'Obs' contains only missing values", call. = FALSE)
}
if (min(vecQSS, na.rm = TRUE) < 0) {
stop(sprintf("'Obs' outside [0,Inf[ for \"%s\"", iListArgs2$VarObs), call. = FALSE)
}
}
## check 'transfo'
if (is.null(iListArgs2$transfo) | !is.vector(iListArgs2$transfo) | length(iListArgs2$transfo) != 1 | !is.character(iListArgs2$transfo)) {
stop(msgTransfo, call. = FALSE)
}
isNotInTransfo <- !(iListArgs2$transfo %in% inTransfo)
if (any(isNotInTransfo)) {
powTransfo <- iListArgs2$transfo[isNotInTransfo]
powTransfo <- gsub("\\^|[[:alpha:]]", "", powTransfo)
numExpTransfo <- suppressWarnings(as.numeric(powTransfo))
if (any(is.na(numExpTransfo))) {
stop(msgTransfo, call. = FALSE)
}
iListArgs2$transfo <- paste0("^", iListArgs2$transfo)
}
## 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)", call. = FALSE)
}
}
## 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)", call. = FALSE)
}
} 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 as the epsilon argument was set to 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 section 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,
idLayer = iListArgs2$idLayer,
transfo = iListArgs2$transfo,
epsilon = iListArgs2$epsilon,
Weights = iListArgs2$Weights)
class(iInputsCrit) <- c("Single", "InputsCrit", ObjectClass)
281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350
return(iInputsCrit)
})
names(InputsCrit) <- paste0("IC", seq_along(InputsCrit))
## define FUN_CRIT as a characater string
listErrorCrit <- c("ErrorCrit_KGE", "ErrorCrit_KGE2", "ErrorCrit_NSE", "ErrorCrit_RMSE")
InputsCrit <- lapply(InputsCrit, function(i) {
i$FUN_CRIT <- listErrorCrit[sapply(listErrorCrit, function(j) identical(i$FUN_CRIT, get(j)))]
i
})
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 contain %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") {
for (i in which(listVarObs == iInCnVarObs)) {
InputsCrit[[i]]$idLayer <- NA
}
} else {
aa <- listGroupLayer0[listVarObs == iInCnVarObs]
aa <- unname(aa)
bb <- cumsum(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)
} 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]]])
351352353354355356357358359360
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(InputsCrit)
}