ErrorCrit.R 2.87 KB
Newer Older
1
2
ErrorCrit <- function(InputsCrit, OutputsModel, FUN_CRIT, warnings = TRUE, verbose = TRUE) {
  
3
  
4
5
6
  ## ---------- Arguments check
  
  if (!inherits(InputsCrit, "InputsCrit")) {
7
    stop("InputsCrit must be of class 'InputsCrit'")
8
9
  }  
  if (!inherits(OutputsModel, "OutputsModel")) {
10
    stop("OutputsModel must be of class 'OutputsModel'")
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
  }  
  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"]]))
39
    listweights <- listweights / sum(listweights)
40
41
42
    
    
    if (inherits(InputsCrit, "Compo")) {
43
      CritValue <- sum(listValCrit * listweights)
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
      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)
  
Delaigue Olivier's avatar
Delaigue Olivier committed
74
75
}