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
  }  
  if (!missing(FUN_CRIT)) {
13
    warning("deprecated 'FUN_CRIT' argument. The error criterion function is now automatically get from the 'InputsCrit' object", call. = FALSE)
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
  }
  
  
  
  ## ---------- 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
}