R/ErrorCrit.R

-ErrorCrit <- function(InputsCrit, OutputsModel, FUN_CRIT, warnings = TRUE, verbose = TRUE) {
-  
-  
+ErrorCrit <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = TRUE) {
+
+
   ## ---------- Arguments check
-  
+
   if (!inherits(InputsCrit, "InputsCrit")) {
     stop("InputsCrit must be of class 'InputsCrit'")
-  }  
+  }
   if (!inherits(OutputsModel, "OutputsModel")) {
     stop("OutputsModel must be of class 'OutputsModel'")
-  }  
-  if (!missing(FUN_CRIT)) {
-    warning("deprecated 'FUN_CRIT' argument. The error criterion function is now automatically get from the 'InputsCrit' object", call. = FALSE)
   }
-  
-  
-  
+
+
   ## ---------- Criterion computation
-  
+
   ## ----- Single criterion
   if (inherits(InputsCrit, "Single")) {
     FUN_CRIT <- match.fun(InputsCrit$FUN_CRIT)
@@ -25,10 +21,10 @@ ErrorCrit <- function(InputsCrit, OutputsModel, FUN_CRIT, warnings = TRUE, verbo
                             warnings = warnings,
                             verbose = verbose)
   }
-  
-  
+
+
   ## ----- Multiple criteria or Composite criterion
