diff --git a/DESCRIPTION b/DESCRIPTION index 4f98a4d75041296e1e27e4f968f28b00c3973abf..0b39411160d5bc22d26194c63296a18ee9f09bce 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: airGR Type: Package Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling -Version: 1.2.14.0 +Version: 1.2.14.1 Date: 2019-04-16 Authors@R: c( person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")), diff --git a/NEWS.rmd b/NEWS.rmd index 30cdf6b45d30577937fad3b3d6e35cf310167368..627ebde8a71c083454a91d0ad0188fb4a12a1547 100644 --- a/NEWS.rmd +++ b/NEWS.rmd @@ -14,7 +14,7 @@ output: -### 1.2.14.0 Release Notes (2019-04-16) +### 1.2.14.1 Release Notes (2019-04-16) #### New features @@ -24,7 +24,7 @@ output: #### Minor user-visible changes -- <code>ErrorCrit_*()</code> functions now call <code>.ErrorCrit()</code> in order to check. +- <code>.ErrorCrit()</code> private function added to check inputs into <code>ErrorCrit_*()</code> functions. ____________________________________________________________________________________ diff --git a/R/Utils.R b/R/Utils.R index 33106630a7fa749c683c52742adb5cf821d1768f..69fe7901e0df2d7a29d1eafb53c57fd029ece87c 100644 --- a/R/Utils.R +++ b/R/Utils.R @@ -77,10 +77,145 @@ +## ================================================================================= +## function to manage inputs of specific ErrorCrit_*() functions +## ================================================================================= - - - - +.ErrorCrit <- function(InputsCrit, crit) { + + ## Arguments check + if (!inherits(InputsCrit, "InputsCrit")) { + stop("'InputsCrit' must be of class 'InputsCrit'", call. = FALSE) + } + if (inherits(InputsCrit, "Multi") | inherits(InputsCrit, "Compo")) { + if (crit == "RMSE") { + stop("'InputsCrit' must be of class 'Single'. Use the 'ErrorCrit' function on objects of class 'Multi' with RMSE", call. = FALSE) + } else { + stop(paste0("'InputsCrit' must be of class 'Single'. Use the 'ErrorCrit' function on objects of class 'Multi' or 'Compo' with ", crit), call. = FALSE) + } + } + + + ## Initialisation + CritName <- NA + CritVar <- InputsCrit$VarObs + if (InputsCrit$transfo == "") { + CritName <- paste0(crit, "[CritVar]") + } + if (InputsCrit$transfo %in% c("sqrt", "log", "sort")) { + CritName <- paste0(crit, "[", InputsCrit$transfo, "(CritVar)]") + } + if (InputsCrit$transfo == "inv") { + CritName <- paste0(crit, "[1/CritVar]") + } + if (grepl("^", InputsCrit$transfo)) { + transfoPow <- as.numeric(gsub("^", "", InputsCrit$transfo)) + CritName <- paste0(crit, "[CritVar^", transfoPow, "]") + } + CritName <- gsub(pattern = "CritVar", replacement = CritVar, x = CritName) + CritValue <- NA + if (crit %in% c("RMSE")) { + CritBestValue <- +1 + Multiplier <- +1 + } + if (crit %in% c("NSE", "KGE", "KGE2")) { + CritBestValue <- +1 + Multiplier <- -1 + } + + + ## Data preparation + VarObs <- InputsCrit$Obs + VarObs[!InputsCrit$BoolCrit] <- NA + if (InputsCrit$VarObs == "Q") { + VarSim <- OutputsModel$Qsim + } + if (InputsCrit$VarObs == "SCA") { + VarSim <- rowMeans(sapply(OutputsModel$CemaNeigeLayers[InputsCrit$idLayer], FUN = "[[", "Gratio")) + } + if (InputsCrit$VarObs == "SWE") { + VarSim <- rowMeans(sapply(OutputsModel$CemaNeigeLayers[InputsCrit$idLayer], FUN = "[[", "SnowPack")) + } + VarSim[!InputsCrit$BoolCrit] <- NA + + + ## Data transformation + if (InputsCrit$transfo %in% c("log", "inv") & is.null(InputsCrit$epsilon) & warnings) { + if (any(VarObs %in% 0)) { + warning("zeroes detected in 'Qobs': the corresponding time-steps will be excluded from the criteria computation if the epsilon argument of 'CreateInputsCrit' = NULL", call. = FALSE) + } + if (any(VarSim %in% 0)) { + warning("zeroes detected in 'Qsim': the corresponding time-steps will be excluded from the criteria computation if the epsilon argument of 'CreateInputsCrit' = NULL", call. = FALSE) + } + } + if ("epsilon" %in% names(InputsCrit) & !is.null(InputsCrit$epsilon)) { + VarObs <- VarObs + InputsCrit$epsilon + VarSim <- VarSim + InputsCrit$epsilon + } + if (InputsCrit$transfo == "sqrt") { + VarObs <- sqrt(VarObs) + VarSim <- sqrt(VarSim) + } + if (InputsCrit$transfo == "log") { + VarObs <- log(VarObs) + VarSim <- log(VarSim) + VarSim[VarSim < -1e100] <- NA + } + if (InputsCrit$transfo == "inv") { + VarObs <- 1 / VarObs + VarSim <- 1 / VarSim + VarSim[abs(VarSim) > 1e+100] <- NA + } + if (InputsCrit$transfo == "sort") { + VarSim[is.na(VarObs)] <- NA + VarSim <- sort(VarSim, na.last = TRUE) + VarObs <- sort(VarObs, na.last = TRUE) + InputsCrit$BoolCrit <- sort(InputsCrit$BoolCrit, decreasing = TRUE) + } + if ("exp" %in% InputsCrit$transfo) { + VarObs <- VarObs^transfoPow + VarSim <- VarSim^transfoPow + } + + + ## TS_ignore + TS_ignore <- !is.finite(VarObs) | !is.finite(VarSim) | !InputsCrit$BoolCrit + Ind_TS_ignore <- which(TS_ignore) + if (length(Ind_TS_ignore) == 0) { + Ind_TS_ignore <- NULL + } + if (sum(!TS_ignore) == 0 | (sum(!TS_ignore) == 1 & crit %in% c("KGE", "KGE2"))) { + CritCompute <- FALSE + } else { + CritCompute <- TRUE + } + if (inherits(OutputsModel, "hourly")) { + WarningTS <- 365 + } + if (inherits(OutputsModel, "daily")) { + WarningTS <- 365 + } + if (inherits(OutputsModel, "monthly")) { + WarningTS <- 12 + } + if (inherits(OutputsModel, "yearly")) { + WarningTS <- 3 + } + if (sum(!TS_ignore) < WarningTS & warnings) { + warning("\t criterion computed on less than ", WarningTS, " time-steps", call. = FALSE) + } + + + ## Outputs + OutputsCritCheck <- list(WarningTS = WarningTS, + VarObs = VarObs, + VarSim = VarSim, + CritBestValue = CritBestValue, + Multiplier = Multiplier, + CritName = CritName, + CritVar = CritVar, + CritCompute = CritCompute) + +}