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
|
load (sprintf ("%s/data/lsmr_global_tuning.Rdata", Sys.getenv ("ABS_TOP_SRCDIR")))
#' Compute the Friedman + Nemenyi analysis with the tsutils package.
#'
#' @return the tsutils analysis.
#' @export
cd_analysis <- function () {
`%>%` <- magrittr::`%>%`
data <- (global_tuning_data
%>% dplyr::select (`LSMR local` = lsmr_local, dplyr::everything ())
%>% dplyr::select (-dataset))
colnames (data) <- toupper (colnames (data))
colnames (data) <- gsub ("LOCAL", "local", colnames (data))
tsutils::nemenyi (as.matrix (data), plottype = "vmcb")
}
## Expects that higher is better. Returns -1 if the first is better,
## +1 if the second is better, and 0 otherwise.
paired_test_aux <- function (algo1, algo2) {
diff <- algo2 - algo1
magnitude <- abs (diff)
sorted_magnitude <- sort (magnitude)
get_rank <- function (diff) {
m <- abs (diff)
ok <- which (sorted_magnitude == m)
mean (ok)
}
ranks <- sapply (diff, get_rank)
positives <- which (diff > 0)
negatives <- which (diff < 0)
ties <- which (diff == 0)
Rplus <- sum (ranks[positives]) + sum (ranks[ties]) / 2
Rminus <- sum (ranks[negatives]) + sum (ranks[ties]) / 2
ret <- 0
if (Rplus < Rminus) {
ret <- -1
} else {
ret <- +1
}
T <- min (Rplus, Rminus)
N <- length (diff)
znum <- (T - (1 / 4) * N * (N + 1))
## ------------------------------
zdenom <- sqrt ((1 / 24) * N * (N + 1) * (2 * N + 1))
z <- znum / zdenom
alpha <- 0.1
crit <- qnorm (1 - alpha / 2)
if (z >= -crit) {
ret <- 0
}
ret
}
paired_test <- function (algo1, algo2) {
data <- global_tuning_data
algo1 <- data[, algo1 + 1][[1]]
algo2 <- data[, algo2 + 1][[1]]
paired_test_aux (-algo1, -algo2)
}
#' Compute the win / lose / tie matrix for all pairs of algorithms.
#' @return the matrix with row and column names set to the names of
#' the algorithms.
#' @export
win_lose_tie_paired_tests <- function () {
data <- global_tuning_data
M <- matrix (0, ncol (data) - 1, ncol (data) - 1)
colnames (M) <- toupper (gsub ("_", "\n", colnames (data)[2:ncol (data)], fixed = TRUE))
colnames (M) <- gsub ("LOCAL", "local", colnames (M))
row.names (M) <- colnames (M)
colnames (M) <- gsub ("LSMR\nlocal", "LSMR (l)", colnames (M), fixed = TRUE)
for (i in seq_len (ncol (data) - 1)) {
for (j in seq_len (ncol (data) - 1)) {
M[i, j] <- paired_test (i, j)
}
}
M
}
#' Print the plot of the win / lose / tie matrix
#' @return Org-mode code
#' @export
print_win_lose_tie_plot <- function () {
M <- win_lose_tie_paired_tests ()
data <- reshape2::melt (M, na.rm = TRUE)
(ggplot2::ggplot (data = data,
ggplot2::aes (Var2, Var1, fill = value))
+ ggplot2::geom_tile (color = "white")
+ ggplot2::scale_fill_gradient2 (low = "blue", high = "red", mid = "#FFFFFF00",
midpoint = 0, limit = c (-1, 1), name = "significant test")
+ ggplot2::theme (legend.position = "none")
+ ggplot2::theme (axis.title = ggplot2::element_blank ())
+ ggplot2::theme (axis.text.x = ggplot2::element_text (angle=45, hjust=1)))
}
|