-  
+
   if (inherits(InputsCrit, "Multi") | inherits(InputsCrit, "Compo")) {
     listOutputsCrit <- lapply(InputsCrit, FUN = function(iInputsCrit) {
       FUN_CRIT <- match.fun(iInputsCrit$FUN_CRIT)
@@ -37,12 +33,12 @@ ErrorCrit <- function(InputsCrit, OutputsModel, FUN_CRIT, warnings = TRUE, verbo
                warnings = warnings,
                verbose = verbose)
     })
-    
+
     listValCrit  <- sapply(listOutputsCrit, function(x) x[["CritValue"]])
     listNameCrit <- sapply(listOutputsCrit, function(x) x[["CritName"]])
     listweights  <- unlist(lapply(InputsCrit, function(x) x[["Weights"]]))
-    listweights <- listweights / sum(listweights)
-    
+    listweights  <- listweights / sum(listweights)
+
     if (inherits(InputsCrit, "Compo")) {
       CritValue <- sum(listValCrit * listweights)
       OutputsCritCompo <- list(MultiCritValues  = listValCrit,
@@ -61,7 +57,7 @@ ErrorCrit <- function(InputsCrit, OutputsModel, FUN_CRIT, warnings = TRUE, verbo
         message("Crit. Composite = ", sprintf("%.4f", CritValue))
         msgForm <- paste(sprintf("%.2f", listweights), listNameCrit, sep = " * ", collapse = ", ")
         msgForm <- unlist(strsplit(msgForm, split = ","))
-        msgFormSep <- rep(c(",", ",", ",\n\t\t    "), times = ceiling(length(msgForm)/3))[1: length(msgForm)]
+        msgFormSep <- rep(c(",", ",", ",\n\t\t    "), times = ceiling(length(msgForm)/3))[1:length(msgForm)]
         msgForm <- paste(msgForm, msgFormSep, sep = "", collapse = "")
         msgForm <- gsub("\\,\\\n\\\t\\\t    $|\\,$", "", msgForm)
         message("\tFormula: sum(", msgForm, ")\n")
@@ -70,10 +66,10 @@ ErrorCrit <- function(InputsCrit, OutputsModel, FUN_CRIT, warnings = TRUE, verbo
       OutputsCrit <- listOutputsCrit
       class(OutputsCrit) <- c("Multi", "ErrorCrit")
     }
-    
+
   }
-  
+
   return(OutputsCrit)
-  
+
 }
 

R/ErrorCrit_KGE.R

 ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = TRUE) {
-  
+
   ## Arguments check
   if (!inherits(OutputsModel, "OutputsModel")) {
     stop("'OutputsModel' must be of class 'OutputsModel'")
   }
-  
+
   EC <- .ErrorCrit(InputsCrit = InputsCrit, Crit = "KGE", OutputsModel = OutputsModel, warnings = warnings)
-  
+
   CritValue     <- NA
   SubCritValues <- rep(NA, 3)
   SubCritNames  <- c("r", "alpha", "beta")
   SubCritPrint  <- rep(NA, 3)
-  
+
   if (EC$CritCompute) {
     ## Other variables preparation
     meanVarObs <- mean(EC$VarObs[!EC$TS_ignore])
     meanVarSim <- mean(EC$VarSim[!EC$TS_ignore])
-    
+
     ## SubErrorCrit KGE rPearson
     SubCritPrint[1L] <- paste0(EC$CritName, " cor(sim, obs, \"pearson\") =")
-    
+
     Numer <- sum((EC$VarObs[!EC$TS_ignore] - meanVarObs) * (EC$VarSim[!EC$TS_ignore] - meanVarSim))
     Deno1 <- sqrt(sum((EC$VarObs[!EC$TS_ignore] - meanVarObs) ^ 2))
     Deno2 <- sqrt(sum((EC$VarSim[!EC$TS_ignore] - meanVarSim) ^ 2))
-    
+
     if (Numer == 0) {
       if (Deno1 == 0 & Deno2 == 0) {
         Crit <- 1
@@ -31,18 +31,18 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T
         Crit <- 0
       }
     } else {
-      Crit  <- Numer / (Deno1 * Deno2)
+      Crit <- Numer / (Deno1 * Deno2)
     }
     if (is.numeric(Crit) & is.finite(Crit)) {
       SubCritValues[1L] <- Crit
     }
-    
+
     ## SubErrorCrit KGE alpha
     SubCritPrint[2L] <- paste0(EC$CritName, " sd(sim)/sd(obs)          =")
-    
+
     Numer <- sd(EC$VarSim[!EC$TS_ignore])
     Denom <- sd(EC$VarObs[!EC$TS_ignore])
-    
+
     if (Numer == 0 & Denom == 0) {
       Crit <- 1
     } else {
@@ -51,10 +51,10 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T
     if (is.numeric(Crit) & is.finite(Crit)) {
       SubCritValues[2L] <- Crit
     }
-    
+
     ## SubErrorCrit KGE beta
     SubCritPrint[3L] <- paste0(EC$CritName, " mean(sim)/mean(obs)      =")
-    
+
     if (meanVarSim == 0 & meanVarObs == 0) {
       Crit <- 1
     } else {
@@ -63,20 +63,20 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T
     if (is.numeric(Crit) & is.finite(Crit)) {
       SubCritValues[3L] <- Crit
     }
-    
+
     ## ErrorCrit
     if (sum(is.na(SubCritValues)) == 0) {
       CritValue <- (1 - sqrt((SubCritValues[1L] - 1)^2 + (SubCritValues[2L] - 1)^2 + (SubCritValues[3L] - 1)^2))
     }
-    
+
     ## Verbose
     if (verbose) {
       message(sprintf("Crit. %s = %.4f", EC$CritName, CritValue))
       message(paste("\tSubCrit.", SubCritPrint, sprintf("%.4f", SubCritValues), "\n", sep = " "))
     }
   }
-  
-  
+
+
   ## Output
   OutputsCrit <- list(CritValue       = CritValue,
                       CritName        = EC$CritName,
@@ -85,8 +85,11 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T
                       CritBestValue   = EC$CritBestValue,
                       Multiplier      = EC$Multiplier,
                       Ind_notcomputed = EC$Ind_TS_ignore)
-  
+
   class(OutputsCrit) <- c("KGE", "ErrorCrit")
   return(OutputsCrit)
-  
+
 }
+
+class(ErrorCrit_KGE) <- c("FUN_CRIT", class(ErrorCrit_KGE))
+

R/ErrorCrit_NSE.R

 ErrorCrit_NSE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = TRUE) {
-  
+
   ## Arguments check
   if (!inherits(OutputsModel, "OutputsModel")) {
     stop("'OutputsModel' must be of class 'OutputsModel'")
   }
-  
-  EC <- .ErrorCrit(InputsCrit = InputsCrit, Crit = "NSE",  OutputsModel = OutputsModel, warnings = warnings)
-  
+
+  EC <- .ErrorCrit(InputsCrit = InputsCrit, Crit = "NSE", OutputsModel = OutputsModel, warnings = warnings)
+
   CritValue <- NA
-  
+
   if (EC$CritCompute) {
-    ## Other variables preparation
-    meanVarObs <- mean(EC$VarObs[!EC$TS_ignore])
-    meanVarSim <- mean(EC$VarSim[!EC$TS_ignore])
-    
     ## ErrorCrit
     Emod <- sum((EC$VarSim[!EC$TS_ignore] - EC$VarObs[!EC$TS_ignore])^2)
     Eref <- sum((EC$VarObs[!EC$TS_ignore] - mean(EC$VarObs[!EC$TS_ignore]))^2)
-    
+
     if (Emod == 0 & Eref == 0) {
       Crit <- 0
     } else {
@@ -26,22 +22,24 @@ ErrorCrit_NSE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T
     if (is.numeric(Crit) & is.finite(Crit)) {
       CritValue <- Crit
     }
-    
+
     ## Verbose
     if (verbose) {
       message(sprintf("Crit. %s = %.4f", EC$CritName, CritValue))
     }
   }
-  
-  
+
+
   ## Output
   OutputsCrit <- list(CritValue       = CritValue,
                       CritName        = EC$CritName,
                       CritBestValue   = EC$CritBestValue,
                       Multiplier      = EC$Multiplier,
-                      Ind_notcomputed = EC$Ind_TS_ignore)  
-  
+                      Ind_notcomputed = EC$Ind_TS_ignore)
+
   class(OutputsCrit) <- c("NSE", "ErrorCrit")
   return(OutputsCrit)
-  
+
 }
+
+class(ErrorCrit_NSE) <- c("FUN_CRIT", class(ErrorCrit_NSE))