v1.1.1.0 NEW: ErrorCrit can compute single, multiple or composite criterion

DESCRIPTION

 Package: airGR
 Type: Package
 Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
-Version: 1.1.0.0
-Date: 2018-10-17
+Version: 1.1.1.0
+Date: 2018-10-22
 Authors@R: c(
   person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),
   person("Charles", "Perrin", role = c("aut", "ths"), comment = c(ORCID = "0000-0001-8552-1881")),

R/ErrorCrit.R

-ErrorCrit <- function(InputsCrit,OutputsModel,FUN_CRIT, warnings = TRUE, verbose = TRUE){
-    return( FUN_CRIT(InputsCrit,OutputsModel, warnings = warnings, verbose = verbose) )
+ErrorCrit <- function(InputsCrit, OutputsModel, FUN_CRIT, warnings = TRUE, verbose = TRUE) {
+  
+  ## ---------- Arguments check
+  
+  if (!inherits(InputsCrit, "InputsCrit")) {
+    stop("InputsCrit must be of class 'InputsCrit' \n")
+    return(NULL)
+  }  
+  if (!inherits(OutputsModel, "OutputsModel")) {
+    stop("OutputsModel must be of class 'OutputsModel' \n")
+    return(NULL)
+  }  
+  if (!missing(FUN_CRIT)) {
+    warning("argument 'FUN_CRIT' is deprecated. The error criterion function is now automatically get from the 'InputsCrit' object", call. = FALSE)
+  }
+  
+  
+  
+  ## ---------- Criterion computation
+  
+  ## ----- Single criterion
+  if (inherits(InputsCrit, "Single")) {
+    OutputsCrit <- InputsCrit$FUN_CRIT(InputsCrit,
+                                       OutputsModel,
+                                       warnings = warnings,
+                                       verbose = verbose)
+  }
+  
+  
+  ## ----- Multiple criteria or Composite criterion
+  
+  if (inherits(InputsCrit, "Multi") | inherits(InputsCrit, "Compo")) {
+    listOutputsCrit <- lapply(InputsCrit, FUN = function(iInputsCrit) {
+      iInputsCrit$FUN_CRIT(iInputsCrit, OutputsModel, 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"]]))
+    
+    
+    if (inherits(InputsCrit, "Compo")) {
+      CritValue <- sum(listValCrit * (listweights / sum(listweights)))
+      OutputsCritCompo <- list(MultiCritValues  = listValCrit,
+                               MultiCritNames   = listNameCrit,
+                               MultiCritWeights = listweights)
+      OutputsCrit <- list(CritValue       = CritValue,
+                          CritName        = "Composite",
+                          CritBestValue   = +1,
+                          Multiplier      = -1,
+                          Ind_notcomputed = NULL,
+                          CritCompo       = OutputsCritCompo,
+                          MultiCrit       = listOutputsCrit)
+      class(OutputsCrit) <- c("Compo", "ErrorCrit")
+      if (verbose) {
+        message("------------------------------------\n")
+        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)]
+        msgForm <- paste(msgForm, msgFormSep, sep = "", collapse = "")
+        msgForm <- gsub("\\,\\\n\\\t\\\t     $|\\,$", "", msgForm)
+        message("\tFormula: mean(", msgForm, ")\n")
+      }
+    } else {
+      OutputsCrit <- listOutputsCrit
+      class(OutputsCrit) <- c("Multi", "ErrorCrit")
+    }
+    
+  }
+
+  return(OutputsCrit)
+  
 }
 

man/ErrorCrit.Rd

@@ -18,21 +18,43 @@ ErrorCrit(InputsCrit, OutputsModel, FUN_CRIT, warnings = TRUE, verbose = TRUE)
 
 \item{OutputsModel}{[object of class \emph{OutputsModel}] see \code{\link{RunModel_GR4J}} or \code{\link{RunModel_CemaNeigeGR4J}} for details}
 
-\item{FUN_CRIT}{[function] error criterion function (e.g. \code{\link{ErrorCrit_RMSE}}, \code{\link{ErrorCrit_NSE}})}
+\item{FUN_CRIT}{(deprecated) [function] error criterion function (e.g. \code{\link{ErrorCrit_RMSE}}, \code{\link{ErrorCrit_NSE}})}
 
 \item{warnings}{(optional) [boolean] boolean indicating if the warning messages are shown, default = \code{TRUE}}
 
 \item{verbose}{(optional) [boolean] boolean indicating if the function is run in verbose mode or not, default = \code{TRUE}}
 }
-\value{
-[list] list containing the function outputs, see \code{\link{ErrorCrit_RMSE}} or \code{\link{ErrorCrit_NSE}} for details
-}
 
 
 \description{
 Function which computes an error criterion with the provided function.
 }
 
+\value{
+If \code{InputsCrit} is of class \emph{Single}:
+  \tabular{ll}{
+    [list] containing the \code{ErrorCrit_*} functions outputs, see \code{\link{ErrorCrit_RMSE}} or \code{\link{ErrorCrit_NSE}} for details \cr
+  }
+
+If \code{InputsCrit} is of class \emph{Multi}:
+  \tabular{ll}{
+    [list] of list containing the \code{ErrorCrit_*} functions outputs, see \code{\link{ErrorCrit_RMSE}} or \code{\link{ErrorCrit_NSE}} for details \cr
+  }
+
+If \code{InputsCrit} is of class \emph{Compo}:
+  \tabular{ll}{
+    \emph{$CritValue    } \tab [numeric] value of the composite criterion \cr
+    \emph{$CritName     } \tab [character] name of the composite criterion \cr
+    \emph{$CritBestValue} \tab [numeric] theoretical best criterion value \cr
+    \emph{$Multiplier   } \tab [numeric] integer indicating whether the criterion is indeed an error (+1) or an efficiency (-1) \cr
+    \emph{$CritCompo$MultiCritValues} \tab [numeric] values of the sub-criteria \cr
+    \emph{$CritCompo$MultiCritNames} \tab [numeric] names of the sub-criteria \cr
+    \emph{$CritCompo$MultiCritWeights} \tab [character] weighted values of the sub-criteria \cr
+    \emph{$MultiCrit    } \tab [list] of list containing the \code{ErrorCrit_*} functions outputs, see \code{\link{ErrorCrit_NSE}} or \code{\link{ErrorCrit_KGE}} for details \cr
+  }
+
+}
+
 
 \examples{
 library(airGR)
@@ -40,65 +62,55 @@ library(airGR)
 ## loading catchment data
 data(L0123001)
 
-## preparation of the InputsModel object
+
 InputsModel <- CreateInputsModel(FUN_MOD = RunModel_GR4J, DatesR = BasinObs$DatesR, 
                                  Precip = BasinObs$P, PotEvap = BasinObs$E)
 
-## run period selection
+## calibration period selection
 Ind_Run <- seq(which(format(BasinObs$DatesR, format = "\%d/\%m/\%Y")=="01/01/1990"), 
                which(format(BasinObs$DatesR, format = "\%d/\%m/\%Y")=="31/12/1999"))
 
-## preparation of the RunOptions object
-RunOptions <- CreateRunOptions(FUN_MOD = RunModel_GR4J,
-                               InputsModel = InputsModel, IndPeriod_Run = Ind_Run)
+## preparation of RunOptions object
+RunOptions <- CreateRunOptions(FUN_MOD = RunModel_GR4J, InputsModel = InputsModel, 
+                               IndPeriod_Run = Ind_Run)
 
 ## simulation
-Param <- c(734.568, -0.840, 109.809, 1.971)
-OutputsModel <- RunModel(InputsModel = InputsModel, RunOptions = RunOptions, 
-                         Param = Param, FUN = RunModel_GR4J)
-
-## efficiency criterion: Nash-Sutcliffe Efficiency
-InputsCrit <- CreateInputsCrit(FUN_CRIT = ErrorCrit_NSE, InputsModel = InputsModel, 
-                               RunOptions = RunOptions, Qobs = BasinObs$Qmm[Ind_Run])
-OutputsCrit <- ErrorCrit_NSE(InputsCrit = InputsCrit, OutputsModel = OutputsModel)
-
-## efficiency criterion: Nash-Sutcliffe Efficiency on log-transformed flows
-transfo <- "log"
-InputsCrit <- CreateInputsCrit(FUN_CRIT = ErrorCrit_NSE, InputsModel = InputsModel, 
-                               RunOptions = RunOptions, Qobs = BasinObs$Qmm[Ind_Run],
-                               transfo = transfo)
-OutputsCrit <- ErrorCrit_NSE(InputsCrit = InputsCrit, OutputsModel = OutputsModel)
-
-## efficiency criterion: Nash-Sutcliffe Efficiency above a threshold (q75\%)
-BoolCrit <- rep(TRUE, length(BasinObs$Qmm[Ind_Run]))
-BoolCrit[BasinObs$Qmm[Ind_Run]<quantile(BasinObs$Qmm[Ind_Run], 0.75, na.rm = TRUE)] <- FALSE
-InputsCrit <- CreateInputsCrit(FUN_CRIT = ErrorCrit_NSE, InputsModel = InputsModel, 
-                               RunOptions = RunOptions, Qobs = BasinObs$Qmm[Ind_Run],
-                               BoolCrit = BoolCrit)
-OutputsCrit <- ErrorCrit_NSE(InputsCrit = InputsCrit, OutputsModel = OutputsModel)
-
-## efficiency criterion: Kling-Gupta Efficiency
-InputsCrit <- CreateInputsCrit(FUN_CRIT = ErrorCrit_KGE, InputsModel = InputsModel, 
-                               RunOptions = RunOptions, Qobs = BasinObs$Qmm[Ind_Run])
-OutputsCrit <- ErrorCrit_KGE(InputsCrit = InputsCrit, OutputsModel = OutputsModel)
-
-## efficiency criterion: Kling-Gupta Efficiency below a threshold (q10\%) on log-transformed flows
-transfo  <- "log"
-BoolCrit <- rep(TRUE, length(BasinObs$Qmm[Ind_Run]))
-BoolCrit[BasinObs$Qmm[Ind_Run]>quantile(BasinObs$Qmm[Ind_Run], 0.10, na.rm = TRUE)] <- FALSE
-InputsCrit <- CreateInputsCrit(FUN_CRIT = ErrorCrit_KGE, InputsModel = InputsModel,
-                               RunOptions = RunOptions, Qobs = BasinObs$Qmm[Ind_Run],
-                               BoolCrit = BoolCrit, transfo = transfo)
-OutputsCrit <- ErrorCrit_KGE(InputsCrit = InputsCrit, OutputsModel = OutputsModel)
+Param <- c(257.238, 1.012, 88.235, 2.208)
+OutputsModel <- RunModel_GR4J(InputsModel = InputsModel, RunOptions = RunOptions, Param = Param)
+
+## single efficiency criterion: Nash-Sutcliffe Efficiency
+InputsCritSingle <- CreateInputsCrit(FUN_CRIT = ErrorCrit_NSE,
+                                     InputsModel = InputsModel, RunOptions = RunOptions,
+                                     obs = list(BasinObs$Qmm[Ind_Run]),
+                                     varObs = "Qobs", transfo = "",
+                                     weight = NULL) 
+str(ErrorCrit(InputsCrit = InputsCritSingle, OutputsModel = OutputsModel))
+
+## 2 efficiency critera:  RMSE and the Nash-Sutcliffe Efficiency
+InputsCritMulti <- CreateInputsCrit(FUN_CRIT = list(ErrorCrit_RMSE, ErrorCrit_NSE),
+                                    InputsModel = InputsModel, RunOptions = RunOptions,
+                                    obs = list(BasinObs$Qmm[Ind_Run], BasinObs$Qmm[Ind_Run]),
+                                    varObs = list("Qobs", "Qobs"), transfo = list("", "sqrt"),
+                                    weight = NULL) 
+str(ErrorCrit(InputsCrit = InputsCritMulti, OutputsModel = OutputsModel))
+
+## efficiency composite criterion: Nash-Sutcliffe Efficiency mixing
+##                                 both raw and log-transformed flows
+InputsCritCompo <- CreateInputsCrit(FUN_CRIT = list(ErrorCrit_NSE, ErrorCrit_NSE),
+                                    InputsModel = InputsModel, RunOptions = RunOptions,
+                                    obs = list(BasinObs$Qmm[Ind_Run], BasinObs$Qmm[Ind_Run]),
+                                    varObs = list("Qobs", "Qobs"), transfo = list("", "log"),
+                                    weight = list(0.4, 0.6)) 
+str(ErrorCrit(InputsCrit = InputsCritCompo, OutputsModel = OutputsModel))
 }
 
 
 \author{
-Laurent Coron
+Olivier Delaigue
 }
 
 
 \seealso{
-\code{\link{ErrorCrit_RMSE}}, \code{\link{ErrorCrit_NSE}}, \code{\link{ErrorCrit_KGE}}, \code{\link{ErrorCrit_KGE2}}
+\code{\link{CreateInputsCrit}}, \code{\link{ErrorCrit_RMSE}}, \code{\link{ErrorCrit_NSE}}, \code{\link{ErrorCrit_KGE}}, \code{\link{ErrorCrit_KGE2}}
 }