CreateInputsCrit <- function(FUN_CRIT, InputsModel, RunOptions, Qobs, obs, varObs = "Q", 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") } ## 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, 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("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 \"\"") # } } ## 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")) { 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)) ## preparation of warning messages 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 = ", ")) 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) } ## 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 '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) 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)) # 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) }