v1.2.14.1 NEW: add .ErrorCrit fun to manage inputs of ErrorCrit_*()

DESCRIPTION

 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")),

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_&#42;()</code> functions now call <code>.ErrorCrit()</code> in order to check.
+- <code>.ErrorCrit()</code> private function added to check inputs into <code>ErrorCrit_&#42;()</code> functions.
 
 ____________________________________________________________________________________
 

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)
+  
+}