From bb1ae75c56d34a65662d7b285333c595c0ddae7f Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Wed, 7 Apr 2021 12:05:36 +0200
Subject: Nouvelle version du manuscrit avec HTML

---
 images/lsmr_global_tuning.R | 94 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 94 insertions(+)
 create mode 100644 images/lsmr_global_tuning.R

(limited to 'images/lsmr_global_tuning.R')

diff --git a/images/lsmr_global_tuning.R b/images/lsmr_global_tuning.R
new file mode 100644
index 0000000..3753e09
--- /dev/null
+++ b/images/lsmr_global_tuning.R
@@ -0,0 +1,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)))
+}
-- 
cgit v1.2.3