From 67537771ce2e8a88ab22ab08d32c345396efda46 Mon Sep 17 00:00:00 2001 From: likunlan Date: Wed, 11 Apr 2018 00:08:08 +0800 Subject: [PATCH 1/4] add crit difference plot --- DESCRIPTION | 2 + NAMESPACE | 1 + R/critDifferencesPlot.R | 100 ++++++++++++++++++ inst/shiny/ui.R | 2 + man/createcritDifferencesPlot.Rd | 24 +++++ .../testthat/test_checkCritDifferencesPlot.R | 7 ++ 6 files changed, 136 insertions(+) create mode 100644 R/critDifferencesPlot.R create mode 100644 man/createcritDifferencesPlot.Rd create mode 100644 tests/testthat/test_checkCritDifferencesPlot.R diff --git a/DESCRIPTION b/DESCRIPTION index a0f0234..eb83bd1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -39,6 +39,8 @@ Suggests: ParamHelpers (>= 1.10), kernlab, magrittr, + stringi, + BBmisc, dplyr, knitr, rmarkdown diff --git a/NAMESPACE b/NAMESPACE index 1d1c4eb..7e9e756 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,6 +5,7 @@ export(checkColumnNames) export(checkStructure) export(createBarPlot) export(createBoxPlot) +export(createCritDifferencesPlot) export(createDensityPlot) export(createDensityRankPlot) export(createDualMeasurePlot) diff --git a/R/critDifferencesPlot.R b/R/critDifferencesPlot.R new file mode 100644 index 0000000..8136113 --- /dev/null +++ b/R/critDifferencesPlot.R @@ -0,0 +1,100 @@ +#' @title create a crit differences plot +#' +#' @description +#' Create critDifferences plot out of a benchmarkVis compatible data table. +#' +#' @param dt compatible data table +#' @param measure the measure to plot +#' @param group.by the column to group the markers by. Possibilities: "algorithm", "problem", "replication" (default: "problem") +#' @return a crit differences plot +#' @export +#' @examples +#' createCritDifferencesPlot(mlr.benchmark.example, "measure.mmce.test.mean") +createCritDifferencesPlot = function(dt, measure, group.by = "problem") { + # Checks + checkmate::assert_data_table(dt) + checkmate::assert_string(group.by) + checkmate::assert_true(group.by %in% getMainColumns(dt)) + checkmate::assert_string(measure) + checkmate::assert_true(measure %in% getMeasures(dt)) + #first part, genarate S3Obj object + `%>%` = magrittr::`%>%` + df = dt %>% dplyr::group_by(dt[[group.by]]) %>% dplyr::mutate(my_ranks = order(order(eval(parse(text = sprintf("%s", measure))), decreasing = TRUE))) + + mat = matrix(unlist(df$my_ranks), ncol = 3, byrow = TRUE) + rownames(mat) = unique(df$problem) + colnames(mat) = unique(df$algorithm) + rn = as.character.factor(unique(df$problem)) + cn = unique(df$algorithm) + mat = t(mat) + + mean.rank = rowMeans(mat) + cddf = data.frame( + mean.rank, + learner.id = names(mean.rank), + rank = rank(mean.rank, ties.method = "average") + ) + right = cddf$rank > median(cddf$rank) + cddf$yend[!right] = rank(cddf$rank[!right], ties.method = "first") - + 0.5 + cddf$yend[right] = rank(-cddf$rank[right], ties.method = "first") - + 0.5 + cddf$xend = ifelse(!right, 0L, max(cddf$rank) + 1L) + cddf$right = as.numeric(right) + cddf$short.name = unique(df$algorithm) + baseline = as.character(cddf$learner.id[which.min(cddf$rank)]) + + #nem.test = friedmanPostHocTestBMR(bmr, measure, p.value) + + pfdf = data.frame( + "task.id" = df$problem, + "learner.id" = df$algorithm, + "tmpname" = df[[measure]] + ) + + aggr.meas = measure + + data.table::setnames(pfdf, "tmpname", measure) + + nem.test = stats::friedman.test(as.formula(stringi::stri_paste(aggr.meas, " ~ learner.id | task.id", + sep = "")), data = pfdf) + test = "nemenyi" + + cd.info = list( + test = test, + cd = nem.test$crit.difference[[test]], + x = cddf$mean.rank[cddf$learner.id == baseline], + y = 0.1 + ) + #if (test == "nemenyi") { + sub = sort(cddf$mean.rank) + mat = apply( + t(outer(sub, sub, `-`)), + c(1, 2), + FUN = function(x) + ifelse(x > + 0 && + x < cd.info$cd, x, 0) + ) + xstart = round(apply(mat + sub, 1, min), 3) + xend = round(apply(mat + sub, 1, max), 3) + nem.df = data.table::data.table(xstart, xend, diff = xend - xstart) + nem.df = nem.df[, data.table::.SD[which.max(data.table::.SD$diff)], by = "xend"] + nem.df = nem.df[nem.df$xend - nem.df$xstart > 0, ] + 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) + #} + p.value = 0.05 + obj = BBmisc::makeS3Obj( + "CritDifferencesData", + data = cddf, + cd.info = cd.info, + friedman.nemenyi.test = nem.test, + baseline = baseline, + p.value = p.value + ) + p = mlr::plotCritDifferences(obj) + return(p) +} diff --git a/inst/shiny/ui.R b/inst/shiny/ui.R index 604a2af..34316bd 100644 --- a/inst/shiny/ui.R +++ b/inst/shiny/ui.R @@ -5,6 +5,8 @@ library(plotly) library(shinyjs) library(V8) library(shinyBS) +library(stringi) +library(BBmisc) #needed for shinyapps.io #library(devtools) #devtools::install_github("collinleiber/benchmarkVis") diff --git a/man/createcritDifferencesPlot.Rd b/man/createcritDifferencesPlot.Rd new file mode 100644 index 0000000..bd4a101 --- /dev/null +++ b/man/createcritDifferencesPlot.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/critDifferencesPlot.R +\name{createCritDifferencesPlot} +\alias{createCritDifferencesPlot} +\title{create a crit differences plot} +\usage{ +createCritDifferencesPlot(dt, measure, group.by = "problem") +} +\arguments{ +\item{dt}{compatible data table} + +\item{measure}{the measure to plot} + +\item{group.by}{the column to group the markers by. Possibilities: "algorithm", "problem", "replication" (default: "problem")} +} +\value{ +a crit differences plot +} +\description{ +Create critDifferences plot out of a benchmarkVis compatible data table. +} +\examples{ +createCritDifferencesPlot(mlr.benchmark.example, "measure.mmce.test.mean") +} diff --git a/tests/testthat/test_checkCritDifferencesPlot.R b/tests/testthat/test_checkCritDifferencesPlot.R new file mode 100644 index 0000000..974a4e3 --- /dev/null +++ b/tests/testthat/test_checkCritDifferencesPlot.R @@ -0,0 +1,7 @@ +context("CritDifferences Plot") + +# Check if creating a CritDifferences plot throws an error +test_that("createCritDifferences for mlr benchmark", { + p = createCritDifferencesPlot(mlr.benchmark.example, "measure.mmce.test.mean") + expect_true(is.list(p)) +}) From 0bd46b973899f727ab080eba6f6d9a7c901badc1 Mon Sep 17 00:00:00 2001 From: likunlan Date: Fri, 13 Apr 2018 02:08:50 +0800 Subject: [PATCH 2/4] update --- R/critDifferencesPlot.R | 94 ++++++++++++++----- .../testthat/test_checkCritDifferencesPlot.R | 12 +++ 2 files changed, 80 insertions(+), 26 deletions(-) diff --git a/R/critDifferencesPlot.R b/R/critDifferencesPlot.R index 8136113..67ea555 100644 --- a/R/critDifferencesPlot.R +++ b/R/critDifferencesPlot.R @@ -10,13 +10,14 @@ #' @export #' @examples #' createCritDifferencesPlot(mlr.benchmark.example, "measure.mmce.test.mean") -createCritDifferencesPlot = function(dt, measure, group.by = "problem") { +createCritDifferencesPlot = function(dt, measure, group.by = "problem", test.str = "bd", p.value = 0.05) { # Checks checkmate::assert_data_table(dt) checkmate::assert_string(group.by) checkmate::assert_true(group.by %in% getMainColumns(dt)) checkmate::assert_string(measure) checkmate::assert_true(measure %in% getMeasures(dt)) + checkmate::assert_true(test.str %in% list("nemenyi", "bd")) #first part, genarate S3Obj object `%>%` = magrittr::`%>%` df = dt %>% dplyr::group_by(dt[[group.by]]) %>% dplyr::mutate(my_ranks = order(order(eval(parse(text = sprintf("%s", measure))), decreasing = TRUE))) @@ -54,39 +55,80 @@ createCritDifferencesPlot = function(dt, measure, group.by = "problem") { aggr.meas = measure - data.table::setnames(pfdf, "tmpname", measure) + pfdf = data.table::setnames(pfdf, "tmpname", measure) + + if (length(unique(pfdf$task.id)) < 2) { + stop("Benchmark results for at least two tasks are required") + } + if (length(unique(pfdf$learner.id)) < 2) { + stop("Benchmark results for at least two learners are required") + } nem.test = stats::friedman.test(as.formula(stringi::stri_paste(aggr.meas, " ~ learner.id | task.id", sep = "")), data = pfdf) - test = "nemenyi" + #test = test.str + + f.test = nem.test + n.learners = length(unique(pfdf$learner.id)) + n.tasks = length(unique(pfdf$task.id)) + if (!is.na(f.test$p.value)) { + f.rejnull = f.test$p.value < p.value + if (!f.rejnull) + warning("Cannot reject null hypothesis of overall Friedman test,\n returning overall Friedman test.") + } else { + f.rejnull = FALSE + warning("P-value not computable. Learner performances might be exactly equal.") + } + q.nemenyi = qtukey(1 - p.value, n.learners, 1e+06)/sqrt(2L) + cd.nemenyi = q.nemenyi * sqrt(n.learners * (n.learners + + 1L)/(6L * n.tasks)) + q.bd = qtukey(1L - (p.value/(n.learners - 1L)), 2L, 1e+06)/sqrt(2L) + cd.bd = q.bd * sqrt(n.learners * (n.learners + 1L)/(6L * + n.tasks)) + if (f.rejnull) { + form = as.formula(stri_paste(aggr.meas, " ~ learner.id | task.id", + sep = "")) + nem.test = PMCMR::posthoc.friedman.nemenyi.test(form, + data = df) + nem.test$crit.difference = list(nemenyi = cd.nemenyi, + bd = cd.bd) + nem.test$f.rejnull = f.rejnull + return(nem.test) + } else { + f.test$f.rejnull = f.rejnull + f.test$crit.difference = list(nemenyi = cd.nemenyi, + bd = cd.bd) + } + nem.test = f.test cd.info = list( - test = test, - cd = nem.test$crit.difference[[test]], + test = test.str, + cd = nem.test$crit.difference[[test.str]], x = cddf$mean.rank[cddf$learner.id == baseline], y = 0.1 ) - #if (test == "nemenyi") { - sub = sort(cddf$mean.rank) - mat = apply( - t(outer(sub, sub, `-`)), - c(1, 2), - FUN = function(x) - ifelse(x > - 0 && - x < cd.info$cd, x, 0) - ) - xstart = round(apply(mat + sub, 1, min), 3) - xend = round(apply(mat + sub, 1, max), 3) - nem.df = data.table::data.table(xstart, xend, diff = xend - xstart) - nem.df = nem.df[, data.table::.SD[which.max(data.table::.SD$diff)], by = "xend"] - nem.df = nem.df[nem.df$xend - nem.df$xstart > 0, ] - 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) - #} - p.value = 0.05 + + if (test.str == "nemenyi") { + sub = sort(cddf$mean.rank) + mat = apply( + t(outer(sub, sub, `-`)), + c(1, 2), + FUN = function(x) + ifelse(x > + 0 && + x < cd.info$cd, x, 0) + ) + xstart = round(apply(mat + sub, 1, min), 3) + xend = round(apply(mat + sub, 1, max), 3) + nem.df = data.table::data.table(xstart, xend, diff = xend - xstart) + nem.df = nem.df[, data.table::.SD[which.max(data.table::.SD$diff)], by = "xend"] + nem.df = nem.df[nem.df$xend - nem.df$xstart > 0,] + 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) + } + obj = BBmisc::makeS3Obj( "CritDifferencesData", data = cddf, diff --git a/tests/testthat/test_checkCritDifferencesPlot.R b/tests/testthat/test_checkCritDifferencesPlot.R index 974a4e3..c7a316c 100644 --- a/tests/testthat/test_checkCritDifferencesPlot.R +++ b/tests/testthat/test_checkCritDifferencesPlot.R @@ -5,3 +5,15 @@ test_that("createCritDifferences for mlr benchmark", { p = createCritDifferencesPlot(mlr.benchmark.example, "measure.mmce.test.mean") expect_true(is.list(p)) }) + +# Check if creating a CritDifferences plot throws an error +# test_that("createCritDifferences for mlr benchmark", { +# p = createCritDifferencesPlot(large.benchmark, "measure.mmce.test.mean") +# expect_true(is.list(p)) +# }) + +# Check if creating a CritDifferences plot throws an error +# test_that("createCritDifferences for mlr benchmark", { +# p = createCritDifferencesPlot(microbenchmark.example, "measure.min") +# expect_true(is.list(p)) +# }) From e96678d3d08dba41346b447f1a13ee38afb9e610 Mon Sep 17 00:00:00 2001 From: likunlan Date: Fri, 13 Apr 2018 14:05:57 +0800 Subject: [PATCH 3/4] update --- R/critDifferencesPlot.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/critDifferencesPlot.R b/R/critDifferencesPlot.R index 67ea555..fbdc89c 100644 --- a/R/critDifferencesPlot.R +++ b/R/critDifferencesPlot.R @@ -79,11 +79,11 @@ createCritDifferencesPlot = function(dt, measure, group.by = "problem", test.str f.rejnull = FALSE warning("P-value not computable. Learner performances might be exactly equal.") } - q.nemenyi = qtukey(1 - p.value, n.learners, 1e+06)/sqrt(2L) + q.nemenyi = qtukey(1 - p.value, n.learners, 1e+06) / sqrt(2L) cd.nemenyi = q.nemenyi * sqrt(n.learners * (n.learners + - 1L)/(6L * n.tasks)) - q.bd = qtukey(1L - (p.value/(n.learners - 1L)), 2L, 1e+06)/sqrt(2L) - cd.bd = q.bd * sqrt(n.learners * (n.learners + 1L)/(6L * + 1L) / (6L * n.tasks)) + q.bd = qtukey(1L - (p.value/(n.learners - 1L)), 2L, 1e+06) / sqrt(2L) + cd.bd = q.bd * sqrt(n.learners * (n.learners + 1L) / (6L * n.tasks)) if (f.rejnull) { form = as.formula(stri_paste(aggr.meas, " ~ learner.id | task.id", @@ -122,7 +122,7 @@ createCritDifferencesPlot = function(dt, measure, group.by = "problem", test.str xend = round(apply(mat + sub, 1, max), 3) nem.df = data.table::data.table(xstart, xend, diff = xend - xstart) nem.df = nem.df[, data.table::.SD[which.max(data.table::.SD$diff)], by = "xend"] - nem.df = nem.df[nem.df$xend - nem.df$xstart > 0,] + nem.df = nem.df[nem.df$xend - nem.df$xstart > 0, ] nem.df$y = seq(from = 0.1, to = 0.35, length.out = dim(nem.df)[1]) From c6d0d7fb7cc019c6e8c8d79fa3b343b0576294b9 Mon Sep 17 00:00:00 2001 From: likunlan Date: Fri, 13 Apr 2018 14:24:17 +0800 Subject: [PATCH 4/4] update --- R/critDifferencesPlot.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/critDifferencesPlot.R b/R/critDifferencesPlot.R index fbdc89c..f8d037c 100644 --- a/R/critDifferencesPlot.R +++ b/R/critDifferencesPlot.R @@ -82,7 +82,7 @@ createCritDifferencesPlot = function(dt, measure, group.by = "problem", test.str q.nemenyi = qtukey(1 - p.value, n.learners, 1e+06) / sqrt(2L) cd.nemenyi = q.nemenyi * sqrt(n.learners * (n.learners + 1L) / (6L * n.tasks)) - q.bd = qtukey(1L - (p.value/(n.learners - 1L)), 2L, 1e+06) / sqrt(2L) + q.bd = qtukey(1L - (p.value / (n.learners - 1L)), 2L, 1e+06) / sqrt(2L) cd.bd = q.bd * sqrt(n.learners * (n.learners + 1L) / (6L * n.tasks)) if (f.rejnull) {