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)
}
|