File: plotCritDifferences.R

package info (click to toggle)
r-cran-mlr 2.19.2%2Bdfsg-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 8,264 kB
  • sloc: ansic: 65; sh: 13; makefile: 5
file content (237 lines) | stat: -rw-r--r-- 10,155 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
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
39
40
41
42
43
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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
#' @title Generate data for critical-differences plot.
#'
#' @description Generates data that can be used to plot a
#' critical differences plot. Computes the critical differences according
#' to either the
#' `"Bonferroni-Dunn"` test or the `"Nemenyi"` test.\cr
#' `"Bonferroni-Dunn"` usually yields higher power as it does not
#' compare all algorithms to each other, but all algorithms to a
#' `baseline` instead. \cr
#' Learners are drawn on the y-axis according to their average rank. \cr
#' For `test = "nemenyi"` a bar is drawn, connecting all groups of not
#' significantly different learners.\cr
#' For `test = "bd"` an interval is drawn arround the algorithm selected
#' as a baseline. All learners within this interval are not signifcantly different
#' from the baseline. \cr
#' Calculation:
#' \deqn{CD = q_{\alpha} \sqrt{\left(\frac{k(k+1)}{6N}\right)}}{CD = q_alpha sqrt(k(k+1)/(6N))} \cr
#' Where \eqn{q_\alpha} is based on the studentized range statistic.
#' See references for details.
#'
#' @template arg_bmr
#' @template arg_measure
#' @param p.value (`numeric(1)`)\cr
#'   P-value for the critical difference. Default: 0.05
#' @param baseline (`character(1)`): (`learner.id`) \cr
#'   Select a `learner.id` as baseline for the `test = "bd"`
#'   ("Bonferroni-Dunn") critical differences
#'   diagram. The critical difference interval will then be positioned arround this learner.
#'   Defaults to best performing algorithm. \cr
#'   For `test = "nemenyi"`, no baseline is needed as it performs *all pairwise
#'   comparisons*.
#' @param test (`character(1)`) \cr
#'   Test for which the critical differences are computed. \cr
#'   \dQuote{bd} for the Bonferroni-Dunn Test, which is comparing all
#'   classifiers to a `baseline`, thus performing a comparison
#'   of one classifier to all others. \cr
#'   Algorithms not connected by a single line are statistically different
#'   from the baseline. \cr
#'   \dQuote{nemenyi} for the [PMCMRplus::frdAllPairsNemenyiTest]
#'   which is comparing all classifiers to each other. The null hypothesis that
#'   there is a difference between the classifiers can not be rejected for all
#'   classifiers that have a single grey bar connecting them.
#' @return (`critDifferencesData`). List containing:
#' \item{data}{(data.frame) containing the info for the descriptive
#'                part of the plot}
#' \item{friedman.nemenyi.test}{(list) of class `pairwise.htest` \cr
#'                                contains the calculated
#'                                [PMCMRplus::frdAllPairsNemenyiTest]}
#' \item{cd.info}{(list) containing info on the critical difference
#'                  and its positioning}
#' \item{baseline}{`baseline` chosen for plotting}
#' \item{p.value}{p.value used for the [PMCMRplus::frdAllPairsNemenyiTest]
#'                  and for computation of the critical difference}
#'
#' @family generate_plot_data
#' @family benchmark
#' @md
#' @export
generateCritDifferencesData = function(bmr, measure = NULL, p.value = 0.05,
  baseline = NULL, test = "bd") {

  assertClass(bmr, "BenchmarkResult")
  assertChoice(test, c("nemenyi", "bd"))
  assertNumeric(p.value, lower = 0, upper = 1, len = 1)
  measure = checkBMRMeasure(measure, bmr)

  # Get Rankmatrix, transpose and get mean ranks
  mean.rank = rowMeans(convertBMRToRankMatrix(bmr, measure))
  # Gather Info for plotting the descriptive part.
  df = data.frame(mean.rank,
    learner.id = names(mean.rank),
    rank = rank(mean.rank, ties.method = "average"))
  # Orientation of descriptive lines yend(=y-value of horizontal line)
  right = df$rank > median(df$rank)
  # Better learners are ranked ascending
  df$yend[!right] = rank(df$rank[!right], ties.method = "first") - 0.5
  # Worse learners ranked descending
  df$yend[right] = rank(-df$rank[right], ties.method = "first") - 0.5
  # Better half of learner have lines to left / others right.
  df$xend = ifelse(!right, 0L, max(df$rank) + 1L)
  # Save orientation, can be used for vjust of text later on
  df$right = as.numeric(right)
  df$short.name = getBMRLearnerShortNames(bmr)

  # Get a baseline
  if (is.null(baseline)) {
    baseline = as.character(df$learner.id[which.min(df$rank)])
  } else {
    assertString(baseline)
    assertChoice(baseline, getBMRLearnerIds(bmr))
  }

  # Perform nemenyi test
  nem.test = friedmanPostHocTestBMR(bmr, measure, p.value)
  # Store Info for plotting the cricital differences
  cd.info = list("test" = test,
    "cd" = nem.test$crit.difference[[test]],
    "x" = df$mean.rank[df$learner.id == baseline],
    "y" = 0.1)

  # Create data for connecting bars (only nemenyi test)
  if (test == "nemenyi") {
    sub = sort(df$mean.rank)
    # Compute a matrix of all possible bars
    mat = apply(t(outer(sub, sub, `-`)), c(1, 2),
      FUN = function(x) ifelse(x > 0 && x < cd.info$cd, x, 0))
    # Get start and end point of all possible bars
    xstart = round(apply(mat + sub, 1, min), 3)
    xend = round(apply(mat + sub, 1, max), 3)
    nem.df = data.table(xstart, xend, "diff" = xend - xstart)
    # For each unique endpoint of a bar keep only the longest bar
    nem.df = nem.df[, .SD[which.max(.SD$diff)], by = "xend"]
    # Take only bars with length > 0
    nem.df = nem.df[nem.df$xend - nem.df$xstart > 0, ]
    # Y-value for bars is between 0.1 and 0..35 hardcoded
    # Descriptive lines for learners start at 0.5, 1.5, ...
    nem.df$y = seq(from = 0.1, to = 0.35, length.out = dim(nem.df)[1])
    cd.info$nemenyi.data = as.data.frame(nem.df)
  }

  makeS3Obj("CritDifferencesData",
    "data" = df,
    "cd.info" = cd.info,
    "friedman.nemenyi.test" = nem.test,
    "baseline" = baseline,
    "p.value" = p.value)
}
#' @title Plot critical differences for a selected measure.
#'
#' @description Plots a critical-differences diagram for all classifiers and a
#'   selected measure. If a baseline is selected for the Bonferroni-Dunn test,
#'   the critical difference interval will be positioned around the baseline. If
#'   not, the best performing algorithm will be chosen as baseline.
#'
#'   The positioning of some descriptive elements can be moved by modifying the
#'   generated data.
#'
#' @param obj (`critDifferencesData`)
#'   Result of [generateCritDifferencesData()].
#' @param baseline (`character(1)`): (`learner.id`)\cr
#'   Overwrites baseline from [generateCritDifferencesData()]!\cr
#'   Select a `learner.id` as baseline for the critical difference
#'   diagram, the critical difference will be positioned around this learner.
#'   Defaults to best performing algorithm.
#' @template arg_prettynames
#' @template ret_gg2
#'
#' @references Janez Demsar, Statistical Comparisons of Classifiers over
#'   Multiple Data Sets, JMLR, 2006
#' @family plot
#' @family benchmark
#' @export
#' @examples
#' # see benchmark
plotCritDifferences = function(obj, baseline = NULL, pretty.names = TRUE) {

  assertClass(obj, "CritDifferencesData")

  # Plot descritptive lines and learner names
  p = ggplot(obj$data)
  # Point at mean rank
  p = p + geom_point(aes_string("mean.rank", 0, colour = "learner.id"), size = 3)
  # Horizontal descriptive bar
  p = p + geom_segment(aes_string("mean.rank", 0, xend = "mean.rank", yend = "yend",
    color = "learner.id"), size = 1)
  # Vertical descriptive bar
  p = p + geom_segment(aes_string("mean.rank", "yend", xend = "xend",
    yend = "yend", color = "learner.id"), size = 1)
  # Plot Learner name
  if (pretty.names) {
    p = p + geom_text(aes_string("xend", "yend", label = "short.name", color = "learner.id",
      hjust = "right"), vjust = -1)
  } else {
    p = p + geom_text(aes_string("xend", "yend", label = "learner.id", color = "learner.id",
      hjust = "right"), vjust = -1)
  }
  p = p + xlab("Average Rank")
  # Change appearance
  p = p + scale_x_continuous(breaks = c(0:max(obj$data$xend)))
  p = p + theme(axis.text.y = element_blank(),
    axis.ticks.y = element_blank(),
    axis.title.y = element_blank(),
    legend.position = "none",
    panel.background = element_blank(),
    panel.border = element_blank(),
    axis.line = element_line(size = 1),
    axis.line.y = element_blank(),
    panel.grid.major = element_blank(),
    plot.background = element_blank())

  # Write some values into shorter names as they are used numerous times.
  cd.x = obj$cd.info$x
  cd.y = obj$cd.info$y
  cd = obj$cd.info$cd

  # Plot the critical difference bars
  if (obj$cd.info$test == "bd") {
    if (!is.null(baseline)) {
      assertChoice(baseline, as.character(obj$data$learner.id))
      cd.x = obj$data$mean.rank[obj$data$learner.id == baseline]
    }
    # Add horizontal bar arround baseline
    p = p + annotate("segment", x = cd.x + cd, xend = cd.x - cd, y = cd.y, yend = cd.y,
      alpha = 0.5, color = "darkgrey", size = 2)
    # Add intervall limiting bar's
    p = p + annotate("segment", x = cd.x + cd, xend = cd.x + cd, y = cd.y - 0.05,
      yend = cd.y + 0.05, color = "darkgrey", size = 1)
    p = p + annotate("segment", x = cd.x - cd, xend = cd.x - cd, y = cd.y - 0.05,
      yend = cd.y + 0.05, color = "darkgrey", size = 1)
    # Add point at learner
    p = p + annotate("point", x = cd.x, y = cd.y, alpha = 0.5)
    # Add critical difference text
    p = p + annotate("text", label = stri_paste("Critical Difference =", round(cd, 2), sep = " "),
      x = cd.x, y = cd.y + 0.05)
  } else {
    nemenyi.data = obj$cd.info$nemenyi.data
    if (!(nrow(nemenyi.data) == 0L)) {
      # Add connecting bars
      p = p + geom_segment(aes_string("xstart", "y", xend = "xend", yend = "y"),
        data = nemenyi.data, size = 2, color = "dimgrey", alpha = 0.9)
      # Add text (descriptive)
      p = p + annotate("text",
        label = stri_paste("Critical Difference =", round(cd, 2), sep = " "),
        y = max(obj$data$yend) + .1, x = mean(obj$data$mean.rank))
      # Add bar (descriptive)
      p = p + annotate("segment",
        x = mean(obj$data$mean.rank) - 0.5 * cd,
        xend = mean(obj$data$mean.rank) + 0.5 * cd,
        y = max(obj$data$yend) + .2,
        yend = max(obj$data$yend) + .2,
        size = 2L)
    } else {
      message("No connecting bars to plot!")
    }
  }
  return(p)
}