ErrorCrit.R

ErrorCrit <- function(InputsCrit, OutputsModel, FUN_CRIT, 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)
    OutputsCrit <- FUN_CRIT(InputsCrit = InputsCrit,
                            OutputsModel = OutputsModel,
                            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)
      FUN_CRIT(InputsCrit = iInputsCrit,
               OutputsModel = 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"]]))
    listweights  <- listweights / sum(listweights)

    if (inherits(InputsCrit, "Compo")) {
      CritValue <- sum(listValCrit * 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: sum(", msgForm, ")\n")
      }
    } else {
      OutputsCrit <- listOutputsCrit
      class(OutputsCrit) <- c("Multi", "ErrorCrit")
    }

  }

  return(OutputsCrit)

}