├── vignettes ├── .gitignore ├── SingleTask_aggregate-then-rank.R ├── quickstart.Rmd ├── MultiTask_rank-then-aggregate.R └── MultiTask_test-then-rank.R ├── DKFZ_Logo.png ├── .gitignore ├── inst ├── appdir │ ├── overviewSingleTaskNoBootstrapping.Rmd │ ├── overviewSingleTaskBootstrapping.Rmd │ ├── overviewMultiTaskNoBootstrapping.Rmd │ ├── consensusRanking.Rmd │ ├── overviewMultiTaskBootstrapping.Rmd │ ├── visualizationViolinPlots.Rmd │ ├── visualizationBlobPlots.Rmd │ ├── characterizationOfTasksBootstrapping.Rmd │ ├── characterizationOfAlgorithmsBootstrapping.Rmd │ └── visualizationAcrossTasks.Rmd └── CITATION ├── man ├── aggregate.challenge.Rd ├── violin.bootstrap.list.Rd ├── consensus.ranked.list.Rd ├── stability.ranked.list.Rd ├── rankingHeatmap.challenge.Rd ├── rankingHeatmap.ranked.list.Rd ├── dendrogram.ranked.list.Rd ├── rankThenAggregate.Rd ├── boxplot.ranked.list.Rd ├── significanceMap.ranked.list.Rd ├── aggregateThenRank.Rd ├── stabilityByAlgorithm.bootstrap.list.Rd ├── podium.challenge.Rd ├── testThenRank.Rd ├── podium.ranked.list.Rd ├── stabilityByTask.bootstrap.list.Rd ├── bootstrap.ranked.list.Rd ├── methodsplot.challenge.Rd ├── subset.ranked.list.Rd ├── subset.bootstrap.list.Rd ├── report.ranked.list.Rd ├── report.bootstrap.list.Rd └── as.challenge.Rd ├── R ├── extract.workflow.R ├── by.R ├── melt.R ├── winner.R ├── rankNA2.R ├── default_colors.R ├── benchmarkUtils.R ├── S3.R ├── firstlib.R ├── select.R ├── relation.R ├── compareRanks.R ├── consensus.R ├── merge.list.R ├── rrank.R ├── dendrogram.R ├── Rank.aggregated.list.R ├── boxplot.R ├── Rank.R ├── rankingMethods.R ├── rankingHeatmap.R ├── violin.R ├── Aggregate.R ├── methodsplot.R ├── graph.R ├── aaggregate.R ├── significanceMap.R ├── testBased.R └── subset.R ├── tests ├── testthat.R └── testthat │ ├── test-linePlot.R │ ├── test-violinPlot.R │ ├── test-blobPlotStabilityByTask.R │ ├── test-significanceMap.R │ ├── test-boxplot.R │ ├── test-rankingHeatmap.R │ ├── test-blobPlotStabilityAcrossTasks.R │ ├── test-bootstrap.R │ ├── test-networkPlot.R │ └── test-stackedBarPlotStabilityByAlgorithm.R ├── DESCRIPTION ├── NAMESPACE └── Helmholtz_Imaging_Logo.svg /vignettes/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | *.R 3 | -------------------------------------------------------------------------------- /DKFZ_Logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/wiesenfa/challengeR/HEAD/DKFZ_Logo.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | inst/doc 6 | doc 7 | Meta 8 | .vscode 9 | -------------------------------------------------------------------------------- /inst/appdir/overviewSingleTaskNoBootstrapping.Rmd: -------------------------------------------------------------------------------- 1 | * Visualization of assessment data: Dot- and boxplot, podium plot and ranking heatmap 2 | * Visualization of ranking stability: Significance map, line plot 3 | -------------------------------------------------------------------------------- /inst/appdir/overviewSingleTaskBootstrapping.Rmd: -------------------------------------------------------------------------------- 1 | * Visualization of assessment data: Dot- and boxplot, podium plot and ranking heatmap 2 | * Visualization of ranking stability: Blob plot, violin plot and significance map, line plot 3 | -------------------------------------------------------------------------------- /inst/appdir/overviewMultiTaskNoBootstrapping.Rmd: -------------------------------------------------------------------------------- 1 | * Visualization of assessment data: Dot- and boxplots, podium plots and ranking heatmaps 2 | * Visualization of ranking stability: Significance maps, line plots 3 | * Visualization of cross-task insights: Blob plot, dendrogram 4 | -------------------------------------------------------------------------------- /inst/appdir/consensusRanking.Rmd: -------------------------------------------------------------------------------- 1 | Consensus ranking across tasks according to chosen method "`r attr(params$consensus,"method")`": 2 | ```{r} 3 | knitr::kable(data.frame(value=round(params$consensus,3), 4 | rank=rank(params$consensus, 5 | ties.method="min"))) 6 | ``` 7 | -------------------------------------------------------------------------------- /inst/appdir/overviewMultiTaskBootstrapping.Rmd: -------------------------------------------------------------------------------- 1 | * Visualization of assessment data: Dot- and boxplots, podium plots and ranking heatmaps 2 | * Visualization of ranking stability: Blob plots, violin plots and significance maps, line plots 3 | * Visualization of cross-task insights: Blob plots, stacked frequency plots, dendrograms 4 | -------------------------------------------------------------------------------- /man/aggregate.challenge.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/aaggregate.R 3 | \name{aggregate.challenge} 4 | \alias{aggregate.challenge} 5 | \title{Title} 6 | \usage{ 7 | \method{aggregate}{challenge}( 8 | x, 9 | FUN = mean, 10 | na.treat, 11 | alpha = 0.05, 12 | p.adjust.method = "none", 13 | parallel = FALSE, 14 | progress = "none", 15 | ... 16 | ) 17 | } 18 | \arguments{ 19 | \item{...}{} 20 | } 21 | \value{ 22 | 23 | } 24 | \description{ 25 | Title 26 | } 27 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | bibentry( 2 | bibtype="Article", 3 | title={"Methods and open-source toolkit for analyzing and visualizing challenge results"}, 4 | journal={"Scientific Reports"}, 5 | year="2021", 6 | author=personList(as.person("Manuel Wiesenfarth"), as.person("Annika Reinke"), as.person("Bennett A. Landman"), as.person("Matthias Eisenmann"), as.person("Laura Aguilera Saiz"), as.person("Manuel Jorge Cardoso"), as.person("Lena Maier-Hein"), as.person("Annette Kopp-Schneider")), 7 | textVersion="Wiesenfarth, M., Reinke, A., Landman, B.A., Eisenmann, M., Aguilera Saiz, L., Cardoso, M.J., Maier-Hein, L. and Kopp-Schneider, A. Methods and open-source toolkit for analyzing and visualizing challenge results. Sci Rep 11, 2369 (2021). https://doi.org/10.1038/s41598-021-82017-6" 8 | ) 9 | -------------------------------------------------------------------------------- /R/extract.workflow.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | extract.workflow=function(x) x$FUN 20 | -------------------------------------------------------------------------------- /inst/appdir/visualizationViolinPlots.Rmd: -------------------------------------------------------------------------------- 1 | \newpage 2 | 3 | ## *Violin plot* for visualizing ranking stability based on bootstrapping \label{violin} 4 | 5 | The ranking list based on the full assessment data is pairwise compared with the ranking lists based on the individual bootstrap samples (here $b=$ `r ncol(boot_object$bootsrappedRanks[[1]])` samples). For each pair of rankings, Kendall's $\tau$ correlation is computed. Kendall’s $\tau$ is a scaled index determining the correlation between the lists. It is computed by evaluating the number of pairwise concordances and discordances between ranking lists and produces values between $-1$ (for inverted order) and $1$ (for identical order). A violin plot, which simultaneously depicts a boxplot and a density plot, is generated from the results. 6 | 7 | \bigskip 8 | 9 | ```{r violin, results='asis'} 10 | violin(boot_object) 11 | ``` 12 | 13 | \newpage 14 | -------------------------------------------------------------------------------- /man/violin.bootstrap.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/violin.R 3 | \name{violin.bootstrap.list} 4 | \alias{violin.bootstrap.list} 5 | \title{Creates a violin plot} 6 | \usage{ 7 | \method{violin}{bootstrap.list}(x, ...) 8 | } 9 | \arguments{ 10 | \item{x}{The bootstrapped, ranked assessment data set.} 11 | 12 | \item{...}{Further arguments passed to or from other functions.} 13 | } 14 | \value{ 15 | 16 | } 17 | \description{ 18 | Creates a violin plot from a bootstrapped, ranked assessment data set. 19 | } 20 | \examples{ 21 | 22 | } 23 | \seealso{ 24 | \code{browseVignettes("challengeR")} 25 | 26 | Other functions to visualize ranking stability: 27 | \code{\link{methodsplot.challenge}()}, 28 | \code{\link{significanceMap.ranked.list}()}, 29 | \code{\link{stabilityByTask.bootstrap.list}()} 30 | } 31 | \concept{functions to visualize ranking stability} 32 | -------------------------------------------------------------------------------- /man/consensus.ranked.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/consensus.R 3 | \name{consensus.ranked.list} 4 | \alias{consensus.ranked.list} 5 | \title{Computes a consensus ranking} 6 | \usage{ 7 | \method{consensus}{ranked.list}(object, method, ...) 8 | } 9 | \arguments{ 10 | \item{object}{The ranked asssessment data set.} 11 | 12 | \item{method}{A string specifying the method to derive the consensus ranking, see \code{\link[relations:consensus]{relations::consensus()}} for the methods. Consensus ranking according to mean ranks across tasks if method="euclidean" where in case of ties (equal ranks for multiple algorithms) the average rank is used, i.e. ties.method="average".} 13 | 14 | \item{...}{Further arguments passed to or from other functions.} 15 | } 16 | \value{ 17 | 18 | } 19 | \description{ 20 | Computes a consensus ranking (rank aggregation) across tasks. 21 | } 22 | -------------------------------------------------------------------------------- /R/by.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | splitby <- 20 | function(x,by){ 21 | if (length(by)==1) split(x,x[,by]) 22 | else split(x,as.list(x[,by])) 23 | } 24 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | library(testthat) 20 | library(challengeR) 21 | Sys.setenv("LANGUAGE" = "EN") 22 | test_check("challengeR") 23 | 24 | -------------------------------------------------------------------------------- /R/melt.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | melt.ranked.list=melt.aggregated.list=function(object,...){ 20 | matlist=lapply(object$matlist, function(z){ 21 | z$algorithm=rownames(z) 22 | z 23 | }) 24 | melt(matlist,id.vars="algorithm",...) 25 | } 26 | -------------------------------------------------------------------------------- /man/stability.ranked.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/stability.R 3 | \name{stability.ranked.list} 4 | \alias{stability.ranked.list} 5 | \title{Creates a blob plot across tasks} 6 | \usage{ 7 | \method{stability}{ranked.list}( 8 | x, 9 | ordering, 10 | probs = c(0.025, 0.975), 11 | max_size = 6, 12 | freq = FALSE, 13 | shape = 4, 14 | ... 15 | ) 16 | } 17 | \arguments{ 18 | \item{x}{The ranked asssessment data set.} 19 | 20 | \item{...}{Further arguments passed to or from other functions.} 21 | } 22 | \value{ 23 | 24 | } 25 | \description{ 26 | Creates a blob plots visualizing the ranking variability across tasks. 27 | } 28 | \examples{ 29 | 30 | } 31 | \seealso{ 32 | \code{browseVignettes("challengeR")} 33 | 34 | Other functions to visualize cross-task insights: 35 | \code{\link{dendrogram.ranked.list}()}, 36 | \code{\link{stabilityByAlgorithm.bootstrap.list}()}, 37 | \code{\link{stabilityByTask.bootstrap.list}()} 38 | } 39 | \concept{functions to visualize cross-task insights} 40 | -------------------------------------------------------------------------------- /man/rankingHeatmap.challenge.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rankingHeatmap.R 3 | \name{rankingHeatmap.challenge} 4 | \alias{rankingHeatmap.challenge} 5 | \title{Creates a ranking heatmap} 6 | \usage{ 7 | \method{rankingHeatmap}{challenge}(x, ordering, ties.method = "min", ...) 8 | } 9 | \arguments{ 10 | \item{x}{The challenge object.} 11 | 12 | \item{ties.method}{A string specifying how ties are treated, see \code{\link[base:rank]{base::rank()}}.} 13 | 14 | \item{...}{Further arguments passed to or from other functions.} 15 | } 16 | \value{ 17 | 18 | } 19 | \description{ 20 | Creates a ranking heatmap from a challenge object. 21 | } 22 | \examples{ 23 | 24 | } 25 | \seealso{ 26 | \code{browseVignettes("challengeR")} 27 | 28 | Other functions to visualize assessment data: 29 | \code{\link{boxplot.ranked.list}()}, 30 | \code{\link{podium.challenge}()}, 31 | \code{\link{podium.ranked.list}()}, 32 | \code{\link{rankingHeatmap.ranked.list}()} 33 | } 34 | \concept{functions to visualize assessment data} 35 | -------------------------------------------------------------------------------- /man/rankingHeatmap.ranked.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rankingHeatmap.R 3 | \name{rankingHeatmap.ranked.list} 4 | \alias{rankingHeatmap.ranked.list} 5 | \title{Creates ranking heatmaps} 6 | \usage{ 7 | \method{rankingHeatmap}{ranked.list}(x, ties.method = "min", ...) 8 | } 9 | \arguments{ 10 | \item{x}{The ranked asssessment data set.} 11 | 12 | \item{ties.method}{A string specifying how ties are treated, see \code{\link[base:rank]{base::rank()}}.} 13 | 14 | \item{...}{Further arguments passed to or from other functions.} 15 | } 16 | \value{ 17 | 18 | } 19 | \description{ 20 | Creates ranking heatmaps from one or more ranked assessment data sets. 21 | } 22 | \examples{ 23 | 24 | } 25 | \seealso{ 26 | \code{browseVignettes("challengeR")} 27 | 28 | Other functions to visualize assessment data: 29 | \code{\link{boxplot.ranked.list}()}, 30 | \code{\link{podium.challenge}()}, 31 | \code{\link{podium.ranked.list}()}, 32 | \code{\link{rankingHeatmap.challenge}()} 33 | } 34 | \concept{functions to visualize assessment data} 35 | -------------------------------------------------------------------------------- /R/winner.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | winner <- function(x,...) UseMethod("winner") 20 | winner.default <- function(x, ...) stop("not implemented for this class") 21 | 22 | winner.ranked.list <-winner.bootstrap.list <-function(x,...){ 23 | lapply(x$matlist, function(z) z[which(z$rank==min(z$rank)),,drop=F]) 24 | } 25 | 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: challengeR 2 | Type: Package 3 | Title: Analyzing assessment data of biomedical image analysis competitions and visualization of results 4 | Version: 1.0.5 5 | Date: 2023-08-10 6 | Author: Manuel Wiesenfarth, Matthias Eisenmann, Laura Aguilera Saiz, Annette Kopp-Schneider, Ali Emre Kavur 7 | Maintainer: Manuel Wiesenfarth 8 | Description: Analyzing assessment data of biomedical image analysis competitions and visualization of results. 9 | License: GPL (>= 2) 10 | Depends: 11 | R (>= 3.5.2), 12 | ggplot2 (>= 3.3.0), 13 | purrr (>= 0.3.3) 14 | Imports: 15 | dplyr (>= 0.8.5), 16 | graph (>= 1.64.0), 17 | knitr (>= 1.28), 18 | methods (>= 3.6.0), 19 | plyr (>= 1.8.6), 20 | relations (>= 0.6-9), 21 | reshape2 (>= 1.4.3), 22 | rlang (>= 0.4.5), 23 | rmarkdown (>= 2.1), 24 | tidyr (>= 1.0.2), 25 | viridisLite (>= 0.3.0) 26 | Suggests: 27 | doParallel (>= 1.0.15), 28 | doRNG (>= 1.8.6), 29 | foreach (>= 1.4.8), 30 | ggpubr (>= 0.2.5), 31 | Rgraphviz (>= 2.30.0), 32 | testthat (>= 2.1.0) 33 | VignetteBuilder: knitr 34 | Roxygen: list(markdown = TRUE) 35 | RoxygenNote: 7.1.0 36 | -------------------------------------------------------------------------------- /man/dendrogram.ranked.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dendrogram.R 3 | \name{dendrogram.ranked.list} 4 | \alias{dendrogram.ranked.list} 5 | \title{Creates a cluster dendrogram} 6 | \usage{ 7 | \method{dendrogram}{ranked.list}(object, dist = "symdiff", method = "complete", ...) 8 | } 9 | \arguments{ 10 | \item{object}{The ranked assessment data set.} 11 | 12 | \item{dist}{A string specifying the distance measure to be used, see \code{\link[relations:dissimilarity]{relations::dissimilarity()}}.} 13 | 14 | \item{method}{A string specifying agglomeration method to be used, see \code{\link[stats:hclust]{stats::hclust()}}.} 15 | 16 | \item{...}{Further arguments passed to or from other functions.} 17 | } 18 | \value{ 19 | 20 | } 21 | \description{ 22 | Creates a cluster dendrogram from a ranked assessment data set. 23 | } 24 | \examples{ 25 | 26 | } 27 | \seealso{ 28 | \code{browseVignettes("challengeR")} 29 | 30 | Other functions to visualize cross-task insights: 31 | \code{\link{stability.ranked.list}()}, 32 | \code{\link{stabilityByAlgorithm.bootstrap.list}()}, 33 | \code{\link{stabilityByTask.bootstrap.list}()} 34 | } 35 | \concept{functions to visualize cross-task insights} 36 | -------------------------------------------------------------------------------- /man/rankThenAggregate.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rankingMethods.R 3 | \name{rankThenAggregate} 4 | \alias{rankThenAggregate} 5 | \title{Performs ranking via rank-then-aggregate} 6 | \usage{ 7 | rankThenAggregate(object, FUN, ties.method = "min") 8 | } 9 | \arguments{ 10 | \item{object}{The challenge object.} 11 | 12 | \item{FUN}{The aggregation function, e.g., mean, median, min, max, function(x), quantile(x, probs=0.05).} 13 | 14 | \item{ties.method}{A string specifying how ties are treated, see \code{\link[base:rank]{base::rank()}}.} 15 | } 16 | \value{ 17 | An S3 object of class "ranked.list" to represent a ranked assessment data set. 18 | } 19 | \description{ 20 | Performs ranking by first computing a rank for each case for each algorithm ("rank first"). 21 | The final rank is based on the aggregated ranks for the cases. This ranking method handles missing values implicitly 22 | by assigning the worst rank to missing algorithm performances. 23 | } 24 | \examples{ 25 | \dontrun{ 26 | rankThenAggregate(challenge, FUN = mean) 27 | } 28 | 29 | } 30 | \seealso{ 31 | Other ranking functions: 32 | \code{\link{aggregateThenRank}()}, 33 | \code{\link{testThenRank}()} 34 | } 35 | \concept{ranking functions} 36 | -------------------------------------------------------------------------------- /R/rankNA2.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | rankNA2 <- 20 | function(x,ties.method="min",smallBetter=TRUE){ 21 | r=rank((-1)^(!smallBetter)*x,ties.method=ties.method,na.last="keep") #xtfrm maybe faster alternative 22 | if (any(is.na(x))){ 23 | maxrank=ifelse(all(is.na(x)), yes=0, no=max(r,na.rm=TRUE)) 24 | if (ties.method%in%c("min","random")) r[is.na(x)]<-maxrank+1 25 | if (ties.method=="average") r[is.na(x)]<-maxrank+mean(1:sum(is.na(x))) 26 | } 27 | r 28 | } 29 | -------------------------------------------------------------------------------- /man/boxplot.ranked.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/boxplot.R 3 | \name{boxplot.ranked.list} 4 | \alias{boxplot.ranked.list} 5 | \title{Creates dot- and boxplots} 6 | \usage{ 7 | \method{boxplot}{ranked.list}(x, jitter.width = 0.25, ...) 8 | } 9 | \arguments{ 10 | \item{x}{The ranked assessment data set.} 11 | 12 | \item{jitter.width}{A numeric value specifying the jitter width of the dots.} 13 | 14 | \item{...}{Further arguments passed to or from other functions.} 15 | 16 | \item{color}{A string specifying the color of the dots.} 17 | } 18 | \value{ 19 | 20 | } 21 | \description{ 22 | Creates dot- and boxplots visualizing the assessment data separately for each algorithm. 23 | Boxplots representing descriptive statistics for all test cases (median, quartiles and outliers) 24 | are combined with horizontally jittered dots representing individual test cases. 25 | } 26 | \examples{ 27 | 28 | } 29 | \seealso{ 30 | \code{browseVignettes("challengeR")} 31 | 32 | Other functions to visualize assessment data: 33 | \code{\link{podium.challenge}()}, 34 | \code{\link{podium.ranked.list}()}, 35 | \code{\link{rankingHeatmap.challenge}()}, 36 | \code{\link{rankingHeatmap.ranked.list}()} 37 | } 38 | \concept{functions to visualize assessment data} 39 | -------------------------------------------------------------------------------- /man/significanceMap.ranked.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/significanceMap.R 3 | \name{significanceMap.ranked.list} 4 | \alias{significanceMap.ranked.list} 5 | \title{Creates significance maps} 6 | \usage{ 7 | \method{significanceMap}{ranked.list}( 8 | object, 9 | alpha = 0.05, 10 | p.adjust.method = "holm", 11 | order = FALSE, 12 | size.rank = 0.3 * theme_get()$text$size, 13 | ... 14 | ) 15 | } 16 | \arguments{ 17 | \item{object}{The ranked assessment data set.} 18 | 19 | \item{alpha}{A numeric values specifying the significance level.} 20 | 21 | \item{p.adjust.method}{A string specifying the adjustment method for multiple testing, see \code{\link[stats:p.adjust]{stats::p.adjust()}}.} 22 | 23 | \item{...}{Further arguments passed to or from other functions.} 24 | } 25 | \value{ 26 | 27 | } 28 | \description{ 29 | Creates significance maps from a ranked assessment data set. 30 | } 31 | \examples{ 32 | 33 | } 34 | \seealso{ 35 | \code{browseVignettes("challengeR")} 36 | 37 | Other functions to visualize ranking stability: 38 | \code{\link{methodsplot.challenge}()}, 39 | \code{\link{stabilityByTask.bootstrap.list}()}, 40 | \code{\link{violin.bootstrap.list}()} 41 | } 42 | \concept{functions to visualize ranking stability} 43 | -------------------------------------------------------------------------------- /man/aggregateThenRank.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rankingMethods.R 3 | \name{aggregateThenRank} 4 | \alias{aggregateThenRank} 5 | \title{Performs ranking via aggregate-then-rank} 6 | \usage{ 7 | aggregateThenRank(object, FUN, ties.method = "min", ...) 8 | } 9 | \arguments{ 10 | \item{object}{The challenge object.} 11 | 12 | \item{FUN}{The aggregation function, e.g. mean, median, min, max, function(x), quantile(x, probs=0.05).} 13 | 14 | \item{ties.method}{A string specifying how ties are treated, see \code{\link[base:rank]{base::rank()}}.} 15 | 16 | \item{...}{Further arguments passed to or from other functions.} 17 | } 18 | \value{ 19 | An S3 object of class "ranked.list" to represent a ranked assessment data set. 20 | } 21 | \description{ 22 | Performs ranking by first aggregating performance values across all cases (e.g., with the mean, median or another quantile) for each algorithm. 23 | This aggregate is then used to compute a rank for each algorithm. 24 | } 25 | \examples{ 26 | 27 | \dontrun{ 28 | aggregateThenRank(challenge, FUN = mean, ties.method = "average", na.treat = 0) 29 | } 30 | 31 | } 32 | \seealso{ 33 | Other ranking functions: 34 | \code{\link{rankThenAggregate}()}, 35 | \code{\link{testThenRank}()} 36 | } 37 | \concept{ranking functions} 38 | -------------------------------------------------------------------------------- /R/default_colors.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | default_colors= 20 | function(n = length(algorithms), algorithms = NULL) { 21 | # Based on ggplot2:::ScaleHue 22 | h <- c(0, 360) + 15 23 | l <- 65 24 | c <- 100 25 | 26 | start <-0# 1 27 | direction <- 1 28 | 29 | rotate <- function(x) (x + start) %% 360 * direction 30 | 31 | if ( (diff(h) %% 360) < 1 ) { 32 | h[2] <- h[2] - 360 / n 33 | } 34 | 35 | structure(grDevices::hcl(h = rotate(seq(h[1], h[2], length = n)), 36 | c = c, l = l), 37 | names = algorithms) 38 | } 39 | -------------------------------------------------------------------------------- /man/stabilityByAlgorithm.bootstrap.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/stability.R 3 | \name{stabilityByAlgorithm.bootstrap.list} 4 | \alias{stabilityByAlgorithm.bootstrap.list} 5 | \title{Creates blob plots or stacked frequency plots stratified by algorithm} 6 | \usage{ 7 | \method{stabilityByAlgorithm}{bootstrap.list}( 8 | x, 9 | ordering, 10 | stacked = FALSE, 11 | probs = c(0.025, 0.975), 12 | max_size = 3, 13 | shape = 4, 14 | freq = FALSE, 15 | single = FALSE, 16 | ... 17 | ) 18 | } 19 | \arguments{ 20 | \item{x}{The bootstrapped, ranked assessment data set.} 21 | 22 | \item{stacked}{A boolean specifying whether a stacked frequency plot (\code{stacked = TRUE}) or blob plot (\code{stacked = FALSE}) should be created.} 23 | 24 | \item{...}{Further arguments passed to or from other functions.} 25 | } 26 | \value{ 27 | 28 | } 29 | \description{ 30 | Creates blob plots (\code{stacked = FALSE}) or stacked frequency plots (\code{stacked = TRUE}) for each algorithm 31 | from a bootstrapped, ranked assessment data set. 32 | } 33 | \examples{ 34 | 35 | } 36 | \seealso{ 37 | \code{browseVignettes("challengeR")} 38 | 39 | Other functions to visualize cross-task insights: 40 | \code{\link{dendrogram.ranked.list}()}, 41 | \code{\link{stability.ranked.list}()}, 42 | \code{\link{stabilityByTask.bootstrap.list}()} 43 | } 44 | \concept{functions to visualize cross-task insights} 45 | -------------------------------------------------------------------------------- /man/podium.challenge.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/podium.R 3 | \name{podium.challenge} 4 | \alias{podium.challenge} 5 | \title{Creates a podium plot} 6 | \usage{ 7 | \method{podium}{challenge}( 8 | object, 9 | ordering, 10 | xlab = NULL, 11 | ylab = NULL, 12 | lines.show = FALSE, 13 | lines.alpha = 0.2, 14 | lines.lwd = 1, 15 | lines.lty = 1, 16 | col, 17 | lines.col = col, 18 | dots.pch = 19, 19 | dots.cex = 1, 20 | places.lty = 2, 21 | places.col = 1, 22 | legendfn = function(algs, cols) { legend("topleft", algs, lwd = 1, col = cols, bg 23 | = "white") }, 24 | layout.heights = c(1, 0.4), 25 | ... 26 | ) 27 | } 28 | \arguments{ 29 | \item{object}{The challenge object.} 30 | 31 | \item{xlab}{A string specifying the x-axis label.} 32 | 33 | \item{ylab}{A string specifying the y-axis label.} 34 | 35 | \item{...}{Further arguments passed to or from other functions.} 36 | } 37 | \value{ 38 | 39 | } 40 | \description{ 41 | Creates a podium plot from a challenge object. 42 | } 43 | \examples{ 44 | 45 | } 46 | \seealso{ 47 | \code{browseVignettes("challengeR")} 48 | 49 | Other functions to visualize assessment data: 50 | \code{\link{boxplot.ranked.list}()}, 51 | \code{\link{podium.ranked.list}()}, 52 | \code{\link{rankingHeatmap.challenge}()}, 53 | \code{\link{rankingHeatmap.ranked.list}()} 54 | } 55 | \concept{functions to visualize assessment data} 56 | -------------------------------------------------------------------------------- /man/testThenRank.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/rankingMethods.R 3 | \name{testThenRank} 4 | \alias{testThenRank} 5 | \title{Performs ranking via test-then-rank} 6 | \usage{ 7 | testThenRank(object, ties.method = "min", ...) 8 | } 9 | \arguments{ 10 | \item{object}{The challenge object.} 11 | 12 | \item{ties.method}{A string specifying how ties are treated, see \code{\link[base:rank]{base::rank()}}.} 13 | 14 | \item{...}{Further arguments passed to or from other functions.} 15 | } 16 | \value{ 17 | An S3 object of class "ranked.list" to represent a ranked assessment data set. 18 | } 19 | \description{ 20 | Computes statistical hypothesis tests based on Wilcoxon signed rank test for each possible 21 | pair of algorithms to assess differences in metric values between the algorithms. 22 | Then ranking is performed according to the number of significant one-sided test results. 23 | If algorithms have the same number of significant test results, then they obtain the same rank. 24 | } 25 | \examples{ 26 | \dontrun{ 27 | testThenRank(challenge, 28 | alpha=0.05, # significance level 29 | p.adjust.method="none", # method for adjustment for multiple testing, see ?p.adjust 30 | na.treat = 0) 31 | } 32 | 33 | } 34 | \seealso{ 35 | Other ranking functions: 36 | \code{\link{aggregateThenRank}()}, 37 | \code{\link{rankThenAggregate}()} 38 | } 39 | \concept{ranking functions} 40 | -------------------------------------------------------------------------------- /R/benchmarkUtils.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | # to link with benchmark package (CRAN archived) 20 | 21 | as.warehouse.challenge=function(x,...){ 22 | x$.ds="data" 23 | x$.perf="perf" 24 | form=as.formula(paste(attr(x,"case"),attr(x,"algorithm"),".perf",".ds",sep="~")) 25 | ar=acast(x,form,value.var = attr(x,"value")) 26 | 27 | # ar=acast(dd,case~alg_name~score~subtask,value.var = attr(object,"value")) 28 | names(dimnames(ar)) =c("samp", "alg" , "perf", "ds") 29 | w=benchmark::as.warehouse.array4dim(ar) 30 | apm <- w$viewAlgorithmPerformance(performances = "perf",datasets="data") 31 | attr(apm,"challenge")=attributes(x)[-(1:2)] 32 | apm 33 | } 34 | 35 | 36 | -------------------------------------------------------------------------------- /man/podium.ranked.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/podium.R 3 | \name{podium.ranked.list} 4 | \alias{podium.ranked.list} 5 | \title{Creates podium plots} 6 | \usage{ 7 | \method{podium}{ranked.list}( 8 | object, 9 | xlab = "Podium", 10 | ylab = "Performance", 11 | lines.show = TRUE, 12 | lines.alpha = 0.2, 13 | lines.lwd = 1, 14 | lines.lty = 1, 15 | lines.col = col, 16 | col, 17 | dots.pch = 19, 18 | dots.cex = 1, 19 | places.lty = 2, 20 | places.col = 1, 21 | legendfn = function(algs, cols) { legend("topright", algs, lwd = 1, col = cols, 22 | bg = "white") }, 23 | layout.heights = c(1, 0.4), 24 | ... 25 | ) 26 | } 27 | \arguments{ 28 | \item{object}{The ranked asssessment data set.} 29 | 30 | \item{xlab}{A string specifying the x-axis label.} 31 | 32 | \item{ylab}{A string specifying the y-axis label.} 33 | 34 | \item{...}{Further arguments passed to or from other functions.} 35 | } 36 | \value{ 37 | 38 | } 39 | \description{ 40 | Creates podium plots from one or more ranked assessment data sets. 41 | } 42 | \examples{ 43 | 44 | } 45 | \seealso{ 46 | \code{browseVignettes("challengeR")} 47 | 48 | Other functions to visualize assessment data: 49 | \code{\link{boxplot.ranked.list}()}, 50 | \code{\link{podium.challenge}()}, 51 | \code{\link{rankingHeatmap.challenge}()}, 52 | \code{\link{rankingHeatmap.ranked.list}()} 53 | } 54 | \concept{functions to visualize assessment data} 55 | -------------------------------------------------------------------------------- /man/stabilityByTask.bootstrap.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/stability.R 3 | \name{stabilityByTask.bootstrap.list} 4 | \alias{stabilityByTask.bootstrap.list} 5 | \title{Creates blob plots stratified by task} 6 | \usage{ 7 | \method{stabilityByTask}{bootstrap.list}( 8 | x, 9 | ordering, 10 | probs = c(0.025, 0.975), 11 | max_size = 3, 12 | size.ranks = 0.3 * theme_get()$text$size, 13 | shape = 4, 14 | showLabelForSingleTask = FALSE, 15 | ... 16 | ) 17 | } 18 | \arguments{ 19 | \item{x}{The bootstrapped, ranked assessment data set.} 20 | 21 | \item{showLabelForSingleTask}{A boolean specifying whether the task name should be used as title for a single-task data set.} 22 | 23 | \item{...}{Further arguments passed to or from other functions.} 24 | } 25 | \value{ 26 | 27 | } 28 | \description{ 29 | Creates blob plots for each task from a bootstrapped, ranked assessment data set. 30 | } 31 | \examples{ 32 | 33 | } 34 | \seealso{ 35 | \code{browseVignettes("challengeR")} 36 | 37 | Other functions to visualize ranking stability: 38 | \code{\link{methodsplot.challenge}()}, 39 | \code{\link{significanceMap.ranked.list}()}, 40 | \code{\link{violin.bootstrap.list}()} 41 | 42 | Other functions to visualize cross-task insights: 43 | \code{\link{dendrogram.ranked.list}()}, 44 | \code{\link{stability.ranked.list}()}, 45 | \code{\link{stabilityByAlgorithm.bootstrap.list}()} 46 | } 47 | \concept{functions to visualize cross-task insights} 48 | \concept{functions to visualize ranking stability} 49 | -------------------------------------------------------------------------------- /R/S3.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | utils::globalVariables(c(".")) 20 | 21 | "+.ggList" <- function (e1, e2){ 22 | pp <- e1 23 | if(is.ggplot(pp)) plotList <- list(pp) 24 | else if(is.list(pp)) plotList <- pp 25 | else stop("Can't handle an object of class ", class(pp)) 26 | 27 | for(i in 1:length(plotList)){ 28 | p <- plotList[[i]] 29 | if(is.ggplot(p)) plotList[[i]] <- p + e2 30 | } 31 | 32 | if(is.ggplot(pp)) plotList[[1]] 33 | else plotList 34 | } 35 | 36 | "%++%" <- `+.ggList` 37 | 38 | print.ranked.list <-function(x,...) print(x$matlist, ...) 39 | print.aggregated.list <-function(x,...) print(x$matlist, ...) 40 | print.aggregated <-function(x,...) print(x$mat,...) 41 | print.ranked <-function(x,...) print(x$mat[order(x$mat$rank),],...) 42 | print.ggList <- function(x, ...) { 43 | for(i in 1:length(x)) print(x[[i]]) 44 | } 45 | -------------------------------------------------------------------------------- /man/bootstrap.ranked.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/Bootstrap.R 3 | \name{bootstrap.ranked.list} 4 | \alias{bootstrap.ranked.list} 5 | \title{Performs bootstrapping} 6 | \usage{ 7 | \method{bootstrap}{ranked.list}(object, nboot, parallel = FALSE, progress = "text", ...) 8 | } 9 | \arguments{ 10 | \item{object}{The ranked assessment data set.} 11 | 12 | \item{nboot}{The number of bootstrap samples.} 13 | 14 | \item{parallel}{A boolean specifying whether parallel processing should be enabled.} 15 | 16 | \item{progress}{A string specifying the type of progress indication.} 17 | 18 | \item{...}{Further arguments passed to or from other functions.} 19 | } 20 | \value{ 21 | An S3 object of class "bootstrap.list" to represent a bootstrapped, ranked assessment data set. 22 | } 23 | \description{ 24 | Performs bootstrapping on a ranked assessment data set and applies the ranking method to each bootstrap sample. One bootstrap sample of 25 | a task with \code{n} cases consists of \code{n} cases randomly drawn with replacement from this task. 26 | A total of \code{nboot} of these bootstrap samples are drawn. 27 | } 28 | \examples{ 29 | 30 | \dontrun{ 31 | # perform bootstrapping with 1000 bootstrap samples using one CPU 32 | set.seed(1) 33 | ranking_bootstrapped <- bootstrap(ranking, nboot = 1000) 34 | } 35 | 36 | \dontrun{ 37 | # perform bootstrapping using multiple CPUs (here: 8 CPUs) 38 | library(doParallel) 39 | registerDoParallel(cores=8) 40 | set.seed(1) 41 | ranking_bootstrapped <- bootstrap(ranking, nboot = 1000, parallel = TRUE, progress = "none") 42 | stopImplicitCluster() 43 | } 44 | 45 | } 46 | -------------------------------------------------------------------------------- /inst/appdir/visualizationBlobPlots.Rmd: -------------------------------------------------------------------------------- 1 | ## *Blob plot* for visualizing ranking stability based on bootstrap sampling \label{blobByTask} 2 | 3 | Algorithms are color-coded, and the area of each blob at position $\left( A_i, \text{rank } j \right)$ is proportional to the relative frequency $A_i$ achieved rank $j$ across $b=$ `r ncol(boot_object$bootsrappedRanks[[1]])` bootstrap samples. The median rank for each algorithm is indicated by a black cross. 95\% bootstrap intervals across bootstrap samples are indicated by black lines. 4 | 5 | 6 | \bigskip 7 | 8 | ```{r blobplot_bootstrap,fig.width=9, fig.height=9, results='hide'} 9 | showLabelForSingleTask <- FALSE 10 | 11 | if (n.tasks > 1) { 12 | showLabelForSingleTask <- TRUE 13 | } 14 | 15 | pl=list() 16 | for (subt in names(boot_object$bootsrappedRanks)){ 17 | a=list(bootsrappedRanks=list(boot_object$bootsrappedRanks[[subt]]), 18 | matlist=list(boot_object$matlist[[subt]])) 19 | names(a$bootsrappedRanks)=names(a$matlist)=subt 20 | class(a)="bootstrap.list" 21 | r=boot_object$matlist[[subt]] 22 | 23 | pl[[subt]]=stabilityByTask(a, 24 | max_size =8, 25 | ordering=rownames(r[order(r$rank),]), 26 | size.ranks=.25*theme_get()$text$size, 27 | size=8, 28 | shape=4, 29 | showLabelForSingleTask=showLabelForSingleTask) + 30 | scale_color_manual(values=cols) + 31 | guides(color = 'none') 32 | 33 | } 34 | 35 | # if (length(boot_object$matlist)<=6 &nrow((boot_object$matlist[[1]]))<=10 ){ 36 | # ggpubr::ggarrange(plotlist = pl) 37 | # } else { 38 | print(pl) 39 | #} 40 | 41 | ``` 42 | -------------------------------------------------------------------------------- /R/firstlib.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | .onAttach <- function (lib, pkg) { 20 | ver <- read.dcf(file.path(lib,pkg,"DESCRIPTION"),"Version") 21 | ver <- as.character(ver) 22 | packageStartupMessage("\nchallengeR ", 23 | ver, 24 | " loaded. \n", 25 | # "Note: Layouting in case of many algorithms or tasks is not yet optimized. Please be patient, we are steadily working on improving the package", 26 | "\nPlease cite as:\n Wiesenfarth, M., Reinke, A., Landman, B.A., Eisenmann, M., Aguilera Saiz, L., Cardoso, M.J., Maier-Hein, L. and Kopp-Schneider, A. Methods and open-source toolkit for analyzing and visualizing challenge results. Sci Rep 11, 2369 (2021). https://doi.org/10.1038/s41598-021-82017-6\n", 27 | domain = NULL, 28 | appendLF = TRUE) 29 | } 30 | 31 | .onLoad <- function(...) { 32 | } 33 | 34 | .onUnload <- function (libpath) { 35 | } 36 | -------------------------------------------------------------------------------- /man/methodsplot.challenge.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/methodsplot.R 3 | \name{methodsplot.challenge} 4 | \alias{methodsplot.challenge} 5 | \title{Creates line plots} 6 | \usage{ 7 | \method{methodsplot}{challenge}( 8 | x, 9 | na.treat = NULL, 10 | methods = list(testBased = . \%>\% test() \%>\% rank(ties.method = "min"), 11 | meanThenRank = . \%>\% aggregate(FUN = "mean") \%>\% rank(ties.method = "min"), 12 | medianThenRank = . \%>\% aggregate(FUN = "median") \%>\% rank(ties.method = "min"), 13 | rankThenMean = . \%>\% rank(ties.method = "min") \%>\% aggregate(FUN = "mean") \%>\% 14 | rank(ties.method = "min"), rankThenMedian = . \%>\% rank(ties.method = "min") \%>\% 15 | aggregate(FUN = "median") \%>\% rank(ties.method = "min")), 16 | ordering, 17 | ... 18 | ) 19 | } 20 | \arguments{ 21 | \item{x}{The challenge object.} 22 | 23 | \item{na.treat}{Indicates how missing perfomance values are treated if sanity check is enabled. It can be 'na.rm', numeric value or function. 24 | For a numeric value or function, NAs will be replaced by the specified values. For 'na.rm', rows that contain missing values will be removed.} 25 | 26 | \item{methods}{A list of ranking methods that should be incorporated.} 27 | 28 | \item{...}{Further arguments passed to or from other functions.} 29 | } 30 | \value{ 31 | 32 | } 33 | \description{ 34 | Create line plots that visualize the robustness of ranking across different ranking methods from a challenge object. 35 | } 36 | \examples{ 37 | 38 | } 39 | \seealso{ 40 | \code{browseVignettes("challengeR")} 41 | 42 | Other functions to visualize ranking stability: 43 | \code{\link{significanceMap.ranked.list}()}, 44 | \code{\link{stabilityByTask.bootstrap.list}()}, 45 | \code{\link{violin.bootstrap.list}()} 46 | } 47 | \concept{functions to visualize ranking stability} 48 | -------------------------------------------------------------------------------- /R/select.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | select.if <- function(object,...) UseMethod("select.if") 20 | select.if.default <- function(object, ...) stop("not implemented for this class") 21 | 22 | select.if.comparedRanks.list=function(object,FUN,...){ 23 | #if (!missing(FUN)) 24 | res=object[sapply(object, function(x) do.call(FUN,args=list(x=x$mat)))] 25 | #if (!missing(which)) res=object[which] 26 | class(res)="comparedRanks.list" 27 | res 28 | } 29 | 30 | select.if.list=function(object,FUN,...){ 31 | res=object[sapply(object, function(x) do.call(FUN,args=list(x=x)))] 32 | res 33 | } 34 | 35 | 36 | 37 | select.if.aggregated.list=select.if.ranked.list=function(object,FUN,...){ 38 | call=match.call(expand.dots = T) 39 | matlist=object$matlist 40 | #if (!missing(FUN)) 41 | matlist=matlist[sapply(matlist, function(x) do.call(FUN,args=list(x=x)))] 42 | #if (!missing(which)) matlist=matlist[which] 43 | 44 | res=list(matlist=matlist, 45 | call=list(object$call,call), 46 | data=object$data, 47 | FUN = . %>% (object$FUN) %>% (call) 48 | ) 49 | 50 | class(res)=class(object) 51 | res 52 | 53 | } 54 | 55 | 56 | -------------------------------------------------------------------------------- /man/subset.ranked.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/subset.R 3 | \name{subset.ranked.list} 4 | \alias{subset.ranked.list} 5 | \title{Extracts a subset of algorithms or tasks} 6 | \usage{ 7 | \method{subset}{ranked.list}(x, top, tasks, ...) 8 | } 9 | \arguments{ 10 | \item{x}{The ranked asssessment data set.} 11 | 12 | \item{top}{A positive integer specifying the amount of top performing algorithms to be retrieved.} 13 | 14 | \item{tasks}{A vector of strings containing the task identifiers that should remain in the subset.} 15 | 16 | \item{...}{Further arguments passed to or from other functions.} 17 | } 18 | \value{ 19 | An S3 object of class "ranked.list" to represent a ranked assessment data set. 20 | } 21 | \description{ 22 | Extracts the top performing algorithms or a subset of tasks. 23 | } 24 | \section{Reports for subsets (top list) of algorithms}{ 25 | 26 | If ties are present in the ranking, the subset will consist of more than \code{top} algorithms. 27 | Line plots for ranking robustness can be used to check whether algorithms performing well in other 28 | ranking methods are excluded. Bootstrapping still takes entire uncertainty into account. 29 | Podium plots and ranking heatmaps neglect excluded algorithms. Only available for single-task challenges 30 | (for multi-task challenges not sensible because each task would contain a different set of algorithms). 31 | } 32 | 33 | \section{Reports for subsets of tasks}{ 34 | 35 | You may want to recompute the consensus ranking after creating the subset. An error will be raised 36 | if a task identifier is not contained in the assessment data set to avoid subsequent errors. 37 | } 38 | 39 | \examples{ 40 | 41 | \dontrun{ 42 | # only show the top 3 algorithms according to the chosen ranking method 43 | subset(ranking, top = 3) \%>\% report(...) 44 | } 45 | 46 | \dontrun{ 47 | # restrict report to tasks "task1" and "task2" 48 | subset(ranking, tasks=c("task1", "task2")) \%>\% report(...) 49 | } 50 | 51 | } 52 | -------------------------------------------------------------------------------- /man/subset.bootstrap.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/subset.R 3 | \name{subset.bootstrap.list} 4 | \alias{subset.bootstrap.list} 5 | \title{Extracts a subset of algorithms or tasks} 6 | \usage{ 7 | \method{subset}{bootstrap.list}(x, top, tasks, ...) 8 | } 9 | \arguments{ 10 | \item{x}{The bootstrapped, ranked asssessment data set.} 11 | 12 | \item{top}{A positive integer specifying the amount of top performing algorithms to be retrieved.} 13 | 14 | \item{tasks}{A vector of strings containing the task identifiers that should remain in the subset.} 15 | 16 | \item{...}{Further arguments passed to or from other functions.} 17 | } 18 | \value{ 19 | An S3 object of class "bootstrap.list" to represent a bootstrapped, ranked assessment data set. 20 | } 21 | \description{ 22 | Extracts the top performing algorithms or a subset of tasks. 23 | } 24 | \section{Reports for subsets (top list) of algorithms}{ 25 | 26 | If ties are present in the ranking, the subset will consist of more than \code{top} algorithms. 27 | Line plots for ranking robustness can be used to check whether algorithms performing well in other 28 | ranking methods are excluded. Bootstrapping still takes entire uncertainty into account. 29 | Podium plots and ranking heatmaps neglect excluded algorithms. Only available for single-task challenges 30 | (for multi-task challenges not sensible because each task would contain a different set of algorithms). 31 | } 32 | 33 | \section{Reports for subsets of tasks}{ 34 | 35 | You may want to recompute the consensus ranking after creating the subset. An error will be raised 36 | if a task identifier is not contained in the assessment data set to avoid subsequent errors. 37 | } 38 | 39 | \examples{ 40 | 41 | \dontrun{ 42 | # only show the top 3 algorithms according to the chosen ranking method 43 | subset(ranking_bootstrapped, top = 3) \%>\% report(...) 44 | } 45 | 46 | \dontrun{ 47 | # restrict report to tasks "task1" and "task2" and recompute consensus ranking 48 | meanRanks <- subset(ranking, tasks = c("task1", "task2")) \%>\% consensus(method = "euclidean") 49 | } 50 | 51 | } 52 | -------------------------------------------------------------------------------- /R/relation.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | relation_dissimilarity <- function(x,...) UseMethod("relation_dissimilarity") 20 | relation_dissimilarity.default <- function(x, ...) relations::relation_dissimilarity(x, ...) 21 | 22 | relation_dissimilarity.ranked.list=function(x, 23 | method=kendall, 24 | ...){ #method in kendall, spearmansFootrule, spearmansWeightedFootrule or any other function with two arguments 25 | tt=names(x$matlist) 26 | n.tt=length(tt) 27 | tau=matrix(NA,n.tt,n.tt) 28 | colnames(tau)=rownames(tau)=tt 29 | aa=melt(x, 30 | measure.vars="rank") 31 | for (i in 1:n.tt){ 32 | for (j in 1:n.tt){ 33 | temp=aa%>% 34 | filter(L1==as.character(tt[i]))%>% 35 | right_join(aa%>% 36 | filter(L1==as.character(tt[j])), 37 | by="algorithm") 38 | tau[i,j]=method(temp$value.x, 39 | temp$value.y) 40 | } 41 | } 42 | 43 | if (method(1:2,1:2)==1 & method(2:1,1:2)==-1) as.dist(1-tau) #if two identical objects yield value of 1, method seems to be a correlation 44 | else as.dist(tau) #distance 45 | } 46 | 47 | 48 | as.relation.ranked.list=function(x,...){ 49 | res= lapply(x$matlist,function(z){ 50 | r=z[,"rank"] 51 | names(r)=rownames(z) 52 | as.relation(r) 53 | } ) 54 | class(res)="relation_ensemble" 55 | res 56 | } 57 | -------------------------------------------------------------------------------- /R/compareRanks.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | kendall=function(a,b) cor(a,b,method="kendall") 20 | spearmansWeightedFootrule=function(a,b) sum(abs(a-b)/pmin(a,b)) 21 | spearmansFootrule=function(a,b) sum(abs(a-b)) 22 | # SpearmansFootrule=function(a,b) sum(abs(match(a, b) - a)) 23 | # SpearmansWeightedFootrule=function(a,b) sum(abs(match(a, b) - a)/pmin(a,b)) 24 | 25 | 26 | compareRanks <- function(x,...) UseMethod("compareRanks") 27 | compareRanks.default <- function(x, ...) stop("not implemented for this class") 28 | 29 | 30 | compareRanks.ranked.list <-function(x, 31 | y, 32 | FUN=kendall,...){ 33 | matlist=merge.list(x$matlist, 34 | y$matlist 35 | ,...) 36 | res=lapply(1:length(matlist), 37 | function(z){ 38 | tau=FUN(matlist[[z]][,"rank.1"], 39 | matlist[[z]][,"rank.2"]) 40 | res=list(tau=tau, 41 | mat=matlist[[z]]) 42 | class(res)="comparedRanks" 43 | res 44 | }) 45 | names(res)=names(matlist) 46 | class(res)="comparedRanks.list" 47 | res 48 | } 49 | 50 | 51 | 52 | 53 | print.comparedRanks <- 54 | function(x,...) { 55 | cat("\n") 56 | print(x$mat) 57 | cat("\nKendall's tau =",x$tau,"\n-------------------------------------------------------\n") 58 | } 59 | 60 | 61 | -------------------------------------------------------------------------------- /R/consensus.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | #' @export 20 | consensus <- function(object,...) UseMethod("consensus") 21 | 22 | #' @export 23 | consensus.default <- function(object, ...) stop("not implemented for this class") 24 | 25 | #' Computes a consensus ranking 26 | #' 27 | #' Computes a consensus ranking (rank aggregation) across tasks. 28 | #' 29 | #' @param object The ranked asssessment data set. 30 | #' @param method A string specifying the method to derive the consensus ranking, see [relations::consensus()] for the methods. Consensus ranking according to mean ranks across tasks if method="euclidean" where in case of ties (equal ranks for multiple algorithms) the average rank is used, i.e. ties.method="average". 31 | #' @param ... Further arguments passed to or from other functions. 32 | #' 33 | #' @return 34 | #' 35 | #' @examples 36 | #' @export 37 | consensus.ranked.list=function(object, 38 | method, 39 | ...){ 40 | relensemble= relation_ensemble(list = as.relation(object)) 41 | cons=relation_consensus(relensemble, 42 | method = method,...) # consensus ranking according to mean ranks across tasks if method="euclidean". 43 | # See ?relation_consensus for different methods to derive consensus ranking 44 | res=sort(relation_scores(cons, 45 | decreasing=FALSE)) # note that there may be ties (i.e. some algorithms have identical mean rank) 46 | attr(res,"method")=method 47 | res 48 | } 49 | -------------------------------------------------------------------------------- /inst/appdir/characterizationOfTasksBootstrapping.Rmd: -------------------------------------------------------------------------------- 1 | ### Visualizing bootstrap results 2 | To investigate which tasks separate algorithms well (i.e., lead to a stable ranking), a blob plot is recommended. 3 | 4 | Bootstrap results can be shown in a blob plot showing one plot for each 5 | task. In this view, the spread of the blobs for each algorithm 6 | can be compared across tasks. Deviations from the diagonal indicate deviations 7 | from the consensus ranking (over tasks). Specifically, if rank 8 | distribution of an algorithm is consistently below the diagonal, 9 | the algorithm performed better in this task than on average 10 | across tasks, while if the rank distribution of an algorithm 11 | is consistently above the diagonal, the algorithm performed 12 | worse in this task than on average across tasks. At the bottom 13 | of each panel, ranks for each algorithm in the tasks are provided. 14 | 15 | 16 | 17 | 18 | 19 | Same as in Section \ref{blobByTask} but now ordered according to consensus. 20 | 21 | \bigskip 22 | 23 | ```{r blobplot_bootstrap_byTask,fig.width=9, fig.height=9, results='hide'} 24 | #stabilityByTask.bootstrap.list 25 | if (n.tasks<=6 & n.algorithms<=10 ){ 26 | stabilityByTask(boot_object, 27 | ordering=ordering_consensus, 28 | max_size = 9, 29 | size=4, 30 | shape=4) + 31 | scale_color_manual(values=cols) + 32 | guides(color = 'none') 33 | } else { 34 | pl=list() 35 | for (subt in names(boot_object$bootsrappedRanks)){ 36 | a=list(bootsrappedRanks=list(boot_object$bootsrappedRanks[[subt]]), 37 | matlist=list(boot_object$matlist[[subt]])) 38 | names(a$bootsrappedRanks)=names(a$matlist)=subt 39 | class(a)="bootstrap.list" 40 | r=boot_object$matlist[[subt]] 41 | 42 | pl[[subt]]=stabilityByTask(a, 43 | max_size = 9, 44 | ordering=ordering_consensus, 45 | size.ranks=.25*theme_get()$text$size, 46 | size=4, 47 | shape=4) + 48 | scale_color_manual(values=cols) + 49 | guides(color = 'none') + 50 | ggtitle(subt)+ 51 | theme(legend.position = "bottom") 52 | } 53 | print(pl) 54 | } 55 | ``` -------------------------------------------------------------------------------- /R/merge.list.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | merge.list=function(x,y,by="row.names",suffixes = c(".1",".2"),...){ 20 | if (is.list(x) & is.list(y)){ 21 | #if (!all.equal(names(x),names(y))) stop("list elements must have same names and lists must have same length") 22 | common.elements=intersect(names(x),names(y)) 23 | 24 | res=lapply(common.elements, function(z){ 25 | merge(x[[z]],y[[z]],by=by,suffixes=suffixes,...) 26 | }) 27 | names(res)=common.elements 28 | res 29 | 30 | } else stop("Comparison of a list and a data.frame under construction") 31 | } 32 | 33 | quickmerge.list=function(x,y){ 34 | if (is.list(x) & is.list(y)){ 35 | #if (!all.equal(names(x),names(y))) stop("list elements must have same names and lists must have same length") 36 | common.elements=intersect(names(x),names(y)) 37 | 38 | res=lapply(common.elements, function(z){ 39 | dat1=x[[z]] 40 | dat2=y[[z]] 41 | dat1=dat1[order(rownames(dat1)),,drop=F] 42 | dat2=dat2[order(rownames(dat2)),,drop=F] 43 | if (all(rownames(dat1)==rownames(dat2))) { 44 | qq=cbind(dat1,dat2) 45 | rownames(qq)=rownames(dat1) 46 | qq 47 | } 48 | else { 49 | id=intersect(rownames(dat1),rownames(dat2)) 50 | dat1=dat1[match(id,rownames(dat1)),] 51 | dat2=dat2[match(id,rownames(dat2)),,drop=F] 52 | qq=cbind(dat1,dat2) 53 | rownames(qq)=rownames(dat1) 54 | qq 55 | } 56 | }) 57 | names(res)=common.elements 58 | res 59 | 60 | } else stop("Comparison of a list and a data.frame under construction") 61 | } 62 | -------------------------------------------------------------------------------- /R/rrank.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | rank <- function(object,...) UseMethod("rank") 20 | rank.default <- function(object, ...) base::rank(object,...) #stats::aggregate 21 | 22 | rank.challenge=function(object, 23 | x, 24 | ties.method="min",...){ 25 | call=as.list(match.call()) 26 | if (!is.null(attr(object,"annotator"))) { 27 | call2=call("Rank", 28 | object=call$object, 29 | x=attr(object,"value"), 30 | annotator=c(attr(object,"annotator")), 31 | ties.method=ties.method, 32 | smallBetter=attr(object,"smallBetter") 33 | ) 34 | res1=do.call("Rank",list(object=object, 35 | x=attr(object,"value"), 36 | annotator=c(attr(object,"annotator")), 37 | ties.method=ties.method, 38 | smallBetter=attr(object,"smallBetter") 39 | )) 40 | 41 | } else { 42 | call2=call("Rank", 43 | object=call$object, 44 | x=attr(object,"value"), 45 | ties.method=ties.method, 46 | smallBetter=attr(object,"smallBetter") 47 | ) 48 | res1=do.call("Rank",list(object=object, 49 | x=attr(object,"value"), 50 | ties.method=ties.method, 51 | smallBetter=attr(object,"smallBetter") 52 | )) 53 | 54 | } 55 | 56 | res=list(FUN = . %>% (call2), 57 | call=list(call2), 58 | FUN.list=list("rank"), 59 | data=object, 60 | matlist=res1$matlist) 61 | 62 | class(res)=c("ranked.list",class(res)) 63 | res 64 | } 65 | -------------------------------------------------------------------------------- /R/dendrogram.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | #' @export 20 | dendrogram <- function(object,...) UseMethod("dendrogram") 21 | 22 | #' @export 23 | dendrogram.default <- function(object, ...) stop("not implemented for this class") 24 | 25 | #' Creates a cluster dendrogram 26 | #' 27 | #' Creates a cluster dendrogram from a ranked assessment data set. 28 | #' 29 | #' @param object The ranked assessment data set. 30 | #' @param dist A string specifying the distance measure to be used, see [relations::dissimilarity()]. 31 | #' @param method A string specifying agglomeration method to be used, see [stats::hclust()]. 32 | #' @param ... Further arguments passed to or from other functions. 33 | #' 34 | #' @return 35 | #' 36 | #' @examples 37 | #' 38 | #' @seealso `browseVignettes("challengeR")` 39 | #' 40 | #' @family functions to visualize cross-task insights 41 | #' @export 42 | dendrogram.ranked.list <- function(object, 43 | dist = "symdiff", #the distance measure to be used. see ?relation_dissimilarity 44 | method = "complete", #the agglomeration method to be used. see ?hclust 45 | ... # arguments passed to stats:::plot.hclust 46 | ){ 47 | relensemble=as.relation.ranked.list(object) 48 | d <- relation_dissimilarity(relensemble, 49 | method = dist) 50 | clust <- hclust(d, 51 | method=method) 52 | dots <- match.call(expand.dots = FALSE)$... 53 | if (is.null(dots$xlab)) dots$xlab <- "" 54 | if (is.null(dots$sub)) dots$sub <- "" 55 | if (is.null(dots$main)) dots$main <- paste0("Cluster Dendrogram (", method, " agglomeration)") 56 | 57 | do.call(plot, 58 | c(list(x = clust), dots) ) 59 | invisible(list(dist = d, 60 | hclust = clust 61 | )) 62 | 63 | } 64 | -------------------------------------------------------------------------------- /vignettes/SingleTask_aggregate-then-rank.R: -------------------------------------------------------------------------------- 1 | ## Single task, aggregate-then-rank ranking 2 | 3 | ## 1\. Load package 4 | 5 | library(challengeR) 6 | 7 | ## 2\. Load data 8 | 9 | if (!requireNamespace("permute", quietly = TRUE)) install.packages("permute") 10 | 11 | n=50 12 | 13 | set.seed(4) 14 | strip=runif(n,.9,1) 15 | c_ideal=cbind(task="c_ideal", 16 | rbind( 17 | data.frame(alg_name="A1",value=runif(n,.9,1),case=1:n), 18 | data.frame(alg_name="A2",value=runif(n,.8,.89),case=1:n), 19 | data.frame(alg_name="A3",value=runif(n,.7,.79),case=1:n), 20 | data.frame(alg_name="A4",value=runif(n,.6,.69),case=1:n), 21 | data.frame(alg_name="A5",value=runif(n,.5,.59),case=1:n) 22 | )) 23 | 24 | set.seed(1) 25 | c_random=data.frame(task="c_random", 26 | alg_name=factor(paste0("A",rep(1:5,each=n))), 27 | value=plogis(rnorm(5*n,1.5,1)),case=rep(1:n,times=5) 28 | ) 29 | 30 | strip2=seq(.8,1,length.out=5) 31 | a=permute::allPerms(1:5) 32 | c_worstcase=data.frame(task="c_worstcase", 33 | alg_name=c(t(a)), 34 | value=rep(strip2,nrow(a)), 35 | case=rep(1:nrow(a),each=5) 36 | ) 37 | c_worstcase=rbind(c_worstcase, 38 | data.frame(task="c_worstcase",alg_name=1:5,value=strip2,case=max(c_worstcase$case)+1) 39 | ) 40 | c_worstcase$alg_name=factor(c_worstcase$alg_name,labels=paste0("A",1:5)) 41 | 42 | data_matrix=rbind(c_ideal, c_random, c_worstcase) 43 | 44 | ## 3 Perform ranking 45 | 46 | ### 3.1 Define challenge object 47 | 48 | dataSubset=subset(data_matrix, task=="c_random") 49 | 50 | challenge=as.challenge(dataSubset, algorithm="alg_name", case="case", value="value", smallBetter = FALSE) 51 | 52 | ### 3.2 Perform ranking 53 | 54 | ranking=challenge%>%aggregateThenRank(FUN = mean, na.treat=0, ties.method = "min") 55 | 56 | ## 4\. Perform bootstrapping 57 | 58 | library(doParallel) 59 | library(doRNG) 60 | registerDoParallel(cores=8) 61 | registerDoRNG(1) 62 | ranking_bootstrapped=ranking%>%bootstrap(nboot=1000, parallel=TRUE, progress="none") 63 | stopImplicitCluster() 64 | 65 | ## 5\. Generate the report 66 | ranking_bootstrapped %>% 67 | report(title="singleTaskChallengeExample", # used for the title of the report 68 | file = "SingleTask_aggregate-then-rank", 69 | format = "PDF", # format can be "PDF", "HTML" or "Word" 70 | latex_engine="pdflatex", #LaTeX engine for producing PDF output. Options are "pdflatex", "lualatex", and "xelatex" 71 | clean=TRUE #optional. Using TRUE will clean intermediate files that are created during rendering. 72 | ) 73 | -------------------------------------------------------------------------------- /man/report.ranked.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/report.R 3 | \name{report.ranked.list} 4 | \alias{report.ranked.list} 5 | \title{Generates a benchmarking report without bootstrapping results} 6 | \usage{ 7 | \method{report}{ranked.list}( 8 | object, 9 | consensus, 10 | file, 11 | title = "", 12 | colors = default_colors, 13 | format = "PDF", 14 | latex_engine = "pdflatex", 15 | clean = TRUE, 16 | fig.format = NULL, 17 | dpi = 150, 18 | open = TRUE, 19 | ... 20 | ) 21 | } 22 | \arguments{ 23 | \item{object}{The ranked assessment data set.} 24 | 25 | \item{consensus}{The rank aggregation across tasks (consensus ranking). Only needed for a multi-task data set.} 26 | 27 | \item{file}{A string specifying the file name of the report. It allows for specifying the output file path as well, 28 | otherwise the working directory is used. If \code{file} does not have a file extension, an extension will be automatically 29 | added according to the output format given in \code{format}. If the argument is omitted, the report is created in a 30 | temporary folder with file name "report".} 31 | 32 | \item{title}{A string specifying the title of the report.} 33 | 34 | \item{colors}{The color scheme that is applied to the plots.} 35 | 36 | \item{format}{A string specifying the format of the report. The options are "PDF", "HTML" or "Word".} 37 | 38 | \item{latex_engine}{A string specifying the LaTeX engine for producing PDF output. The Options are "pdflatex", "lualatex", and "xelatex".} 39 | 40 | \item{clean}{A boolean indicating whether intermediate files (e.g. individual plots) should be kept. Using \code{TRUE} will clean 41 | intermediate files that are created during rendering.} 42 | 43 | \item{fig.format}{A vector of strings containing the file format of the figures that are not removed if \code{clean} is set to \code{FALSE}. 44 | The options are "jpeg", "png" and "pdf", e.g. \code{fig.format = c("jpeg", "png", "pdf")}.} 45 | 46 | \item{dpi}{A positive integer specifying the resolution of the generated plot (\code{fig.format} "jpeg" or "png") in dots per inch (DPI).} 47 | 48 | \item{open}{A boolean specifying whether the report should be opened with the default system viewer after generation.} 49 | 50 | \item{...}{Further arguments passed to or from other functions.} 51 | } 52 | \value{ 53 | 54 | } 55 | \description{ 56 | Generates a benchmarking report in PDF, HTML or Word format without bootstrapping results. 57 | It contains the rankings, plots of the raw assessment data and plots of the ranking stability. 58 | For multi-task challenges, it also contains plots of cross-task insights. If you are interested in 59 | the individual plots as separate files, set argument \code{clean} to \code{FALSE} and specify \code{fig.format}. 60 | } 61 | -------------------------------------------------------------------------------- /man/report.bootstrap.list.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/report.R 3 | \name{report.bootstrap.list} 4 | \alias{report.bootstrap.list} 5 | \title{Generates a benchmarking report with bootstrapping results} 6 | \usage{ 7 | \method{report}{bootstrap.list}( 8 | object, 9 | consensus, 10 | file, 11 | title = "", 12 | colors = default_colors, 13 | format = "PDF", 14 | latex_engine = "pdflatex", 15 | clean = TRUE, 16 | fig.format = NULL, 17 | dpi = 150, 18 | open = TRUE, 19 | ... 20 | ) 21 | } 22 | \arguments{ 23 | \item{object}{The ranked (bootstrapped) assessment data set.} 24 | 25 | \item{consensus}{The rank aggregation across tasks (consensus ranking). Only needed for a multi-task data set.} 26 | 27 | \item{file}{A string specifying the file name of the report. It allows for specifying the output file path as well, 28 | otherwise the working directory is used. If \code{file} does not have a file extension, an extension will be automatically 29 | added according to the output format given in \code{format}. If the argument is omitted, the report is created in a 30 | temporary folder with file name "report".} 31 | 32 | \item{title}{A string specifying the title of the report.} 33 | 34 | \item{colors}{The color scheme that is applied to the plots.} 35 | 36 | \item{format}{A string specifying the format of the report. The options are "PDF", "HTML" or "Word".} 37 | 38 | \item{latex_engine}{A string specifying the LaTeX engine for producing PDF output. The Options are "pdflatex", "lualatex", and "xelatex".} 39 | 40 | \item{clean}{A boolean indicating whether intermediate files (e.g. individual plots) should be kept. Using \code{TRUE} will clean 41 | intermediate files that are created during rendering.} 42 | 43 | \item{fig.format}{A vector of strings containing the file format of the figures that are not removed if \code{clean} is set to \code{FALSE}. 44 | The options are "jpeg", "png" and "pdf", e.g. \code{fig.format = c("jpeg", "png", "pdf")}.} 45 | 46 | \item{dpi}{A positive integer specifying the resolution of the generated plot (\code{fig.format} "jpeg" or "png") in dots per inch (DPI).} 47 | 48 | \item{open}{A boolean specifying whether the report should be opened with the default system viewer after generation.} 49 | 50 | \item{...}{Further arguments passed to or from other functions.} 51 | } 52 | \value{ 53 | 54 | } 55 | \description{ 56 | Generates a benchmarking report in PDF, HTML or Word format with bootstrapping results. 57 | It contains the rankings, plots of the raw assessment data and plots of the ranking stability. 58 | For multi-task challenges, it also contains plots of cross-task insights. If you are interested in 59 | the individual plots as separate files, set argument \code{clean} to \code{FALSE} and specify \code{fig.format}. 60 | } 61 | -------------------------------------------------------------------------------- /vignettes/quickstart.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Quickstart" 3 | output: rmarkdown::html_vignette 4 | vignette: > 5 | %\VignetteIndexEntry{Quickstart} 6 | %\VignetteEngine{knitr::rmarkdown} 7 | %\VignetteEncoding{UTF-8} 8 | --- 9 | 10 | ```{r, include = FALSE} 11 | knitr::opts_chunk$set( 12 | collapse = TRUE, 13 | comment = "#>" 14 | ) 15 | ``` 16 | 17 | # Introduction 18 | 19 | This tutorial intends to give customized scripts to generate reports quickly, without going through all the installation and usage steps given in the README in detail. 20 | 21 | The tutorial contains the following scripts, which are included in the "vignettes" directory: 22 | 23 | - SingleTask_aggregate-then-rank.R 24 | - MultiTask_rank-then-aggregate.R 25 | - MultiTask_test-then-rank.R 26 | 27 | How to use the tutorial scripts in RStudio: 28 | 29 | 1. Specify where the report should be generated. 30 | ```{r, eval=F} 31 | setwd("myWorkingDirectoryFilePath") 32 | ``` 33 | 34 | 2. Open the script. 35 | 36 | 3. Click "Source". 37 | 38 | 4. The report will be generated in the previously specified working directory. 39 | 40 | 5. Check out the report, adapt the script to fit your configuration. 41 | 42 | 43 | # Usage 44 | 45 | Each script contains the following steps, as described in the README: 46 | 47 | 1. Load package 48 | 49 | 2. Load data (generated randomly) 50 | 51 | 3. Perform ranking 52 | 53 | 4. Uncertainty analysis (bootstrapping) 54 | 55 | 5. Generate report 56 | 57 | The scrips will be now explained in more detail: 58 | 59 | * **SingleTask_aggregate-then-rank.R:** In this script a single-task evaluation will be performed. The applied ranking method is "metric-based aggregation". It begins by aggregating metric values across all test cases for each algorithm. This aggregate is then used to compute a rank for each algorithm. 60 | 61 | * **MultiTask_rank-then-aggregate.R:** In this script a multi-task evaluation will be performed. The applied ranking method is "case-based aggregation". It begins with computing a rank for each test case for each algorithm (”rank first”). The final rank is based on the aggregated test-case ranks. Distance-based approaches for rank aggregation can also be used. 62 | 63 | * **MultiTask_test-then-rank.R:** In this script a multi-task evaluation will be performed. The applied ranking method is "significance ranking". In a complementary approach, statistical hypothesis tests are computed for each possible pair of algorithms to assess differences in metric values between the algorithms. Then ranking is performed according to the resulting relations or according to the number of significant one-sided test results. In the latter case, if algorithms have the same number of significant test results then they obtain the same rank. Various test statistics can be used. 64 | 65 | For more hints, see the README and the package documentation. 66 | -------------------------------------------------------------------------------- /tests/testthat/test-linePlot.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | test_that("line plot across ranking methods returns one plot for multi-task data set", { 20 | data <- rbind( 21 | data.frame(algo="A1", value=0.8, case="C1"), 22 | data.frame(algo="A2", value=0.6, case="C1"), 23 | data.frame(algo="A3", value=0.4, case="C1"), 24 | data.frame(algo="A1", value=0.2, case="C2"), 25 | data.frame(algo="A2", value=0.1, case="C2"), 26 | data.frame(algo="A3", value=0.0, case="C2")) 27 | 28 | challenge <- as.challenge(data, taskName="T1", algorithm="algo", case="case", value="value", smallBetter=FALSE) 29 | 30 | actualPlot <- methodsplot(challenge) 31 | expect_is(actualPlot, "ggplot") 32 | }) 33 | 34 | test_that("line plot across ranking methods returns one plot for multi-task data set", { 35 | dataTask1 <- cbind(task="T1", 36 | rbind( 37 | data.frame(algo="A1", value=0.8, case="C1"), 38 | data.frame(algo="A2", value=0.6, case="C1"), 39 | data.frame(algo="A3", value=0.4, case="C1"), 40 | data.frame(algo="A1", value=0.2, case="C2"), 41 | data.frame(algo="A2", value=0.1, case="C2"), 42 | data.frame(algo="A3", value=0.0, case="C2") 43 | )) 44 | dataTask2 <- cbind(task="T2", 45 | rbind( 46 | data.frame(algo="A1", value=0.2, case="C1"), 47 | data.frame(algo="A2", value=0.3, case="C1"), 48 | data.frame(algo="A3", value=0.4, case="C1"), 49 | data.frame(algo="A1", value=0.7, case="C2"), 50 | data.frame(algo="A2", value=0.8, case="C2"), 51 | data.frame(algo="A3", value=0.9, case="C2") 52 | )) 53 | 54 | data <- rbind(dataTask1, dataTask2) 55 | 56 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 57 | 58 | actualPlot <- methodsplot(challenge) 59 | expect_is(actualPlot, "ggplot") 60 | }) 61 | -------------------------------------------------------------------------------- /vignettes/MultiTask_rank-then-aggregate.R: -------------------------------------------------------------------------------- 1 | ## Multitask, rank-then-aggregate ranking 2 | 3 | ## 1\. Load package 4 | 5 | library(challengeR) 6 | 7 | ## 2\. Load data 8 | 9 | if (!requireNamespace("permute", quietly = TRUE)) install.packages("permute") 10 | 11 | n=50 12 | 13 | set.seed(4) 14 | strip=runif(n,.9,1) 15 | c_ideal=cbind(task="c_ideal", 16 | rbind( 17 | data.frame(alg_name="A1",value=runif(n,.9,1),case=1:n), 18 | data.frame(alg_name="A2",value=runif(n,.8,.89),case=1:n), 19 | data.frame(alg_name="A3",value=runif(n,.7,.79),case=1:n), 20 | data.frame(alg_name="A4",value=runif(n,.6,.69),case=1:n), 21 | data.frame(alg_name="A5",value=runif(n,.5,.59),case=1:n) 22 | )) 23 | 24 | set.seed(1) 25 | c_random=data.frame(task="c_random", 26 | alg_name=factor(paste0("A",rep(1:5,each=n))), 27 | value=plogis(rnorm(5*n,1.5,1)),case=rep(1:n,times=5) 28 | ) 29 | 30 | strip2=seq(.8,1,length.out=5) 31 | a=permute::allPerms(1:5) 32 | c_worstcase=data.frame(task="c_worstcase", 33 | alg_name=c(t(a)), 34 | value=rep(strip2,nrow(a)), 35 | case=rep(1:nrow(a),each=5) 36 | ) 37 | c_worstcase=rbind(c_worstcase, 38 | data.frame(task="c_worstcase",alg_name=1:5,value=strip2,case=max(c_worstcase$case)+1) 39 | ) 40 | c_worstcase$alg_name=factor(c_worstcase$alg_name,labels=paste0("A",1:5)) 41 | 42 | data_matrix=rbind(c_ideal, c_random, c_worstcase) 43 | 44 | ## 3 Perform ranking 45 | 46 | ### 3.1 Define challenge object 47 | 48 | challenge=as.challenge(data_matrix, 49 | by="task", 50 | algorithm="alg_name", case="case", value="value", 51 | smallBetter = FALSE) 52 | 53 | ### 3.2 Perform ranking 54 | 55 | ranking=challenge%>%rankThenAggregate(FUN = mean, 56 | ties.method = "min" 57 | ) 58 | 59 | ## 4\. Perform bootstrapping 60 | 61 | library(doParallel) 62 | library(doRNG) 63 | registerDoParallel(cores=8) 64 | registerDoRNG(1) 65 | ranking_bootstrapped=ranking%>%bootstrap(nboot=1000, parallel=TRUE, progress="none") 66 | stopImplicitCluster() 67 | 68 | ## 5\. Generate the report 69 | 70 | meanRanks=ranking%>%consensus(method = "euclidean") 71 | meanRanks # note that there may be ties (i.e. some algorithms have identical mean rank) 72 | 73 | ranking_bootstrapped %>% 74 | report(consensus=meanRanks, 75 | title="multiTaskChallengeExample", 76 | file = "MultiTask_rank-then-aggregate", 77 | format = "PDF", # format can be "PDF", "HTML" or "Word" 78 | latex_engine="pdflatex",#LaTeX engine for producing PDF output. Options are "pdflatex", "lualatex", and "xelatex" 79 | clean=TRUE #optional. Using TRUE will clean intermediate files that are created during rendering. 80 | ) 81 | -------------------------------------------------------------------------------- /vignettes/MultiTask_test-then-rank.R: -------------------------------------------------------------------------------- 1 | ## Multi-task, test-then-rank based on Wilcoxon signed rank ranking 2 | 3 | ## 1\. Load package 4 | 5 | library(challengeR) 6 | 7 | ## 2\. Load data 8 | 9 | if (!requireNamespace("permute", quietly = TRUE)) install.packages("permute") 10 | 11 | n=50 12 | 13 | set.seed(4) 14 | strip=runif(n,.9,1) 15 | c_ideal=cbind(task="c_ideal", 16 | rbind( 17 | data.frame(alg_name="A1",value=runif(n,.9,1),case=1:n), 18 | data.frame(alg_name="A2",value=runif(n,.8,.89),case=1:n), 19 | data.frame(alg_name="A3",value=runif(n,.7,.79),case=1:n), 20 | data.frame(alg_name="A4",value=runif(n,.6,.69),case=1:n), 21 | data.frame(alg_name="A5",value=runif(n,.5,.59),case=1:n) 22 | )) 23 | 24 | set.seed(1) 25 | c_random=data.frame(task="c_random", 26 | alg_name=factor(paste0("A",rep(1:5,each=n))), 27 | value=plogis(rnorm(5*n,1.5,1)),case=rep(1:n,times=5) 28 | ) 29 | 30 | strip2=seq(.8,1,length.out=5) 31 | a=permute::allPerms(1:5) 32 | c_worstcase=data.frame(task="c_worstcase", 33 | alg_name=c(t(a)), 34 | value=rep(strip2,nrow(a)), 35 | case=rep(1:nrow(a),each=5) 36 | ) 37 | c_worstcase=rbind(c_worstcase, 38 | data.frame(task="c_worstcase",alg_name=1:5,value=strip2,case=max(c_worstcase$case)+1) 39 | ) 40 | c_worstcase$alg_name=factor(c_worstcase$alg_name,labels=paste0("A",1:5)) 41 | 42 | data_matrix=rbind(c_ideal, c_random, c_worstcase) 43 | 44 | ## 3 Perform ranking 45 | 46 | ### 3.1 Define challenge object 47 | 48 | challenge=as.challenge(data_matrix, 49 | by="task", 50 | algorithm="alg_name", case="case", value="value", 51 | smallBetter = FALSE) 52 | 53 | ### 3.2 Perform ranking 54 | 55 | #{r, eval=F, echo=T} 56 | ranking=challenge%>%testThenRank(alpha=0.05, 57 | p.adjust.method="none", 58 | na.treat=0, 59 | ties.method = "min" 60 | ) 61 | 62 | ## 4\. Perform bootstrapping 63 | 64 | library(doParallel) 65 | library(doRNG) 66 | registerDoParallel(cores=8) 67 | registerDoRNG(1) 68 | ranking_bootstrapped=ranking%>%bootstrap(nboot=1000, parallel=TRUE, progress="none") 69 | stopImplicitCluster() 70 | 71 | ## 5\. Generate the report 72 | 73 | meanRanks=ranking%>%consensus(method = "euclidean") 74 | meanRanks # note that there may be ties (i.e. some algorithms have identical mean rank) 75 | 76 | ranking_bootstrapped %>% 77 | report(consensus=meanRanks, 78 | title="multiTaskChallengeExample", 79 | file = "MultiTask_test-then-rank", 80 | format = "PDF", # format can be "PDF", "HTML" or "Word" 81 | latex_engine="pdflatex",#LaTeX engine for producing PDF output. Options are "pdflatex", "lualatex", and "xelatex" 82 | clean=TRUE #optional. Using TRUE will clean intermediate files that are created during rendering. 83 | ) 84 | -------------------------------------------------------------------------------- /inst/appdir/characterizationOfAlgorithmsBootstrapping.Rmd: -------------------------------------------------------------------------------- 1 | ### Ranking stability: Ranking variability via bootstrap approach 2 | 3 | A blob plot of bootstrap results over the different tasks separated 4 | by algorithm allows another perspective on the assessment data. This gives deeper insights into the characteristics 5 | of tasks and the ranking uncertainty of the algorithms in each task. 6 | 7 | 8 | 9 | 10 | 11 | 12 | \bigskip 13 | 14 | ```{r blobplot_bootstrap_byAlgorithm,fig.width=7,fig.height = 5} 15 | #stabilityByAlgorithm.bootstrap.list 16 | if (n.tasks<=6 & n.algorithms<=10 ){ 17 | stabilityByAlgorithm(boot_object, 18 | ordering=ordering_consensus, 19 | max_size = 9, 20 | size=4, 21 | shape=4, 22 | single = F) + 23 | scale_color_manual(values=cols) + 24 | guides(color = 'none') 25 | } else { 26 | pl=stabilityByAlgorithm(boot_object, 27 | ordering=ordering_consensus, 28 | max_size = 9, 29 | size=4, 30 | shape=4, 31 | single = T) 32 | for (i in 1:length(pl)) print(pl[[i]] + 33 | scale_color_manual(values=cols) + 34 | guides(size = guide_legend(title="%"),color="none") 35 | ) 36 | } 37 | 38 | ``` 39 | 40 | 41 | 42 | 43 | \newpage 44 | 45 | An alternative representation is provided by a stacked 46 | frequency plot of the observed ranks, separated by algorithm. Observed ranks across bootstrap samples are 47 | displayed with coloring according to the task. For algorithms that 48 | achieve the same rank in different tasks for the full assessment 49 | data set, vertical lines are on top of each other. Vertical lines 50 | allow to compare the achieved rank of each algorithm over 51 | different tasks. 52 | 53 | \bigskip 54 | 55 | 56 | 57 | ```{r stackedFrequencies_bootstrap_byAlgorithm,fig.width=7,fig.height = 5} 58 | if (n.tasks<=6 & n.algorithms<=10 ){ 59 | stabilityByAlgorithm(boot_object, 60 | ordering=ordering_consensus, 61 | stacked = TRUE, 62 | single = F) 63 | } else { 64 | pl=stabilityByAlgorithm(boot_object, 65 | ordering=ordering_consensus, 66 | stacked = TRUE, 67 | single = T) %++% 68 | theme(legend.position = ifelse(n.tasks>20, 69 | yes = "bottom", 70 | no = "right")) 71 | print(pl) 72 | } 73 | 74 | ``` 75 | -------------------------------------------------------------------------------- /tests/testthat/test-violinPlot.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | test_that("violin plot for visualizing ranking stability returns one plot for single-task data set", { 20 | data <- rbind( 21 | data.frame(algo="A1", value=0.8, case="C1"), 22 | data.frame(algo="A2", value=0.6, case="C1"), 23 | data.frame(algo="A3", value=0.4, case="C1"), 24 | data.frame(algo="A1", value=0.2, case="C2"), 25 | data.frame(algo="A2", value=0.1, case="C2"), 26 | data.frame(algo="A3", value=0.0, case="C2")) 27 | 28 | challenge <- as.challenge(data, taskName="T1", algorithm="algo", case="case", value="value", smallBetter=FALSE) 29 | 30 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 31 | 32 | set.seed(1) 33 | rankingBootstrapped <- ranking%>%bootstrap(nboot=10) 34 | 35 | actualPlot <- violin(rankingBootstrapped) 36 | expect_is(actualPlot, "ggplot") 37 | }) 38 | 39 | test_that("violin plot for visualizing ranking stability returns one plot for multi-task data set", { 40 | dataTask1 <- cbind(task="T1", 41 | rbind( 42 | data.frame(algo="A1", value=0.8, case="C1"), 43 | data.frame(algo="A2", value=0.6, case="C1"), 44 | data.frame(algo="A3", value=0.4, case="C1"), 45 | data.frame(algo="A1", value=0.2, case="C2"), 46 | data.frame(algo="A2", value=0.1, case="C2"), 47 | data.frame(algo="A3", value=0.0, case="C2") 48 | )) 49 | dataTask2 <- cbind(task="T2", 50 | rbind( 51 | data.frame(algo="A1", value=0.2, case="C1"), 52 | data.frame(algo="A2", value=0.3, case="C1"), 53 | data.frame(algo="A3", value=0.4, case="C1"), 54 | data.frame(algo="A1", value=0.7, case="C2"), 55 | data.frame(algo="A2", value=0.8, case="C2"), 56 | data.frame(algo="A3", value=0.9, case="C2") 57 | )) 58 | 59 | data <- rbind(dataTask1, dataTask2) 60 | 61 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 62 | 63 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 64 | 65 | set.seed(1) 66 | rankingBootstrapped <- ranking%>%bootstrap(nboot=10) 67 | 68 | actualPlot <- violin(rankingBootstrapped) 69 | expect_is(actualPlot, "ggplot") 70 | }) 71 | -------------------------------------------------------------------------------- /tests/testthat/test-blobPlotStabilityByTask.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | test_that("blob plot for visualizing ranking stability returns one plot for single-task data set", { 20 | data <- rbind( 21 | data.frame(algo="A1", value=0.8, case="C1"), 22 | data.frame(algo="A2", value=0.6, case="C1"), 23 | data.frame(algo="A3", value=0.4, case="C1"), 24 | data.frame(algo="A1", value=0.2, case="C2"), 25 | data.frame(algo="A2", value=0.1, case="C2"), 26 | data.frame(algo="A3", value=0.0, case="C2")) 27 | 28 | challenge <- as.challenge(data, taskName="T1", algorithm="algo", case="case", value="value", smallBetter=FALSE) 29 | 30 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 31 | 32 | set.seed(1) 33 | rankingBootstrapped <- ranking%>%bootstrap(nboot=10) 34 | 35 | actualPlot <- stabilityByTask(rankingBootstrapped) 36 | expect_is(actualPlot, "ggplot") 37 | }) 38 | 39 | test_that("blob plot for visualizing ranking stability returns one plot for multi-task data set", { 40 | dataTask1 <- cbind(task="T1", 41 | rbind( 42 | data.frame(algo="A1", value=0.8, case="C1"), 43 | data.frame(algo="A2", value=0.6, case="C1"), 44 | data.frame(algo="A3", value=0.4, case="C1"), 45 | data.frame(algo="A1", value=0.2, case="C2"), 46 | data.frame(algo="A2", value=0.1, case="C2"), 47 | data.frame(algo="A3", value=0.0, case="C2") 48 | )) 49 | dataTask2 <- cbind(task="T2", 50 | rbind( 51 | data.frame(algo="A1", value=0.2, case="C1"), 52 | data.frame(algo="A2", value=0.3, case="C1"), 53 | data.frame(algo="A3", value=0.4, case="C1"), 54 | data.frame(algo="A1", value=0.7, case="C2"), 55 | data.frame(algo="A2", value=0.8, case="C2"), 56 | data.frame(algo="A3", value=0.9, case="C2") 57 | )) 58 | 59 | data <- rbind(dataTask1, dataTask2) 60 | 61 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 62 | 63 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 64 | 65 | set.seed(1) 66 | rankingBootstrapped <- ranking%>%bootstrap(nboot=10) 67 | 68 | actualPlot <- stabilityByTask(rankingBootstrapped) 69 | expect_is(actualPlot, "ggplot") 70 | }) 71 | -------------------------------------------------------------------------------- /tests/testthat/test-significanceMap.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | test_that("significance map for single-task data set has no title", { 20 | data <- rbind( 21 | data.frame(algo="A1", value=0.8, case="C1"), 22 | data.frame(algo="A2", value=0.6, case="C1"), 23 | data.frame(algo="A3", value=0.4, case="C1"), 24 | data.frame(algo="A1", value=0.2, case="C2"), 25 | data.frame(algo="A2", value=0.1, case="C2"), 26 | data.frame(algo="A3", value=0.0, case="C2")) 27 | 28 | challenge <- as.challenge(data, taskName="T1", algorithm="algo", case="case", value="value", smallBetter=FALSE) 29 | 30 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 31 | 32 | actualPlot <- significanceMap(ranking) 33 | expect_is(actualPlot, "ggplot") 34 | expect_equal(actualPlot$labels$title, NULL) 35 | }) 36 | 37 | test_that("significance map for multi-task data set have titles", { 38 | dataTask1 <- cbind(task="T1", 39 | rbind( 40 | data.frame(algo="A1", value=0.8, case="C1"), 41 | data.frame(algo="A2", value=0.6, case="C1"), 42 | data.frame(algo="A3", value=0.4, case="C1"), 43 | data.frame(algo="A1", value=0.2, case="C2"), 44 | data.frame(algo="A2", value=0.1, case="C2"), 45 | data.frame(algo="A3", value=0.0, case="C2") 46 | )) 47 | dataTask2 <- cbind(task="T2", 48 | rbind( 49 | data.frame(algo="A1", value=0.2, case="C1"), 50 | data.frame(algo="A2", value=0.3, case="C1"), 51 | data.frame(algo="A3", value=0.4, case="C1"), 52 | data.frame(algo="A1", value=0.7, case="C2"), 53 | data.frame(algo="A2", value=0.8, case="C2"), 54 | data.frame(algo="A3", value=0.9, case="C2") 55 | )) 56 | 57 | data <- rbind(dataTask1, dataTask2) 58 | 59 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 60 | 61 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 62 | 63 | actualPlots <- significanceMap(ranking) 64 | actualPlotTask1 <- actualPlots[[1]] 65 | actualPlotTask2 <- actualPlots[[2]] 66 | 67 | expect_is(actualPlotTask1, "ggplot") 68 | expect_equal(actualPlotTask1$labels$title, "T1") 69 | 70 | expect_is(actualPlotTask2, "ggplot") 71 | expect_equal(actualPlotTask2$labels$title, "T2") 72 | }) 73 | -------------------------------------------------------------------------------- /tests/testthat/test-boxplot.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | test_that("boxplot for ranked single-task data set has no title", { 20 | data <- rbind( 21 | data.frame(algo="A1", value=0.8, case="C1"), 22 | data.frame(algo="A2", value=0.6, case="C1"), 23 | data.frame(algo="A3", value=0.4, case="C1"), 24 | data.frame(algo="A1", value=0.2, case="C2"), 25 | data.frame(algo="A2", value=0.1, case="C2"), 26 | data.frame(algo="A3", value=0.0, case="C2")) 27 | 28 | challenge <- as.challenge(data, taskName="T1", algorithm="algo", case="case", value="value", smallBetter=FALSE) 29 | 30 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 31 | 32 | actualPlot <- boxplot(ranking) 33 | expect_is(actualPlot, "ggplot") 34 | expect_equal(actualPlot$labels$title, NULL) 35 | }) 36 | 37 | test_that("boxplots for ranked multi-task data set have titles", { 38 | dataTask1 <- cbind(task="T1", 39 | rbind( 40 | data.frame(algo="A1", value=0.8, case="C1"), 41 | data.frame(algo="A2", value=0.6, case="C1"), 42 | data.frame(algo="A3", value=0.4, case="C1"), 43 | data.frame(algo="A1", value=0.2, case="C2"), 44 | data.frame(algo="A2", value=0.1, case="C2"), 45 | data.frame(algo="A3", value=0.0, case="C2") 46 | )) 47 | dataTask2 <- cbind(task="T2", 48 | rbind( 49 | data.frame(algo="A1", value=0.2, case="C1"), 50 | data.frame(algo="A2", value=0.3, case="C1"), 51 | data.frame(algo="A3", value=0.4, case="C1"), 52 | data.frame(algo="A1", value=0.7, case="C2"), 53 | data.frame(algo="A2", value=0.8, case="C2"), 54 | data.frame(algo="A3", value=0.9, case="C2") 55 | )) 56 | 57 | data <- rbind(dataTask1, dataTask2) 58 | 59 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 60 | 61 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 62 | 63 | actualPlots <- boxplot(ranking) 64 | actualPlotTask1 <- actualPlots[[1]] 65 | actualPlotTask2 <- actualPlots[[2]] 66 | 67 | expect_is(actualPlotTask1, "ggplot") 68 | expect_equal(actualPlotTask1$labels$title, "T1") 69 | 70 | expect_is(actualPlotTask2, "ggplot") 71 | expect_equal(actualPlotTask2$labels$title, "T2") 72 | }) 73 | 74 | -------------------------------------------------------------------------------- /tests/testthat/test-rankingHeatmap.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | test_that("ranking heatmap for single-task data set has no title", { 20 | data <- rbind( 21 | data.frame(algo="A1", value=0.8, case="C1"), 22 | data.frame(algo="A2", value=0.6, case="C1"), 23 | data.frame(algo="A3", value=0.4, case="C1"), 24 | data.frame(algo="A1", value=0.2, case="C2"), 25 | data.frame(algo="A2", value=0.1, case="C2"), 26 | data.frame(algo="A3", value=0.0, case="C2")) 27 | 28 | challenge <- as.challenge(data, taskName="T1", algorithm="algo", case="case", value="value", smallBetter=FALSE) 29 | 30 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 31 | 32 | actualPlot <- rankingHeatmap(ranking) 33 | expect_is(actualPlot, "ggplot") 34 | expect_equal(actualPlot$labels$title, NULL) 35 | }) 36 | 37 | test_that("ranking heatmap for multi-task data set have titles", { 38 | dataTask1 <- cbind(task="T1", 39 | rbind( 40 | data.frame(algo="A1", value=0.8, case="C1"), 41 | data.frame(algo="A2", value=0.6, case="C1"), 42 | data.frame(algo="A3", value=0.4, case="C1"), 43 | data.frame(algo="A1", value=0.2, case="C2"), 44 | data.frame(algo="A2", value=0.1, case="C2"), 45 | data.frame(algo="A3", value=0.0, case="C2") 46 | )) 47 | dataTask2 <- cbind(task="T2", 48 | rbind( 49 | data.frame(algo="A1", value=0.2, case="C1"), 50 | data.frame(algo="A2", value=0.3, case="C1"), 51 | data.frame(algo="A3", value=0.4, case="C1"), 52 | data.frame(algo="A1", value=0.7, case="C2"), 53 | data.frame(algo="A2", value=0.8, case="C2"), 54 | data.frame(algo="A3", value=0.9, case="C2") 55 | )) 56 | 57 | data <- rbind(dataTask1, dataTask2) 58 | 59 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 60 | 61 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 62 | 63 | actualPlots <- rankingHeatmap(ranking) 64 | actualPlotTask1 <- actualPlots[[1]] 65 | actualPlotTask2 <- actualPlots[[2]] 66 | 67 | expect_is(actualPlotTask1, "ggplot") 68 | expect_equal(actualPlotTask1$labels$title, "T1") 69 | 70 | expect_is(actualPlotTask2, "ggplot") 71 | expect_equal(actualPlotTask2$labels$title, "T2") 72 | }) 73 | -------------------------------------------------------------------------------- /R/Rank.aggregated.list.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | rank.aggregated.list <-function(object, 20 | ties.method="min", 21 | smallBetter, 22 | ...){ 23 | 24 | call=match.call(expand.dots = F) 25 | if (missing(smallBetter)){ 26 | if (!is.null(attr(object$data,"smallBetter"))) smallBetter=attr(object$data,"smallBetter") 27 | else stop("smallBetter has to be provided either in as.challenge() or rank()") 28 | 29 | if (object$isSignificance) smallBetter=FALSE # smallBetter already taken care of by one-sided test nature of signficance 30 | } 31 | 32 | call=call("rank.aggregated.list", 33 | object=call$object, 34 | ties.method=ties.method, 35 | smallBetter=smallBetter) 36 | 37 | matlist=object$matlist 38 | 39 | matlist=lapply(matlist, 40 | function(y){ 41 | if (nrow(y)>0) r=rankNA2(y[,ncol(y)], 42 | ties.method=ties.method, 43 | smallBetter=smallBetter) 44 | else r=NULL 45 | res=cbind(y,rank=r) 46 | res 47 | }) 48 | 49 | res=list(matlist=matlist, 50 | data=object$data, 51 | call=list(object$call,call), 52 | FUN = . %>% (object$FUN) %>% (call), 53 | FUN.list=c(object$FUN.list, 54 | "rank") 55 | ) 56 | class(res)=c("ranked.list",class(res)) 57 | 58 | res 59 | } 60 | 61 | rank.aggregatedRanks.list <-function(object, 62 | ties.method="min", 63 | ...){ 64 | 65 | call=match.call(expand.dots = F) 66 | call=call("rank.aggregatedRanks.list", 67 | object=call$object, 68 | ties.method=ties.method) 69 | matlist=object$matlist 70 | 71 | matlist=lapply(matlist, function(y){ 72 | if (nrow(y)>0) r=rankNA2(y[,ncol(y)], 73 | ties.method=ties.method, 74 | smallBetter=TRUE) 75 | else r=NULL 76 | res=cbind(y,rank=r) 77 | res 78 | }) 79 | 80 | res=list(matlist=matlist, 81 | data=object$data, 82 | call=list(object$call,call), 83 | FUN = . %>% (object$FUN) %>% (call), 84 | FUN.list=c(object$FUN.list, 85 | "rank") 86 | ) 87 | class(res)=c("ranked.list",class(res)) 88 | res 89 | 90 | res 91 | } 92 | -------------------------------------------------------------------------------- /R/boxplot.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | #' Creates dot- and boxplots 20 | #' 21 | #' Creates dot- and boxplots visualizing the assessment data separately for each algorithm. 22 | #' Boxplots representing descriptive statistics for all test cases (median, quartiles and outliers) 23 | #' are combined with horizontally jittered dots representing individual test cases. 24 | #' 25 | #' @param x The ranked assessment data set. 26 | #' @param color A string specifying the color of the dots. 27 | #' @param jitter.width A numeric value specifying the jitter width of the dots. 28 | #' @param ... Further arguments passed to or from other functions. 29 | #' 30 | #' @return 31 | #' 32 | #' @examples 33 | #' 34 | #' @seealso `browseVignettes("challengeR")` 35 | #' 36 | #' @family functions to visualize assessment data 37 | #' @export 38 | boxplot.ranked.list=function(x, 39 | jitter.width=0.25,...){ 40 | algo=attr(x$data,"algorithm") 41 | value=attr(x$data,"value") 42 | ranking=x 43 | x=x$data 44 | 45 | for (i in names(x)) { 46 | x[[i]][[algo]]=factor(x[[i]][[algo]], 47 | levels=rownames(ranking$matlist[[i]][order(ranking$matlist[[i]]$rank),])) 48 | } 49 | 50 | a=lapply(1:length(x),function(id){ 51 | ggplot(data=x[[id]])+ 52 | geom_jitter(aes_string(algo,value,color=algo), 53 | position=position_jitter(width=jitter.width, height=0), 54 | ...)+ 55 | geom_boxplot(aes_string(algo,value), 56 | outlier.shape = NA,fill=NA)+ 57 | ggtitle(names(x)[id]) + 58 | theme(axis.text.x=element_text(angle = -90, hjust = 0), 59 | legend.position="none") + 60 | xlab("Algorithm") + 61 | ylab("Metric value") 62 | }) 63 | 64 | # Remove title for single-task data set 65 | if (length(a) == 1) { 66 | a[[1]]$labels$title <- NULL 67 | return(a[[1]]) 68 | } else { 69 | names(a) = names(x$matlist) 70 | class(a) <- "ggList" 71 | return(a) 72 | } 73 | } 74 | 75 | boxplot.comparedRanks.list=function(x,...){ 76 | tau=sapply(x,function(z) z$tau) 77 | boxplot(tau,ylim=c(0,1.0),las=2, outline=FALSE, 78 | ylab="Kendall's tau",...) 79 | stripchart(tau, 80 | vertical = TRUE, method = "jitter", 81 | pch = 21, col = "blue", add=TRUE,...) 82 | 83 | } 84 | 85 | boxplot.bootstrap.list=function(x,...){ 86 | winner.noboot=winner.ranked.list(x) 87 | x2=winnerFrequencies(x) 88 | n.bootstraps= ncol(x$bootsrappedRanks[[1]]) 89 | perc_boot_Winner=lapply(1:length(x2),function(i){ 90 | x2.i=x2[[i]] 91 | winner.id=which(rownames(x2.i)%in%rownames(winner.noboot[[i]])) #could be multiple winners!!!! 92 | 100*x2.i[winner.id,3,drop=F]/n.bootstraps 93 | }) 94 | 95 | boxplot(unlist(perc_boot_Winner),ylim=c(0,100),las=2, outline=FALSE, 96 | ylab="% Bootstraps",xlab="Winner ranks 1", 97 | sub=paste(n.bootstraps,"Bootstraps"),...) 98 | stripchart(unlist(perc_boot_Winner), 99 | vertical = TRUE, method = "jitter", 100 | pch = 21, col = "blue", add=TRUE,...) 101 | } 102 | -------------------------------------------------------------------------------- /man/as.challenge.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/challengeR.R 3 | \name{as.challenge} 4 | \alias{as.challenge} 5 | \title{Constructs a challenge object} 6 | \usage{ 7 | as.challenge( 8 | object, 9 | case, 10 | algorithm, 11 | value, 12 | by = NULL, 13 | taskName = NULL, 14 | annotator = NULL, 15 | smallBetter = FALSE, 16 | na.treat = NULL, 17 | check = TRUE 18 | ) 19 | } 20 | \arguments{ 21 | \item{object}{A data frame containing the assessment data.} 22 | 23 | \item{case}{A string specifying the name of the column that contains the case identifiers.} 24 | 25 | \item{algorithm}{A string specifying the name of the column that contains the algorithm identifiers.} 26 | 27 | \item{value}{A string specifying the name of the column that contains the performance values.} 28 | 29 | \item{by}{A string specifying the name of the column that contains the task identifiers. Required for multi-task data set.} 30 | 31 | \item{taskName}{A string specifying the task name for single-task data set that does not contain a task column. 32 | This argument is optional for a single-task data set and is ignored for a multi-task data set.} 33 | 34 | \item{annotator}{If multiple annotators annotated the test cases, a string specifying the name of the column that contains the annotator identifiers. Only applies to rang-then-aggregate. Use with caution: Currently not tested.} 35 | 36 | \item{smallBetter}{A boolean specifying whether small performance values indicate better algorithm performance.} 37 | 38 | \item{na.treat}{Indicates how missing perfomance values are treated if sanity check is enabled. It can be 'na.rm', numeric value or function. 39 | For a numeric value or function, NAs will be replaced by the specified values. For 'na.rm', rows that contain missing values will be removed.} 40 | 41 | \item{check}{A boolean to indicate to perform a sanity check of the specified data set and arguments if set to \code{TRUE}.} 42 | } 43 | \value{ 44 | An S3 object to represent the configuration of an assessment data set. 45 | } 46 | \description{ 47 | Constructs an S3 object to represent the configuration of an assessment data set originating from a benchmarking competition (so-called "challenge"). 48 | } 49 | \section{Assessment data set}{ 50 | 51 | The toolkit provides visualization approaches for both challenges designed around a single task (single-task challenges) and for challenges comprising multiple tasks (multi-task challenges). 52 | For a single-task challenge, the assessment data set (argument \code{object}) requires the following columns: 53 | \itemize{ 54 | \item test case identifier (string or numeric) 55 | \item algorithm identifier (string or numeric) 56 | \item performance value (numeric) 57 | } 58 | 59 | For a multi-task challenge, the assessment data set (argument \code{object}) requires the following columns: 60 | \itemize{ 61 | \item task identifier (string or numeric) 62 | \item test case identifier (string or numeric) 63 | \item algorithm identifier (string or numeric) 64 | \item performance value (numeric) 65 | } 66 | } 67 | 68 | \section{Sanity check}{ 69 | 70 | It is highly recommended that the sanity check is not disabled when the data set is provided initially. 71 | It checks that: 72 | \itemize{ 73 | \item performance values are numeric (if not, raises error) 74 | \item algorithm performances are observed for all cases (if not, adds them as NA and emits a message) 75 | \item cases appear only once for the same algorithm (if not, raises error) 76 | } 77 | If the argument \code{na.treat} for treatment of NA is specified, NAs will be handled respectively. 78 | 79 | It might be reasonable to disable the sanity check for further computations (e.g., for performance reasons 80 | during bootstrapping (\code{\link{bootstrap.ranked.list}}) where cases are actually allowed to appear more than once for the same algorithm). 81 | } 82 | 83 | \examples{ 84 | # single-task data set 85 | 86 | # multi-task data set 87 | 88 | } 89 | -------------------------------------------------------------------------------- /R/Rank.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | Rank <- function(object,...) UseMethod("Rank") 20 | Rank.default <- function(object, ...) rank(object,...) #base::rank 21 | 22 | Rank.list <- function(object, 23 | x, 24 | annotator, 25 | ties.method="min", 26 | smallBetter=TRUE, 27 | ...){ 28 | 29 | call=match.call(expand.dots = T) 30 | annotator.missing=missing(annotator) 31 | if (any(sapply(object, 32 | function(task) { 33 | (attr(object,"check") && 34 | smallBetter && 35 | any(is.na(task[[x]])) && 36 | min(task[[x]], na.rm=TRUE)==0) 37 | }) 38 | )) { 39 | message("There are missing metric values and metric values exactly equal to zero. 40 | Have some actually missing values been entered as zero in some instances? 41 | If yes, specify optional argument na.treat=0 in as.challenge().") 42 | } 43 | 44 | matlist=lapply(object, 45 | function(task){ 46 | if (annotator.missing){ 47 | res=bind_rows( 48 | lapply(split(task, 49 | task[[attr(object,"case")]]), 50 | function(task.case) 51 | cbind(task.case, 52 | rank=rankNA2(task.case[[x]], 53 | ties.method = ties.method, 54 | smallBetter = smallBetter) 55 | ) 56 | ) 57 | ) 58 | class(res)[2]="ranked" 59 | res 60 | } else { 61 | byAnnotator=split(task, 62 | as.list(task[,annotator])) 63 | temp=bind_rows( 64 | lapply(byAnnotator, 65 | function(annotator){ 66 | bind_rows( 67 | lapply(split(annotator, 68 | annotator[[attr(object,"case")]]), 69 | function(annotator.case) 70 | cbind(annotator.case, 71 | rank=rankNA2(annotator.case[[x]], 72 | ties.method = ties.method, 73 | smallBetter = smallBetter) 74 | ) 75 | ) 76 | ) 77 | } 78 | ) 79 | ) 80 | class(temp)[2]="ranked" 81 | temp 82 | } 83 | } 84 | ) 85 | res=list(FUN = . %>% (call), 86 | call=list(call), 87 | data=object, 88 | matlist=matlist) 89 | 90 | class(res)=c("ranked.list",class(res)) 91 | res 92 | } 93 | -------------------------------------------------------------------------------- /R/rankingMethods.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | #' Performs ranking via aggregate-then-rank 20 | #' 21 | #' Performs ranking by first aggregating performance values across all cases (e.g., with the mean, median or another quantile) for each algorithm. 22 | #' This aggregate is then used to compute a rank for each algorithm. 23 | #' 24 | #' @param object The challenge object. 25 | #' @param FUN The aggregation function, e.g. mean, median, min, max, function(x), quantile(x, probs=0.05). 26 | #' @param ties.method A string specifying how ties are treated, see [base::rank()]. 27 | #' @param ... Further arguments passed to or from other functions. 28 | #' 29 | #' @return An S3 object of class "ranked.list" to represent a ranked assessment data set. 30 | #' 31 | #' @examples 32 | #' 33 | #' \dontrun{ 34 | #' aggregateThenRank(challenge, FUN = mean, ties.method = "average", na.treat = 0) 35 | #' } 36 | #' 37 | #' @family ranking functions 38 | #' @export 39 | aggregateThenRank=function(object,FUN,ties.method = "min",...){ 40 | object %>% 41 | aggregate(FUN=FUN,...) %>% 42 | rank(ties.method = ties.method) 43 | } 44 | 45 | #' Performs ranking via test-then-rank 46 | #' 47 | #' Computes statistical hypothesis tests based on Wilcoxon signed rank test for each possible 48 | #' pair of algorithms to assess differences in metric values between the algorithms. 49 | #' Then ranking is performed according to the number of significant one-sided test results. 50 | #' If algorithms have the same number of significant test results, then they obtain the same rank. 51 | #' 52 | #' @param object The challenge object. 53 | #' @param ties.method A string specifying how ties are treated, see [base::rank()]. 54 | #' @param ... Further arguments passed to or from other functions. 55 | #' 56 | #' @return An S3 object of class "ranked.list" to represent a ranked assessment data set. 57 | #' 58 | #' @examples 59 | #' \dontrun{ 60 | #' testThenRank(challenge, 61 | #' alpha=0.05, # significance level 62 | #' p.adjust.method="none", # method for adjustment for multiple testing, see ?p.adjust 63 | #' na.treat = 0) 64 | #' } 65 | #' 66 | #' @family ranking functions 67 | #' @export 68 | testThenRank=function(object, ties.method = "min",...){ 69 | object %>% 70 | aggregate(FUN="significance",...) %>% 71 | rank(ties.method = ties.method) 72 | } 73 | 74 | #' Performs ranking via rank-then-aggregate 75 | #' 76 | #' Performs ranking by first computing a rank for each case for each algorithm ("rank first"). 77 | #' The final rank is based on the aggregated ranks for the cases. This ranking method handles missing values implicitly 78 | #' by assigning the worst rank to missing algorithm performances. 79 | #' 80 | #' 81 | #' @param object The challenge object. 82 | #' @param FUN The aggregation function, e.g., mean, median, min, max, function(x), quantile(x, probs=0.05). 83 | #' @param ties.method A string specifying how ties are treated, see [base::rank()]. 84 | #' 85 | #' @return An S3 object of class "ranked.list" to represent a ranked assessment data set. 86 | #' 87 | #' @examples 88 | #' \dontrun{ 89 | #' rankThenAggregate(challenge, FUN = mean) 90 | #' } 91 | #' 92 | #' @family ranking functions 93 | #' @export 94 | rankThenAggregate=function(object, 95 | FUN, 96 | ties.method = "min" 97 | ){ 98 | object %>% 99 | rank(ties.method = ties.method)%>% 100 | aggregate(FUN=FUN) %>% 101 | rank(ties.method = ties.method) # small rank is always best, i.e. smallBetter always TRUE 102 | } 103 | -------------------------------------------------------------------------------- /R/rankingHeatmap.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | #' @export 20 | rankingHeatmap <- function(x,...) UseMethod("rankingHeatmap") 21 | 22 | #' @export 23 | rankingHeatmap.default <- function(x, ...) stop("not implemented for this class") 24 | 25 | #' Creates ranking heatmaps 26 | #' 27 | #' Creates ranking heatmaps from one or more ranked assessment data sets. 28 | #' 29 | #' @param x The ranked asssessment data set. 30 | #' @param ties.method A string specifying how ties are treated, see [base::rank()]. 31 | #' @param ... Further arguments passed to or from other functions. 32 | #' 33 | #' @return 34 | #' 35 | #' @examples 36 | #' 37 | #' @seealso `browseVignettes("challengeR")` 38 | #' 39 | #' @family functions to visualize assessment data 40 | #' @export 41 | rankingHeatmap.ranked.list=function (x,ties.method="min",...) { 42 | 43 | xx=x$data 44 | 45 | a=lapply(names(x$matlist),function(subt){ 46 | ordering=rownames(x$matlist[[subt]])[order(x$matlist[[subt]]$rank)] 47 | 48 | dd=as.challenge(xx[[subt]], 49 | value=attr(xx,"value"), 50 | algorithm=attr(xx,"algorithm") , 51 | case=attr(xx,"case"), 52 | by=attr(xx, "by"), 53 | annotator = attr(xx,"annotator"), 54 | smallBetter = attr(xx,"smallBetter"), 55 | na.treat=x$call[[1]][[1]]$na.treat) 56 | 57 | rankingHeatmap(dd, 58 | ordering=ordering, 59 | ties.method=ties.method,...) + ggtitle(subt) 60 | }) 61 | 62 | # Remove title for single-task data set 63 | if (length(a) == 1) { 64 | a[[1]]$labels$title <- NULL 65 | return(a[[1]]) 66 | } else { 67 | names(a) = names(x$matlist) 68 | class(a) <- "ggList" 69 | return(a) 70 | } 71 | 72 | } 73 | 74 | #' Creates a ranking heatmap 75 | #' 76 | #' Creates a ranking heatmap from a challenge object. 77 | #' 78 | #' @param x The challenge object. 79 | #' @param ordering 80 | #' @param ties.method A string specifying how ties are treated, see [base::rank()]. 81 | #' @param ... Further arguments passed to or from other functions. 82 | #' 83 | #' @return 84 | #' 85 | #' @examples 86 | #' 87 | #' @seealso `browseVignettes("challengeR")` 88 | #' 89 | #' @family functions to visualize assessment data 90 | #' @export 91 | rankingHeatmap.challenge=function(x, 92 | ordering, 93 | ties.method="min",...) { 94 | ranking=x%>%rank( ties.method = ties.method ) 95 | 96 | task <- ranking$matlist[[1]] 97 | 98 | dat=as.data.frame(table(task[[attr(x,"algorithm")]], 99 | task$rank, 100 | dnn=c("algorithm","rank")), 101 | responseName = "Count") 102 | dat$algorithm=factor(dat$algorithm, levels=ordering) 103 | ncases=length(unique(task[[attr(x,"case")]])) 104 | ggplot(dat)+ 105 | geom_raster(aes(algorithm, rank, fill= Count))+ 106 | geom_hline(yintercept = seq(1.5, 107 | max(max(task$rank)-.5, 108 | 1.5), 109 | by=1), 110 | color=grey(.8),size=.3)+ 111 | geom_vline(xintercept = seq(1.5, 112 | length(unique(dat$algorithm))-.5, 113 | by=1), 114 | color=grey(.8),size=.3)+ 115 | scale_fill_viridis_c(direction = -1, 116 | limits=c(0,ncases) 117 | )+ 118 | theme(axis.text.x = element_text(angle = 90), 119 | aspect.ratio=1)+ 120 | xlab("Algorithm")+ 121 | ylab("Rank") 122 | } 123 | -------------------------------------------------------------------------------- /R/violin.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | #' @export 20 | violin <- function(x,...) UseMethod("violin") 21 | 22 | #' @export 23 | violin.default <- function(x, ...) stop("not implemented for this class") 24 | 25 | #' Creates a violin plot 26 | #' 27 | #' Creates a violin plot from a bootstrapped, ranked assessment data set. 28 | #' 29 | #' @param x The bootstrapped, ranked assessment data set. 30 | #' @param ... Further arguments passed to or from other functions. 31 | #' 32 | #' @return 33 | #' 34 | #' @examples 35 | #' 36 | #' @seealso `browseVignettes("challengeR")` 37 | #' 38 | #' @family functions to visualize ranking stability 39 | #' @export 40 | violin.bootstrap.list=function(x,...){ 41 | ken=melt(kendall.bootstrap.list(x)) 42 | colnames(ken)[2]="Task" 43 | cat("\n\nSummary Kendall's tau:\n") 44 | ss=ken%>%group_by(Task)%>% 45 | summarise(mean=mean(value,na.rm=T), 46 | median=median(value,na.rm=T), 47 | q25=quantile(value,probs = .25,na.rm=T), 48 | q75=quantile(value,probs = .75,na.rm=T))%>% 49 | arrange(desc(median)) 50 | 51 | print(knitr::kable(as.data.frame(ss))) 52 | 53 | # drop task if no kendall could be computed 54 | noResults <- sapply(split(ss,ss$Task), 55 | function(x) all(is.na(x[,-1]))) 56 | if (any(noResults)) { 57 | cat("\nNo Kendall's tau could be calculated for any bootstrap sample in task ", 58 | names(noResults)[noResults], 59 | " because of missing variability. Task dropped from figure.",fill=F) 60 | ken <- ken %>% filter(Task %in% names(noResults)[!noResults]) 61 | 62 | } 63 | 64 | xAxisText <- element_blank() 65 | 66 | # Show task names as tick mark labels only for multi-task data set 67 | if (length(x$data) > 1) { 68 | xAxisText <- element_text(angle = 90, vjust = 0.5, hjust = 1) 69 | } 70 | 71 | ken%>%mutate(Task=factor(.data$Task, 72 | levels=ss$Task))%>% 73 | ggplot(aes(Task,value))+ 74 | geom_violin(alpha=.3, 75 | color=NA, 76 | na.rm=TRUE, 77 | fill="blue")+ 78 | geom_boxplot(width=0.1, 79 | na.rm=TRUE, 80 | fill="white")+ 81 | theme(axis.text.x = xAxisText, 82 | legend.position = "none")+ 83 | ylab("Kendall's tau")+ 84 | scale_y_continuous(limits=c(min(min(ken$value),0), 85 | max(max(ken$value),1))) 86 | } 87 | 88 | kendall.bootstrap.list=function(x){ 89 | ken=lapply(1:length(x$bootsrappedRanks),function(Task){ 90 | id=match(rownames( x$bootsrappedRanks[[Task]]), 91 | rownames(x$matlist[[Task]]) ) 92 | sapply(x$bootsrappedRanks[[Task]], 93 | function(bootSample) suppressWarnings(kendall(bootSample, 94 | x$matlist[[Task]]$rank[id]))) 95 | } ) 96 | names(ken)=names((x$bootsrappedRanks)) 97 | 98 | if (sum(is.na(x))>0){ 99 | cat("Bootstrap samples without variability in rankings (all algorithms ranked 1) excluded.\n Frequency of such samples by task:\n",fill = T) 100 | sapply(ken,function(x) sum(is.na(x))) 101 | } 102 | 103 | 104 | return(ken) 105 | 106 | } 107 | 108 | density.bootstrap.list=function(x,...){ 109 | ken=melt(kendall.bootstrap.list(x)) 110 | colnames(ken)[2]="Task" 111 | 112 | cat("\n\nSummary Kendall's tau\n") 113 | ss=ken%>%group_by(Task)%>% 114 | summarise(mean=mean(value,na.rm=T), 115 | median=median(value,na.rm=T), 116 | q25=quantile(value,probs = .25,na.rm=T), 117 | q75=quantile(value,probs = .75,na.rm=T))%>% 118 | arrange(desc(median)) 119 | 120 | print(as.data.frame(ss)) 121 | 122 | ggplot(ken)+ 123 | geom_density(aes(value,fill=Task),alpha=.3,color=NA) 124 | } 125 | -------------------------------------------------------------------------------- /tests/testthat/test-blobPlotStabilityAcrossTasks.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | test_that("blob plot for visualizing ranking stability across tasks raises error for single-task data set", { 20 | data <- rbind( 21 | data.frame(algo="A1", value=0.8, case="C1"), 22 | data.frame(algo="A2", value=0.6, case="C1"), 23 | data.frame(algo="A3", value=0.4, case="C1"), 24 | data.frame(algo="A1", value=0.2, case="C2"), 25 | data.frame(algo="A2", value=0.1, case="C2"), 26 | data.frame(algo="A3", value=0.0, case="C2")) 27 | 28 | challenge <- as.challenge(data, taskName="T1", algorithm="algo", case="case", value="value", smallBetter=FALSE) 29 | 30 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 31 | 32 | expect_error(stability(ranking), 33 | "The stability of rankings across tasks cannot be computed for less than two tasks.", fixed=TRUE) 34 | }) 35 | 36 | test_that("blob plot for visualizing ranking stability across tasks returns one plot for multi-task data set", { 37 | dataTask1 <- cbind(task="T1", 38 | rbind( 39 | data.frame(algo="A1", value=0.8, case="C1"), 40 | data.frame(algo="A2", value=0.6, case="C1"), 41 | data.frame(algo="A3", value=0.4, case="C1"), 42 | data.frame(algo="A1", value=0.2, case="C2"), 43 | data.frame(algo="A2", value=0.1, case="C2"), 44 | data.frame(algo="A3", value=0.0, case="C2") 45 | )) 46 | dataTask2 <- cbind(task="T2", 47 | rbind( 48 | data.frame(algo="A1", value=0.2, case="C1"), 49 | data.frame(algo="A2", value=0.3, case="C1"), 50 | data.frame(algo="A3", value=0.4, case="C1"), 51 | data.frame(algo="A1", value=0.7, case="C2"), 52 | data.frame(algo="A2", value=0.8, case="C2"), 53 | data.frame(algo="A3", value=0.9, case="C2") 54 | )) 55 | 56 | data <- rbind(dataTask1, dataTask2) 57 | 58 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 59 | 60 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 61 | 62 | actualPlot <- stability(ranking) 63 | expect_is(actualPlot, "ggplot") 64 | }) 65 | 66 | test_that("blob plot for visualizing ranking stability across tasks returns one plot for multi-task data set when consensus ranking is given", { 67 | dataTask1 <- cbind(task="T1", 68 | rbind( 69 | data.frame(algo="A1", value=0.8, case="C1"), 70 | data.frame(algo="A2", value=0.6, case="C1"), 71 | data.frame(algo="A3", value=0.4, case="C1"), 72 | data.frame(algo="A1", value=0.2, case="C2"), 73 | data.frame(algo="A2", value=0.1, case="C2"), 74 | data.frame(algo="A3", value=0.0, case="C2") 75 | )) 76 | dataTask2 <- cbind(task="T2", 77 | rbind( 78 | data.frame(algo="A1", value=0.2, case="C1"), 79 | data.frame(algo="A2", value=0.3, case="C1"), 80 | data.frame(algo="A3", value=0.4, case="C1"), 81 | data.frame(algo="A1", value=0.7, case="C2"), 82 | data.frame(algo="A2", value=0.8, case="C2"), 83 | data.frame(algo="A3", value=0.9, case="C2") 84 | )) 85 | 86 | data <- rbind(dataTask1, dataTask2) 87 | 88 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 89 | 90 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 91 | 92 | meanRanks <- ranking%>%consensus(method = "euclidean") 93 | 94 | actualPlot <- stability(ranking, ordering = names(meanRanks)) 95 | expect_is(actualPlot, "ggplot") 96 | }) 97 | -------------------------------------------------------------------------------- /tests/testthat/test-bootstrap.R: -------------------------------------------------------------------------------- 1 | test_that("single-task bootstrapping with 1 test case stopped with message", { 2 | dataTask1 <- cbind(task="T1", 3 | rbind( 4 | data.frame(algo="A1", value=0.8, case="C1"), 5 | data.frame(algo="A2", value=0.6, case="C1") 6 | )) 7 | 8 | 9 | challenge <- as.challenge(dataTask1, algorithm="algo", case="case", value="value", smallBetter=FALSE) 10 | 11 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 12 | 13 | set.seed(1) 14 | expect_error(rankingBootstrapped <- ranking%>%bootstrap(nboot=10), 15 | "Only 1 test case included. Bootstrapping with 1 test case not sensible.", fixed = TRUE) 16 | }) 17 | 18 | 19 | test_that("multi-task bootstrapping, all tasks with 1 test case stopped with message", { 20 | dataTask1 <- cbind(task="T1", 21 | rbind( 22 | data.frame(algo="A1", value=0.8, case="C1"), 23 | data.frame(algo="A2", value=0.6, case="C1") 24 | )) 25 | dataTask2 <- cbind(task="T2", 26 | rbind( 27 | data.frame(algo="A1", value=0.2, case="C1"), 28 | data.frame(algo="A2", value=0.3, case="C1") 29 | )) 30 | dataTask3 <- cbind(task="T3", 31 | rbind( 32 | data.frame(algo="A1", value=0.1, case="C1"), 33 | data.frame(algo="A2", value=0.8, case="C1") 34 | )) 35 | 36 | data <- rbind(dataTask1, dataTask2, dataTask3) 37 | 38 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 39 | 40 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 41 | 42 | set.seed(1) 43 | expect_error(rankingBootstrapped <- ranking%>%bootstrap(nboot=10), 44 | "All tasks only contained 1 test case. Bootstrapping with 1 test case not sensible.", fixed = TRUE) 45 | }) 46 | 47 | 48 | test_that("multi-task bootstrapping, only one task with >1 test case continued with message", { 49 | dataTask1 <- cbind(task="T1", 50 | rbind( 51 | data.frame(algo="A1", value=0.8, case="C1"), 52 | data.frame(algo="A2", value=0.6, case="C1") 53 | )) 54 | dataTask2 <- cbind(task="T2", 55 | rbind( 56 | data.frame(algo="A1", value=0.2, case="C1"), 57 | data.frame(algo="A2", value=0.3, case="C1"), 58 | data.frame(algo="A1", value=0.2, case="C2"), 59 | data.frame(algo="A2", value=0.3, case="C2") 60 | )) 61 | dataTask3 <- cbind(task="T3", 62 | rbind( 63 | data.frame(algo="A1", value=0.1, case="C1"), 64 | data.frame(algo="A2", value=0.8, case="C1") 65 | )) 66 | 67 | data <- rbind(dataTask1, dataTask2, dataTask3) 68 | 69 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 70 | 71 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 72 | 73 | set.seed(1) 74 | expect_message(rankingBootstrapped <- ranking%>%bootstrap(nboot=3), 75 | "Task(s) T1, T3 with only 1 test case excluded from bootstrapping.", fixed = TRUE) 76 | }) 77 | 78 | 79 | test_that("two sequential bootstrappings yield same results", { 80 | data <- read.csv(system.file("extdata", "data_matrix.csv", package="challengeR", mustWork=TRUE)) 81 | 82 | challenge <- as.challenge(data, by="task", algorithm="alg_name", case="case", value="value", smallBetter=FALSE) 83 | 84 | ranking <- challenge%>%rankThenAggregate(FUN=mean, ties.method="min") 85 | 86 | set.seed(123, kind="L'Ecuyer-CMRG") 87 | rankingBootstrapped1 <- ranking%>%bootstrap(nboot=10) 88 | 89 | set.seed(123, kind="L'Ecuyer-CMRG") 90 | rankingBootstrapped2 <- ranking%>%bootstrap(nboot=10) 91 | 92 | expect_equal(rankingBootstrapped1, rankingBootstrapped2) 93 | }) 94 | 95 | 96 | test_that("two parallel bootstrappings yield same results", { 97 | data <- read.csv(system.file("extdata", "data_matrix.csv", package="challengeR", mustWork=TRUE)) 98 | 99 | challenge <- as.challenge(data, by="task", algorithm="alg_name", case="case", value="value", smallBetter=FALSE) 100 | 101 | ranking <- challenge%>%rankThenAggregate(FUN=mean, ties.method="min") 102 | 103 | library(doParallel) 104 | library(doRNG) 105 | numCores <- detectCores(logical=FALSE) 106 | registerDoParallel(cores=numCores) 107 | 108 | registerDoRNG(123) 109 | rankingBootstrapped1 <- ranking%>%bootstrap(nboot=10, parallel=TRUE, progress="none") 110 | 111 | registerDoRNG(123) 112 | rankingBootstrapped2 <- ranking%>%bootstrap(nboot=10, parallel=TRUE, progress="none") 113 | 114 | stopImplicitCluster() 115 | 116 | expect_equal(rankingBootstrapped1, rankingBootstrapped2) 117 | }) 118 | -------------------------------------------------------------------------------- /inst/appdir/visualizationAcrossTasks.Rmd: -------------------------------------------------------------------------------- 1 | \newpage 2 | 3 | # Visualization of cross-task insights 4 | 5 | The algorithms are ordered according to consensus ranking. 6 | 7 | ## Characterization of algorithms 8 | 9 | ### Ranking stability: Variability of achieved rankings across tasks 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | Algorithms are color-coded, and the area of each blob at position $\left( A_i, \text{rank } j \right)$ is proportional to the relative frequency $A_i$ achieved rank $j$ across multiple tasks. The median rank for each algorithm is indicated by a black cross. This way, the distribution of ranks across tasks can be intuitively visualized. 19 | 20 | 21 | \bigskip 22 | 23 | ```{r blobplot_raw,fig.width=9, fig.height=9} 24 | #stability.ranked.list 25 | stability(object,ordering=ordering_consensus,max_size=9,size=8,shape=4)+ 26 | scale_color_manual(values=cols) + 27 | guides(color = 'none') 28 | ``` 29 | 30 | 31 | ```{r, child=if (isMultiTask && bootstrappingEnabled) system.file("appdir", "characterizationOfAlgorithmsBootstrapping.Rmd", package="challengeR")} 32 | 33 | ``` 34 | 35 | \newpage 36 | 37 | ## Characterization of tasks 38 | 39 | 40 | ```{r, child=if (isMultiTask && bootstrappingEnabled) system.file("appdir", "characterizationOfTasksBootstrapping.Rmd", package="challengeR")} 41 | 42 | ``` 43 | 44 | ### Cluster Analysis 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | Dendrogram from hierarchical cluster analysis and \textit{network-type graphs} for assessing the similarity of tasks based on challenge rankings. 56 | 57 | A dendrogram is a visualization approach based on hierarchical clustering. It depicts clusters according to a chosen distance measure (here: Spearman's footrule) as well as a chosen agglomeration method (here: complete and average agglomeration). 58 | \bigskip 59 | 60 | 61 | ```{r dendrogram_complete, fig.width=6, fig.height=5,out.width='60%'} 62 | if (n.tasks>2) { 63 | dendrogram(object, 64 | dist = "symdiff", 65 | method="complete") 66 | } else cat("\nCluster analysis only sensible if there are >2 tasks.\n\n") 67 | ``` 68 | 69 | \bigskip 70 | 71 | 72 | ```{r dendrogram_average, fig.width=6, fig.height=5,out.width='60%'} 73 | if (n.tasks>2) 74 | dendrogram(object, 75 | dist = "symdiff", 76 | method="average") 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 | -------------------------------------------------------------------------------- /tests/testthat/test-networkPlot.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | test_that("cluster analysis network plot raises error for single-task data set", { 20 | data <- rbind( 21 | data.frame(algo="A1", value=0.8, case="C1"), 22 | data.frame(algo="A2", value=0.6, case="C1"), 23 | data.frame(algo="A3", value=0.4, case="C1"), 24 | data.frame(algo="A1", value=0.2, case="C2"), 25 | data.frame(algo="A2", value=0.1, case="C2"), 26 | data.frame(algo="A3", value=0.0, case="C2")) 27 | 28 | challenge <- as.challenge(data, taskName="T1", algorithm="algo", case="case", value="value", smallBetter=FALSE) 29 | 30 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 31 | 32 | expect_error(network(ranking, edge.col=grDevices::grey.colors, edge.lwd=1, cols=NULL), 33 | "The cluster analysis is only sensible for more than two tasks.", fixed=TRUE) 34 | }) 35 | 36 | test_that("cluster analysis network plot raises error for multi-task data set containing two tasks", { 37 | dataTask1 <- cbind(task="T1", 38 | rbind( 39 | data.frame(algo="A1", value=0.8, case="C1"), 40 | data.frame(algo="A2", value=0.6, case="C1"), 41 | data.frame(algo="A3", value=0.4, case="C1"), 42 | data.frame(algo="A1", value=0.2, case="C2"), 43 | data.frame(algo="A2", value=0.1, case="C2"), 44 | data.frame(algo="A3", value=0.0, case="C2") 45 | )) 46 | dataTask2 <- cbind(task="T2", 47 | rbind( 48 | data.frame(algo="A1", value=0.2, case="C1"), 49 | data.frame(algo="A2", value=0.3, case="C1"), 50 | data.frame(algo="A3", value=0.4, case="C1"), 51 | data.frame(algo="A1", value=0.7, case="C2"), 52 | data.frame(algo="A2", value=0.8, case="C2"), 53 | data.frame(algo="A3", value=0.9, case="C2") 54 | )) 55 | 56 | data <- rbind(dataTask1, dataTask2) 57 | 58 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 59 | 60 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 61 | 62 | expect_error(network(ranking, edge.col=grDevices::grey.colors, edge.lwd=1, cols=NULL), 63 | "The cluster analysis is only sensible for more than two tasks.", fixed=TRUE) 64 | }) 65 | 66 | test_that("cluster analysis network plot returns a network object for multi-task data set containing three tasks", { 67 | dataTask1 <- cbind(task="T1", 68 | rbind( 69 | data.frame(algo="A1", value=0.8, case="C1"), 70 | data.frame(algo="A2", value=0.6, case="C1"), 71 | data.frame(algo="A3", value=0.4, case="C1"), 72 | data.frame(algo="A1", value=0.2, case="C2"), 73 | data.frame(algo="A2", value=0.1, case="C2"), 74 | data.frame(algo="A3", value=0.0, case="C2") 75 | )) 76 | dataTask2 <- cbind(task="T2", 77 | rbind( 78 | data.frame(algo="A1", value=0.2, case="C1"), 79 | data.frame(algo="A2", value=0.3, case="C1"), 80 | data.frame(algo="A3", value=0.4, case="C1"), 81 | data.frame(algo="A1", value=0.7, case="C2"), 82 | data.frame(algo="A2", value=0.8, case="C2"), 83 | data.frame(algo="A3", value=0.9, case="C2") 84 | )) 85 | dataTask3 <- cbind(task="T3", 86 | rbind( 87 | data.frame(algo="A1", value=0.1, case="C1"), 88 | data.frame(algo="A2", value=0.2, case="C1"), 89 | data.frame(algo="A3", value=0.3, case="C1"), 90 | data.frame(algo="A1", value=0.6, case="C2"), 91 | data.frame(algo="A2", value=0.7, case="C2"), 92 | data.frame(algo="A3", value=0.8, case="C2") 93 | )) 94 | 95 | data <- rbind(dataTask1, dataTask2, dataTask3) 96 | 97 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 98 | 99 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 100 | 101 | actualPlot <- network(ranking, edge.col=grDevices::grey.colors, edge.lwd=1, cols=NULL) 102 | expect_is(actualPlot, "network") 103 | }) 104 | -------------------------------------------------------------------------------- /R/Aggregate.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | Aggregate <- function(object,...) UseMethod("Aggregate") 20 | Aggregate.default <- function(object, ...) aggregate(object,...) #stats::aggregate 21 | 22 | Aggregate.list <-function(object, 23 | x, 24 | algorithm, 25 | FUN = mean, 26 | na.treat = "na.rm", 27 | parallel = FALSE, 28 | progress = "none", 29 | case, 30 | alpha = 0.05, 31 | p.adjust.method = "none", 32 | alternative = "one.sided", 33 | test.fun = function(x, y) wilcox.test(x, 34 | y, 35 | alternative = alternative, 36 | exact = FALSE, 37 | paired = TRUE)$p.value, 38 | smallBetter = FALSE, # only needed for significance 39 | ... ) { 40 | call=match.call(expand.dots = T) 41 | if (is.character(FUN) && FUN=="significance"){ 42 | if(missing(case)| missing(smallBetter)| missing(alpha)) stop("If FUN='significance' arguments case, smallBetter and alpha need to be given") 43 | matlist=llply(1:length(object), 44 | function(id){ 45 | piece=object[[id]] 46 | if (length(unique(piece[[algorithm]]))<=1){ 47 | warning("Only one algorithm available in task '", names(object)[id], "'.") 48 | return(data.frame("prop_significance"=rep(NA,length(unique(piece[[algorithm]]))), 49 | row.names = unique(piece[[algorithm]]))) 50 | } 51 | if (is.numeric(na.treat)) piece[,x][is.na(piece[,x])]=na.treat 52 | else if (is.function(na.treat)) piece[,x][is.na(piece[,x])]=na.treat(piece[,x][is.na(piece[,x])]) 53 | else if (na.treat=="na.rm") piece=piece[!is.na(piece[,x]),] 54 | else stop("Argument 'na.treat' is invalid. It can be 'na.rm', numeric value or function.") 55 | 56 | xmean <- significance(piece, 57 | x, 58 | algorithm, 59 | case, 60 | alpha, 61 | p.adjust.method=p.adjust.method, 62 | smallBetter, 63 | alternative=alternative, 64 | ...) 65 | class(xmean)=c("aggregated", 66 | class(xmean)) 67 | xmean 68 | }, 69 | .parallel=parallel, 70 | .progress=progress 71 | ) 72 | isSignificance=TRUE 73 | 74 | } else { 75 | if (is.function(FUN)) FUNname <-gsub('\")',"",gsub('UseMethod(\"',"",deparse(functionBody(FUN)),fixed = T),fixed=T) 76 | else if (is.character(FUN)) FUNname=FUN 77 | 78 | if (is.character(FUN)) FUN=try(eval(parse(text=FUN)), 79 | silent = T) 80 | if (!is.function(FUN)) stop("FUN has to be a function (possibly as character) or 'significance'") 81 | 82 | matlist=llply(object, 83 | function(piece){ 84 | if (is.numeric(na.treat)) piece[,x][is.na(piece[,x])]=na.treat 85 | else if (is.function(na.treat)) piece[,x][is.na(piece[,x])]=na.treat(piece[,x][is.na(piece[,x])]) 86 | else if (na.treat=="na.rm") piece=piece[!is.na(piece[,x]),] 87 | else stop("Argument 'na.treat' is invalid. It can be 'na.rm', numeric value or function.") 88 | 89 | xmean <- aggregate(piece[,x], 90 | by=list(piece[,algorithm]), 91 | FUN=function(z) do.call(FUN,args=list(x=z))) 92 | names(xmean)=c(algorithm, 93 | paste0(x,"_",FUNname)) 94 | rownames(xmean)=xmean[,1] 95 | xmean=xmean[,-1,drop=F] 96 | xmean 97 | }, 98 | .parallel=parallel, 99 | .progress=progress 100 | ) 101 | isSignificance=FALSE 102 | } 103 | names(matlist)=names(object) 104 | res=list(FUN = . %>% (call), 105 | FUN.list=list(FUN), 106 | call=list(call), 107 | data=object, 108 | matlist=matlist, 109 | isSignificance=isSignificance 110 | ) 111 | 112 | class(res)=c("aggregated.list",class(res)) 113 | res 114 | } 115 | -------------------------------------------------------------------------------- /R/methodsplot.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | #' @export 20 | methodsplot <- function(x,...) UseMethod("methodsplot") 21 | 22 | #' @export 23 | methodsplot.default <- function(x, ...) stop("not implemented for this class") 24 | 25 | #' Creates line plots 26 | #' 27 | #' Create line plots that visualize the robustness of ranking across different ranking methods from a challenge object. 28 | #' 29 | #' @param x The challenge object. 30 | #' @param na.treat Indicates how missing perfomance values are treated if sanity check is enabled. It can be 'na.rm', numeric value or function. 31 | #' For a numeric value or function, NAs will be replaced by the specified values. For 'na.rm', rows that contain missing values will be removed. 32 | #' @param methods A list of ranking methods that should be incorporated. 33 | #' @param ordering 34 | #' @param ... Further arguments passed to or from other functions. 35 | #' 36 | #' @return 37 | #' 38 | #' @examples 39 | #' 40 | #' @seealso `browseVignettes("challengeR")` 41 | #' 42 | #' @family functions to visualize ranking stability 43 | #' @export 44 | methodsplot.challenge=function(x, 45 | na.treat=NULL, 46 | methods=list(testBased=.%>%test() %>% rank(ties.method = "min"), 47 | meanThenRank= .%>% aggregate( FUN="mean") %>% rank(ties.method = "min"), 48 | medianThenRank=.%>% aggregate( FUN="median") %>% rank(ties.method = "min"), 49 | rankThenMean= .%>%rank(ties.method = "min") %>% aggregate( FUN="mean") %>%rank(ties.method = "min"), 50 | rankThenMedian=.%>%rank(ties.method = "min") %>% aggregate( FUN="median") %>%rank(ties.method = "min") 51 | ), 52 | ordering, ...) { 53 | 54 | if (any(sapply(x, 55 | function(task) any(is.na(task[,attr(x, "value")]))))) { # only if missings present, else do nothing 56 | if (is.null(na.treat)) { 57 | warning("Please specify na.treat in as.challenge()") 58 | return(NULL) 59 | } else { 60 | xx = melt(x, 61 | id.vars=c(attr(x,"value"), 62 | attr(x,"algorithm") , 63 | attr(x,"case"), 64 | attr(x,"annotator"), 65 | attr(x,"by") 66 | )) 67 | 68 | x=as.challenge(xx, 69 | value=attr(x,"value"), 70 | algorithm=attr(x,"algorithm") , 71 | case=attr(x,"case"), 72 | by=attr(x,"by"), 73 | annotator = attr(x,"annotator"), 74 | smallBetter = attr(x,"smallBetter"), 75 | na.treat=na.treat) 76 | } 77 | } 78 | 79 | a=lapply(methods,function(fun) fun(x)) 80 | dat=melt(a,measure.vars="rank") 81 | colnames(dat)[4:5]=c("task","rankingMethod") 82 | 83 | if (missing(ordering)){ 84 | lev=sort(unique(dat$algorithm)) 85 | lab=lev 86 | } else { 87 | lev=ordering 88 | lab=lev 89 | } 90 | 91 | dat=dat%>% 92 | dplyr::rename(rank=.data$value)%>% 93 | mutate(rank=factor(.data$rank))%>% 94 | mutate(task=factor(.data$task))%>% 95 | mutate(algorithm=factor(.data$algorithm, levels=lev,labels = lab)) 96 | 97 | linePlot <- ggplot(data = dat) + 98 | aes(x = rankingMethod, y = rank, color=algorithm, group=algorithm ) + 99 | geom_line(size=1)+ 100 | xlab("Ranking method") + 101 | ylab("Rank")+ 102 | theme( 103 | strip.placement = "outside", 104 | axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1) 105 | ) 106 | 107 | # Create multi-panel plot with task names as titles for multi-task data set 108 | if (length(x) > 1) { 109 | linePlot <- linePlot + facet_wrap(~ task) 110 | } 111 | 112 | return(linePlot) 113 | } 114 | 115 | # methodsplot.ranked.list does not exist, use methodpsplot.challenge instead since consonsus ranking needed for ordering (or alphabetical ordering instead) 116 | 117 | #similar plot to methods plot, instead of across ranking methods across tasks 118 | lineplot <- function(x,...) UseMethod("lineplot") 119 | lineplot.default <- function(x, ...) stop("not implemented for this class") 120 | 121 | lineplot.challenge=function(x, 122 | ordering,...){ 123 | if (inherits(x,"list")) { 124 | dat=melt(x,measure.vars="rank") 125 | colnames(dat)[4]=c("task") 126 | 127 | if (missing(ordering)){ 128 | lev=sort(unique(dat$algorithm)) 129 | lab=lev 130 | } else { 131 | lev=ordering 132 | lab=paste(1:length(ordering),ordering) 133 | } 134 | 135 | dat=dat%>% 136 | dplyr::rename(rank=.data$value)%>% 137 | mutate(rank=factor(.data$rank))%>% 138 | mutate(task=factor(.data$task))%>% 139 | mutate(algorithm=factor(.data$algorithm, levels=lev,labels = lab)) 140 | 141 | ggplot(data = dat) + 142 | aes(x = task, y = rank, color=algorithm, group=algorithm ) + 143 | geom_line(size=1)+ 144 | theme( 145 | axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1) ) 146 | 147 | } else stop("Only applicable to multiple tasks") 148 | } 149 | -------------------------------------------------------------------------------- /tests/testthat/test-stackedBarPlotStabilityByAlgorithm.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | test_that("stacked bar plot for visualizing ranking stability by algorithm raises error for single-task data set", { 20 | data <- rbind( 21 | data.frame(algo="A1", value=0.8, case="C1"), 22 | data.frame(algo="A2", value=0.6, case="C1"), 23 | data.frame(algo="A3", value=0.4, case="C1"), 24 | data.frame(algo="A1", value=0.2, case="C2"), 25 | data.frame(algo="A2", value=0.1, case="C2"), 26 | data.frame(algo="A3", value=0.0, case="C2")) 27 | 28 | challenge <- as.challenge(data, taskName="T1", algorithm="algo", case="case", value="value", smallBetter=FALSE) 29 | 30 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 31 | 32 | set.seed(1) 33 | rankingBootstrapped <- ranking%>%bootstrap(nboot=10) 34 | 35 | expect_error(stabilityByAlgorithm(rankingBootstrapped, stacked = TRUE), 36 | "The stability of rankings by algorithm cannot be computed for less than two tasks.", fixed=TRUE) 37 | }) 38 | 39 | test_that("stacked bar plot for visualizing ranking stability by algorithm returns one plot for multi-task data set", { 40 | dataTask1 <- cbind(task="T1", 41 | rbind( 42 | data.frame(algo="A1", value=0.8, case="C1"), 43 | data.frame(algo="A2", value=0.6, case="C1"), 44 | data.frame(algo="A3", value=0.4, case="C1"), 45 | data.frame(algo="A1", value=0.2, case="C2"), 46 | data.frame(algo="A2", value=0.1, case="C2"), 47 | data.frame(algo="A3", value=0.0, case="C2") 48 | )) 49 | dataTask2 <- cbind(task="T2", 50 | rbind( 51 | data.frame(algo="A1", value=0.2, case="C1"), 52 | data.frame(algo="A2", value=0.3, case="C1"), 53 | data.frame(algo="A3", value=0.4, case="C1"), 54 | data.frame(algo="A1", value=0.7, case="C2"), 55 | data.frame(algo="A2", value=0.8, case="C2"), 56 | data.frame(algo="A3", value=0.9, case="C2") 57 | )) 58 | 59 | data <- rbind(dataTask1, dataTask2) 60 | 61 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 62 | 63 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 64 | 65 | set.seed(1) 66 | rankingBootstrapped <- ranking%>%bootstrap(nboot=10) 67 | 68 | actualPlot <- stabilityByAlgorithm(rankingBootstrapped, stacked = TRUE) 69 | expect_is(actualPlot, "ggplot") 70 | }) 71 | 72 | test_that("stacked bar plot for visualizing ranking stability by algorithm returns one plot if #algorithms equals #tasks", { 73 | dataTask1 <- cbind(task="T1", 74 | rbind( 75 | data.frame(algo="A1", value=0.8, case="C1"), 76 | data.frame(algo="A2", value=0.6, case="C1"), 77 | data.frame(algo="A1", value=0.2, case="C2"), 78 | data.frame(algo="A2", value=0.1, case="C2") 79 | )) 80 | dataTask2 <- cbind(task="T2", 81 | rbind( 82 | data.frame(algo="A1", value=0.2, case="C1"), 83 | data.frame(algo="A2", value=0.3, case="C1"), 84 | data.frame(algo="A1", value=0.7, case="C2"), 85 | data.frame(algo="A2", value=0.8, case="C2") 86 | )) 87 | 88 | data <- rbind(dataTask1, dataTask2) 89 | 90 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 91 | 92 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 93 | 94 | set.seed(1) 95 | rankingBootstrapped <- ranking%>%bootstrap(nboot=10) 96 | 97 | meanRanks <- ranking%>%consensus(method = "euclidean") 98 | 99 | actualPlot <- stabilityByAlgorithm(rankingBootstrapped, stacked = TRUE) 100 | expect_is(actualPlot, "ggplot") 101 | }) 102 | 103 | test_that("stacked bar plot for visualizing ranking stability by algorithm returns one plot if #algorithms < #tasks", { 104 | dataTask1 <- cbind(task="T1", 105 | rbind( 106 | data.frame(algo="A1", value=0.8, case="C1"), 107 | data.frame(algo="A2", value=0.6, case="C1"), 108 | data.frame(algo="A1", value=0.8, case="C2"), 109 | data.frame(algo="A2", value=0.6, case="C2") 110 | )) 111 | dataTask2 <- cbind(task="T2", 112 | rbind( 113 | data.frame(algo="A1", value=0.2, case="C1"), 114 | data.frame(algo="A2", value=0.3, case="C1"), 115 | data.frame(algo="A1", value=0.2, case="C2"), 116 | data.frame(algo="A2", value=0.3, case="C2") 117 | )) 118 | dataTask3 <- cbind(task="T3", 119 | rbind( 120 | data.frame(algo="A1", value=0.1, case="C1"), 121 | data.frame(algo="A2", value=0.8, case="C1"), 122 | data.frame(algo="A1", value=0.1, case="C2"), 123 | data.frame(algo="A2", value=0.8, case="C2") 124 | )) 125 | 126 | data <- rbind(dataTask1, dataTask2, dataTask3) 127 | 128 | challenge <- as.challenge(data, by="task", algorithm="algo", case="case", value="value", smallBetter=FALSE) 129 | 130 | ranking <- challenge%>%aggregateThenRank(FUN=median, ties.method="min") 131 | 132 | set.seed(1) 133 | rankingBootstrapped <- ranking%>%bootstrap(nboot=10) 134 | 135 | meanRanks <- ranking%>%consensus(method = "euclidean") 136 | 137 | actualPlot <- stabilityByAlgorithm(rankingBootstrapped, stacked = TRUE) 138 | expect_is(actualPlot, "ggplot") 139 | }) 140 | -------------------------------------------------------------------------------- /R/graph.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | network <- function(x,...) UseMethod("network") 20 | network.default <- function(x, ...) stop("not implemented for this class") 21 | 22 | network.ranked.list=function(x, 23 | method = "symdiff", 24 | edge.col, 25 | edge.lwd, 26 | rate=1.05, 27 | cols, 28 | ...) { 29 | if (length(x$data) < 3) { 30 | stop("The cluster analysis is only sensible for more than two tasks.") 31 | } 32 | 33 | # use ranking list 34 | relensemble=as.relation.ranked.list(x) 35 | 36 | # # use relations 37 | # a=challenge_multi%>%decision.challenge(p.adjust.method="none") 38 | # aa=lapply(a,as.relation.challenge.incidence) 39 | # names(aa)=names(challenge_multi) 40 | # relensemble= do.call(relation_ensemble,args = aa) 41 | d <- relation_dissimilarity(relensemble, method = method) 42 | 43 | #coloring 44 | # # use relations 45 | # rm <-my.bsranking(relensemble) #for coloring 46 | # uw <- apply(rm, 2, 47 | # function(x) { 48 | # w <- which(x == 1) 49 | # ifelse(length(w) == 1, 50 | # names(w), "none") 51 | # }) 52 | # use ranking list 53 | uw=lapply(x$matlist,function(task.i) rownames(task.i)[which(task.i$rank==1)]) 54 | uw=sapply(uw, function(task.i) ifelse(length(task.i)==1,yes = task.i,no="none")) 55 | 56 | network.dist(d, 57 | edge.col = edge.col,# grDevices::grey.colors(nn), #terrain_hcl(nn, c=c(65,0), l=c(45,90), power=c(1/2,1.5)), 58 | edge.lwd =edge.lwd,#4*rev(1.2^seq_len(length(unique(d)))/(1.2^length((unique(d))))),# seq(1, .001, length.out=nn), 59 | rate=rate, 60 | node.fill = cols[uw],... 61 | ) 62 | } 63 | 64 | 65 | 66 | network.dist= 67 | function (x, rate=1.05, #ndists.show = length(sort(unique(x))), 68 | edge.col = gray(0.7), 69 | edge.lwd = 1, 70 | node.fill = NULL, 71 | ...) { 72 | nn=length(unique(c(x))) # ==max(rm) number of different distance levels 73 | if (is.function(edge.col)) edge.col=edge.col(nn) 74 | data <- as.matrix(x) 75 | nodes <- colnames(data) 76 | nnodes <- length(nodes) 77 | dists <- sort(unique(x)) 78 | ndists <- length(dists) 79 | dshow <- dists#[seq_len(ndists.show)] 80 | ndshow <- length(dshow) 81 | edge.col <- rep(edge.col, ndshow) 82 | edge.lwd <- rep(edge.lwd, ndshow) 83 | edge.len <- ceiling((rate)^dists)# exponential distance 84 | # edge.len <- ceiling((1.2)^(seq_len(ndists) - 1)) #verwende ordnung 85 | # edge.len <- ceiling((1.05)^(dists-min(dists)+1))# verwende distance mit min==1 86 | edge.weight <- rev(dists) #rev(seq_len(ndists)) 87 | edge.lty <- c(rep("solid", ndshow), 88 | rep("blank", length(dists) - ndshow)) 89 | graph <- new("graphNEL", 90 | nodes = nodes, 91 | edgemode = "undirected") 92 | edgeAttrs <- list() 93 | nodeAttrs <- list() 94 | for (i in 1:(nnodes - 1)) { 95 | for (j in (i + 1):nnodes) { 96 | s <- data[i, j] 97 | # if (s %in% dshow) { 98 | t <- which(s == dists) 99 | graph <- graph::addEdge(nodes[i], nodes[j], graph, 1) #edge.weight[t]) 100 | n <- paste(nodes[i], nodes[j], sep = "~") 101 | edgeAttrs$len[n] <- edge.len[t] # laenge exponentiell 102 | # edgeAttrs$len[n] <- s # laenge prop zu distance 103 | edgeAttrs$color[n] <- "black"#edge.col[t] 104 | edgeAttrs$lwd[n] <- edge.lwd[t] 105 | edgeAttrs$lty[n] <- 1#edge.lty[t] 106 | # } 107 | } 108 | } 109 | if (!is.null(node.fill)) 110 | nodeAttrs$fillcolor[nodes] <- node.fill 111 | 112 | out= list(graph=graph, 113 | nodeAttrs = nodeAttrs, 114 | edgeAttrs = edgeAttrs, 115 | tasknames=nodes, 116 | leg.col=node.fill[unique(names(node.fill))] 117 | ) 118 | class(out)="network" 119 | out 120 | } 121 | 122 | 123 | plot.network=function(x, 124 | layoutType = "neato", 125 | fixedsize=TRUE, 126 | fontsize, 127 | width, 128 | height, 129 | shape="ellipse", 130 | cex=.8, 131 | ... 132 | ){ 133 | graph=x$graph 134 | nodeAttrs=x$nodeAttrs 135 | edgeAttrs=x$edgeAttrs 136 | leg.col=x$leg.col 137 | 138 | layoutType = layoutType 139 | attrs <- Rgraphviz::getDefaultAttrs(layoutType = layoutType) 140 | attrs$node$fixedsize <- fixedsize 141 | attrs$node$shape=shape 142 | if (missing(fontsize)) { 143 | attrs$node$fontsize <- max(sapply(x$tasknames,nchar))-1 144 | } else attrs$node$fontsize=fontsize 145 | if (missing(width)){ 146 | attrs$node$width <- max(sapply(x$tasknames,nchar)) 147 | } else attrs$node$width=width 148 | if (missing(height)) { 149 | attrs$node$height <- max(sapply(x$tasknames,nchar))/2 150 | } else attrs$node$height=height 151 | 152 | ag <- Rgraphviz::agopen(graph, 153 | "", 154 | layoutType = layoutType, 155 | attrs = attrs, 156 | nodeAttrs = nodeAttrs, 157 | edgeAttrs = edgeAttrs) 158 | 159 | plot.new() 160 | l=legend("topright", 161 | names(leg.col), 162 | lwd = 1, 163 | cex=cex, 164 | bg =NA, 165 | plot=F)# bg="white") 166 | w <- grconvertX(l$rect$w, to='inches') 167 | 168 | Rgraphviz::plot(ag,mai=c(0,0,0,w),...) 169 | legend(par('usr')[2], par('usr')[4], 170 | xpd=NA, 171 | names(leg.col), 172 | lwd = 1, 173 | col = leg.col, 174 | bg =NA, 175 | cex=cex)# bg="white") 176 | 177 | } 178 | 179 | 180 | 181 | 182 | 183 | #library(R.utils) 184 | #reassignInPackage("beplot0.matrix","benchmark",my.beplot0.matrix) 185 | #reassignInPackage("beplot0.AlgorithmPerformance","benchmark",my.beplot0.AlgorithmPerformance) 186 | -------------------------------------------------------------------------------- /R/aaggregate.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | test <- function(x,...) UseMethod("test") 20 | test.default <- function(x, ...) stop("not implemented for this class") 21 | test.challenge=function(x,...) aggregate.challenge(x=x, 22 | FUN="significance",...) 23 | 24 | 25 | #' Title 26 | #' 27 | #' @param x 28 | #' @param FUN 29 | #' @param na.treat 30 | #' @param alpha 31 | #' @param p.adjust.method 32 | #' @param parallel 33 | #' @param progress 34 | #' @param ... 35 | #' 36 | #' @return 37 | #' @export 38 | #' 39 | #' @examples 40 | aggregate.challenge=function(x, 41 | FUN=mean, 42 | na.treat, #either "na.rm", numeric value or function 43 | alpha=0.05, p.adjust.method="none",# only needed for significance 44 | parallel=FALSE, 45 | progress="none",...){ 46 | call=as.list(match.call()) 47 | if (missing(na.treat) && !is.null(attr(x,"na.treat"))) na.treat <- attr(x, "na.treat") 48 | 49 | if (missing(na.treat)){ #na.treat only optional if no missing values in data set 50 | if (!inherits(x,"list")){ 51 | if (!any(is.na(x[,attr(x, "value")]))) na.treat="na.rm" # there are no missings so set na.treat by dummy "na.rm" has no effect 52 | } else { 53 | if (!any(sapply(x, 54 | function(task) any(is.na(task[,attr(x, "value")]))))) na.treat="na.rm" # there are no missings so set na.treat by dummy "na.rm" has no effect 55 | } 56 | } else attr(x,"na.treat") <- na.treat 57 | 58 | res1=do.call("Aggregate",list(object=x, 59 | x=attr(x,"value"), 60 | algorithm=attr(x,"algorithm"), 61 | FUN=call$FUN, 62 | na.treat=na.treat, 63 | parallel=parallel, 64 | progress=progress, 65 | case=attr(x,"case"), 66 | alpha=alpha, p.adjust.method=p.adjust.method, 67 | smallBetter=attr(x,"smallBetter") # only needed for significance 68 | )) 69 | 70 | call2=call("Aggregate", 71 | object=call$x, 72 | x=attr(x,"value"), 73 | algorithm=attr(x,"algorithm"), 74 | FUN=call$FUN, 75 | na.treat=na.treat, 76 | parallel=parallel,progress=progress, 77 | case=attr(x,"case"), 78 | alpha=alpha, p.adjust.method=p.adjust.method, 79 | smallBetter=attr(x,"smallBetter") # only needed for significance 80 | ) 81 | 82 | if (inherits(x,"list")){ 83 | res=list(FUN = . %>% (call2), 84 | call=list(call2), 85 | FUN.list=list(FUN), 86 | data=x, 87 | matlist=res1$matlist, 88 | isSignificance=res1$isSignificance) 89 | 90 | class(res)=c("aggregated.list",class(res)) 91 | } else { 92 | res=list(FUN = . %>% (call2), 93 | call=list(call2), 94 | FUN.list=list(FUN), 95 | data=x, 96 | mat=res1$mat, 97 | isSignificance=res1$isSignificance) 98 | 99 | class(res)=c("aggregated",class(res)) 100 | 101 | } 102 | res 103 | 104 | } 105 | 106 | 107 | aggregate.ranked.list <-function(x, 108 | FUN=mean, 109 | ...){ 110 | call=match.call(expand.dots = F) 111 | call=call("aggregate.ranked.list", 112 | x=call$x, 113 | FUN=FUN) 114 | 115 | algorithm=attr(x$data,"algorithm") 116 | resmatlist=Aggregate.list(x$matlist, 117 | x="rank", 118 | algorithm=algorithm, 119 | FUN=FUN,...)$matlist 120 | resmatlist=lapply(resmatlist, 121 | function(z) as.data.frame(z)) 122 | res=list(matlist=resmatlist, 123 | call=c(x$call,call), 124 | data=x$data, 125 | FUN = . %>% (x$FUN) %>% (call), 126 | FUN.list=c(x$FUN.list,FUN) 127 | ) 128 | class(res)=c("aggregatedRanks.list",class(res)) 129 | res 130 | 131 | } 132 | 133 | 134 | aggregate.bootstrap.list <-function(x, 135 | what="metric", 136 | FUN=mean, 137 | ...){ 138 | call=match.call(expand.dots = T) 139 | if (is.character(FUN)) FUN=try(eval(parse(text=FUN)), 140 | silent = T) 141 | FUNname=as.character(call$FUN) 142 | 143 | if (!is.function(FUN)) stop("FUN has to be a function (possibly as character)") 144 | matlist=llply(1:length(x$bootsrappedRank), 145 | function(i.piece){ 146 | if (what=="ranks") xmean <- as.data.frame(apply(x$bootsrappedRank[[i.piece]],1,FUN=FUN)) 147 | else xmean <- as.data.frame(apply(x$bootsrappedAggregate[[i.piece]],1,FUN=FUN)) 148 | names(xmean)=paste0(what,"_",FUNname) 149 | xmean 150 | }) 151 | 152 | 153 | names(matlist)=names(x$bootsrappedRank) 154 | res=list(FUN = . %>% (call), 155 | call=list(call), 156 | data=x, 157 | matlist=matlist) 158 | 159 | class(res)=c("aggregated.list",class(res)) 160 | res 161 | } 162 | 163 | aggregate.bootstrap<-function(x,what="metric",FUN=mean, 164 | ... ){ 165 | call=match.call(expand.dots = T) 166 | if (is.character(FUN)) FUN=try(eval(parse(text=FUN)),silent = T) 167 | FUNname=as.character(call$FUN) 168 | 169 | if (!is.function(FUN)) stop("FUN has to be a function (possibly as character)") 170 | 171 | if (what=="ranks") xmean <- as.data.frame(apply(x$bootsrappedRank, 172 | 1, 173 | FUN=FUN)) 174 | else xmean <- as.data.frame(apply(x$bootsrappedAggregate, 175 | 1, 176 | FUN=FUN)) 177 | names(xmean)=paste0(what,"_",FUNname) 178 | res=list(FUN = . %>% (call), 179 | call=list(call), 180 | data=x, 181 | mat=xmean) 182 | 183 | class(res)=c("aggregated",class(res)) 184 | res 185 | } 186 | -------------------------------------------------------------------------------- /R/significanceMap.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | #' @export 20 | significanceMap <- function(object,...) UseMethod("significanceMap") 21 | 22 | #' @export 23 | significanceMap.default <- function(object, ...) stop("not implemented for this class") 24 | 25 | #' Creates significance maps 26 | #' 27 | #' Creates significance maps from a ranked assessment data set. 28 | #' 29 | #' @param object The ranked assessment data set. 30 | #' @param alpha A numeric values specifying the significance level. 31 | #' @param p.adjust.method A string specifying the adjustment method for multiple testing, see [stats::p.adjust()]. 32 | #' @param order 33 | #' @param size.rank 34 | #' @param ... Further arguments passed to or from other functions. 35 | #' 36 | #' @return 37 | #' 38 | #' @examples 39 | #' 40 | #' @seealso `browseVignettes("challengeR")` 41 | #' 42 | #' @family functions to visualize ranking stability 43 | #' @export 44 | significanceMap.ranked.list=function(object, 45 | alpha=0.05,p.adjust.method="holm", 46 | order=FALSE, 47 | size.rank=.3*theme_get()$text$size,...){ 48 | 49 | a=object$data%>%decision.challenge(na.treat=object$call[[1]][[1]]$na.treat, 50 | alpha=alpha, 51 | p.adjust.method=p.adjust.method) 52 | 53 | aa=lapply(a, as.relation.challenge.incidence) 54 | names(aa)=names(object$data) 55 | 56 | relensemble= do.call(relation_ensemble,args = aa) 57 | 58 | res=list() 59 | for (task in names(object$data)){ 60 | res[[task]]=significanceMap.data.frame(object=object$matlist[[task]], 61 | relation_object=relensemble[[task]], 62 | order=order, 63 | size.rank=size.rank,... 64 | ) + ggtitle(task) 65 | 66 | } 67 | 68 | # Remove title for single-task data set 69 | if (length(res) == 1) { 70 | res[[1]]$labels$title <- NULL 71 | return(res[[1]]) 72 | } else { 73 | names(res) = names(object$matlist) 74 | class(res) <- "ggList" 75 | return(res) 76 | } 77 | } 78 | 79 | 80 | significanceMap.data.frame=function(object, 81 | relation_object, 82 | order=FALSE, 83 | size.rank=.3*theme_get()$text$size,...){ 84 | 85 | object$algorithm=rownames(object) 86 | inc=relation_incidence(relation_object) 87 | 88 | if (order){ 89 | scores=apply(inc,1, 90 | function(x) sum(x==0)-1) 91 | scores2=apply(inc,2, 92 | function(x) sum(x==1))[names(scores)]#+1-nrow(inc)) 93 | scores=data.frame(algorithm=names(scores), 94 | score=scores, 95 | score2=scores2, 96 | stringsAsFactors =F) 97 | scores=right_join(scores, 98 | object, 99 | by="algorithm") 100 | 101 | ordering= (scores[order(scores$score, 102 | scores$score2, 103 | scores$rank),"algorithm"]) 104 | scores=scores[,1:3] 105 | } else ordering= names(sort(t(object[,"rank",drop=F])["rank",])) 106 | 107 | inc=inc[ordering,] 108 | 109 | incidence.mat=melt(inc) 110 | colnames(incidence.mat)=c("algorithm","notsigPair", "decision") 111 | incidence.mat$algorithm=as.character(incidence.mat$algorithm) 112 | incidence.mat$notsigPair=as.character(incidence.mat$notsigPair) 113 | incidence.mat=right_join(incidence.mat, 114 | object, 115 | by="algorithm") 116 | if (order) incidence.mat=right_join(incidence.mat, 117 | scores, 118 | by="algorithm") 119 | 120 | incidence.mat=incidence.mat%>%mutate(algorithm=factor(.data$algorithm, 121 | levels=ordering), 122 | notsigPair=factor(.data$notsigPair, 123 | levels=ordering)) 124 | 125 | incidence.mat$decision=as.factor(incidence.mat$decision) 126 | 127 | p=ggplot(incidence.mat) + 128 | geom_raster(aes(algorithm, 129 | notsigPair, 130 | fill=decision),...)+ 131 | geom_raster(aes(algorithm,algorithm), 132 | fill="white")+ 133 | geom_abline(slope=1) + 134 | coord_cartesian(clip = 'off')+ 135 | theme(aspect.ratio=1, 136 | axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1), 137 | plot.margin=unit(c(1,1,1,1), "lines"), 138 | legend.position="none")+ 139 | ylab("Algorithm")+ 140 | xlab("Algorithm")+ 141 | scale_fill_manual(values=cividis(2,begin=0,end=1,alpha=.7)) 142 | 143 | fixy=0 144 | th_get=theme_get() 145 | # grid on top 146 | lt=th_get$panel.grid$linetype 147 | if (is.null(lt)) lt=th_get$line$linetype 148 | gridSize=c(th_get$panel.grid.major$size,th_get$panel.grid$size,th_get$line$size)[1] 149 | 150 | 151 | #p=p+theme(panel.background = element_rect(fill = NA),panel.ontop=TRUE) #-> grid will be on top of diagonal 152 | #fix: 153 | f=ggplot_build(p) 154 | p= p + geom_vline(xintercept=f$layout$panel_params[[1]]$x$breaks, 155 | linetype=lt, 156 | color=th_get$panel.grid$colour, 157 | size=gridSize)+ 158 | geom_hline(yintercept=f$layout$panel_params[[1]]$y$breaks, 159 | linetype=lt, 160 | color=th_get$panel.grid$colour, 161 | size=gridSize)+ 162 | geom_abline(slope=1)+ 163 | geom_text(aes(x=algorithm,y=fixy,label=rank), 164 | nudge_y=.5, 165 | vjust = 0, 166 | size=size.rank, 167 | fontface="plain",family="sans" 168 | ) 169 | 170 | 171 | if (order) p= p+ 172 | geom_text(aes(x=algorithm,y=fixy,label=score), 173 | nudge_y=0, 174 | vjust = 0, size=size.rank, 175 | fontface="plain",family="sans") + 176 | annotate("text", 177 | x=0,y=fixy+.5, 178 | vjust = 0, 179 | size=size.rank, 180 | fontface="plain", 181 | family="sans", 182 | label="original")+ 183 | annotate("text",x=0,y=fixy, 184 | vjust = 0, 185 | size=size.rank, 186 | fontface="plain",family="sans",label="new") 187 | 188 | return(p) 189 | 190 | } 191 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | S3method("+",ggList) 2 | S3method(print,ggList) 3 | export("%++%") 4 | #export("%+%") 5 | export( 6 | "aggregate.bootstrap", "aggregate.bootstrap.list", "aggregate.challenge", "aggregate.ranked.list", 7 | "aggregateThenRank", 8 | "as.challenge", 9 | "as.relation.challenge.incidence", "as.relation.ranked.list", 10 | "bootstrap", "bootstrap.ranked.list", 11 | "boxplot.ranked.list", "boxplot.bootstrap.list", "boxplot.comparedRanks.list", 12 | "compareRanks", "compareRanks.ranked.list", 13 | "consensus", "consensus.ranked.list", 14 | "Decision", "decision.challenge", 15 | "default_colors", 16 | "density.bootstrap.list", 17 | "dendrogram", "dendrogram.ranked.list", 18 | "extract.workflow", 19 | "kendall", "kendall.bootstrap.list", 20 | "lineplot.challenge", 21 | "methodsplot","methodsplot.challenge", 22 | "network", "plot.network", 23 | "podium","podium.ranked.list", "podium.challenge", 24 | "print.aggregated", "print.aggregated.list", "print.comparedRanks", "print.ranked", "print.ranked.list", 25 | "rank", "rank.aggregated.list", "rank.aggregatedRanks.list", "rank.challenge", 26 | "rankFrequencies", "rankFrequencies.bootstrap", "rankFrequencies.bootstrap.list", 27 | "rankThenAggregate", 28 | "rankingHeatmap", "rankingHeatmap.ranked.list", "relation_dissimilarity.ranked.list", 29 | "report", "report.bootstrap.list", 30 | "select.if", "select.if.aggregated.list", "select.if.comparedRanks.list", "select.if.list", "select.if.ranked.list", 31 | "significanceMap", 32 | "spearmansFootrule", "spearmansWeightedFootrule", 33 | "splitby", 34 | "stability", "stabilityByAlgorithm", "stabilityByTask", 35 | "stability.ranked.list", "relation_dissimilarity", 36 | "stabilityByAlgorithm.bootstrap.list", 37 | "stabilityByTask.bootstrap.list", 38 | "subset", 39 | "subset.aggregated.list", "subset.comparedRanks.list", "subset.list", "subset.ranked.list", "subset.bootstrap.list", 40 | "test", "test.challenge", "test.default", 41 | "testThenRank", 42 | "violin", "violin.bootstrap.list", 43 | "winner", "winner.bootstrap.list", "winner.default", "winner.ranked.list", 44 | "winnerFrequencies", "winnerFrequencies.bootstrap", "winnerFrequencies.bootstrap.list", "winnerFrequencies.default" 45 | ) 46 | 47 | 48 | importFrom("dplyr", "bind_rows","group_by","summarise","select_if","filter","mutate","right_join","anti_join","ungroup","arrange","desc") 49 | importFrom("rlang",":=",".data","!!") 50 | importFrom("reshape2","melt", "acast") 51 | importFrom("utils", "capture.output", "methods") 52 | importFrom("plyr", "llply") 53 | importFrom("knitr", "kable") 54 | importFrom("tidyr", "complete","expand") 55 | importFrom("purrr", "%>%") 56 | importFrom("rmarkdown", "render","word_document","pdf_document","html_document") 57 | importFrom("viridisLite", "viridis","cividis") 58 | importFrom("ggplot2", "aes","aes_string","geom_abline", "geom_bar", "geom_boxplot", "geom_count", "geom_density", "geom_jitter", 59 | "geom_line", "geom_point", "geom_raster", "geom_step", "geom_text", "geom_violin","annotate","guide_legend", 60 | "geom_vline", "ggplot", "ggtitle","vars","xlab","ylab","scale_size_area","theme_get","rel","geom_hline","ggplot_build","scale_fill_manual", 61 | "scale_y_continuous","coord_cartesian", "element_text", "facet_wrap", "position_jitter", "stat", "stat_summary", "theme", "unit","guides","scale_fill_viridis_c", 62 | "theme_set", "theme_light", "scale_color_manual", "element_blank") 63 | importFrom("grDevices", "col2rgb", "gray", "rgb", "grey") 64 | importFrom("graphics", "abline", "axis", "barplot", "box", "layout", 65 | "legend", "par", "plot", "points", "segments","boxplot", "stripchart", "title", "grconvertX", "plot.new") 66 | importFrom("stats", "as.dist", "as.formula", "median", "p.adjust", "density", 67 | "quantile", "aggregate", "cor", "wilcox.test", "terms.formula", "complete.cases") 68 | importFrom("methods", "new") 69 | importFrom("relations","relation","as.relation", 70 | "relation_domain", "relation_incidence", "relation_is_asymmetric","relation_consensus","relation_ensemble", 71 | "relation_is_irreflexive", "relation_is_negatively_transitive", 72 | "relation_is_transitive", "relation_is_trichotomous", "relation_scores", 73 | "relation_violations","relation_dissimilarity") 74 | importFrom("graph", "addEdge") 75 | 76 | 77 | S3method(print, comparedRanks) 78 | S3method(print, aggregated) 79 | S3method(print, ranked) 80 | S3method(print, aggregated.list) 81 | S3method(print, ranked.list) 82 | 83 | S3method(aggregate, challenge) 84 | S3method(aggregate, ranked.list) 85 | S3method(aggregate, bootstrap.list) 86 | S3method(aggregate, bootstrap) 87 | 88 | S3method(test, default) 89 | S3method(test, challenge) 90 | 91 | S3method(Aggregate, default) 92 | S3method(Aggregate, list) 93 | 94 | S3method(Rank, default) 95 | S3method(Rank, list) 96 | 97 | S3method(rank, default) 98 | S3method(rank, challenge) 99 | S3method(rank, aggregated.list) 100 | S3method(rank, aggregatedRanks.list) 101 | 102 | S3method(bootstrap, default) 103 | S3method(bootstrap, ranked.list) 104 | 105 | S3method(dendrogram, default) 106 | S3method(dendrogram, ranked.list) 107 | 108 | S3method(winner, default) 109 | S3method(winner, ranked.list) 110 | S3method(winner, bootstrap.list) 111 | 112 | S3method(rankFrequencies, default) 113 | S3method(rankFrequencies, bootstrap) 114 | S3method(rankFrequencies, bootstrap.list) 115 | 116 | S3method(winnerFrequencies, default) 117 | S3method(winnerFrequencies, bootstrap) 118 | S3method(winnerFrequencies, bootstrap.list) 119 | 120 | 121 | S3method(compareRanks,default) 122 | S3method(compareRanks,ranked.list) 123 | 124 | S3method(merge,list) 125 | 126 | S3method(melt,ranked.list) 127 | S3method(melt,aggregated.list) 128 | 129 | S3method(boxplot,ranked.list) 130 | S3method(boxplot,comparedRanks.list) 131 | S3method(boxplot,bootstrap.list) 132 | 133 | S3method(select.if,default) 134 | S3method(select.if,list) 135 | S3method(select.if,aggregated.list) 136 | S3method(select.if,ranked.list) 137 | S3method(select.if,comparedRanks.list) 138 | 139 | S3method(subset,list) 140 | S3method(subset,bootstrap.list) 141 | S3method(subset,aggregated.list) 142 | S3method(subset,ranked.list) 143 | S3method(subset,comparedRanks.list) 144 | 145 | S3method(podium,default) 146 | S3method(podium,challenge) 147 | S3method(podium,ranked.list) 148 | 149 | S3method(network,default) 150 | S3method(network,ranked.list) 151 | S3method(network,dist) 152 | S3method(plot,network) 153 | 154 | S3method(density,bootstrap.list) 155 | 156 | S3method(as.relation,challenge.incidence) 157 | S3method(as.relation,ranked.list) 158 | 159 | S3method(subset,bootstrap.list) 160 | S3method(subset,ranked.list) 161 | S3method(subset,list) 162 | S3method(subset,comparedRanks.list) 163 | S3method(subset,aggregated.list) 164 | 165 | S3method(decision,challenge) 166 | S3method(decision,default) 167 | 168 | S3method(lineplot,challenge) 169 | S3method(lineplot,default) 170 | 171 | S3method(methodsplot,challenge) 172 | S3method(methodsplot,default) 173 | 174 | S3method(significanceMap,data.frame) 175 | S3method(significanceMap,ranked.list) 176 | S3method(significanceMap,default) 177 | 178 | S3method(violin,bootstrap.list) 179 | S3method(violin,default) 180 | 181 | S3method(rankingHeatmap,ranked.list) 182 | S3method(rankingHeatmap,default) 183 | 184 | S3method(relation_dissimilarity,ranked.list) 185 | S3method(relation_dissimilarity,default) 186 | 187 | S3method(stabilityByTask,bootstrap.list) 188 | S3method(stabilityByTask,default) 189 | S3method(stability,default) 190 | S3method(stability,ranked.list) 191 | 192 | S3method(stabilityByAlgorithm,bootstrap.list) 193 | S3method(stabilityByAlgorithm,default) 194 | 195 | S3method(consensus,ranked.list) 196 | S3method(consensus,default) 197 | 198 | S3method(report,bootstrap.list) 199 | S3method(report,ranked.list) 200 | S3method(report,default) 201 | -------------------------------------------------------------------------------- /R/testBased.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | decision <- function(x,...) UseMethod("decision") 20 | decision.default <- function(x, ...) stop("not implemented for this class") 21 | 22 | decision.challenge=function(x, 23 | na.treat=NULL, # it can be 'na.rm', numeric value or function 24 | alpha=0.05, 25 | p.adjust.method="none", 26 | alternative="one.sided", 27 | test.fun=function(x,y) wilcox.test(x,y, 28 | alternative = alternative,exact=FALSE, 29 | paired = TRUE)$p.value, 30 | parallel=FALSE, 31 | progress="none",...){ 32 | 33 | if (is.null(na.treat)){ #na.treat only optional if no missing values in data set 34 | if (!inherits(x,"list")){ 35 | if (!any(is.na(x[,attr(x, "value")]))) na.treat="na.rm" # there are no missings so set na.treat by dummy "na.rm" has no effect 36 | else stop("Please specify na.treat in as.challenge()") 37 | } else { 38 | if (!any(sapply(x, 39 | function(task) any(is.na(task[,attr(x, "value")]))))) na.treat="na.rm" # there are no missings so set na.treat by dummy "na.rm" has no effect 40 | else stop("Please specify na.treat in as.challenge()") 41 | } 42 | } 43 | 44 | 45 | if (alternative!="two.sided") alternative=ifelse(!attr(x,"smallBetter"), 46 | yes="greater", 47 | no="less") 48 | call=match.call(expand.dots = T) 49 | 50 | object=x 51 | algorithm=attr(object,"algorithm") 52 | case=attr(object,"case") 53 | value=attr(object,"value") 54 | smallBetter=attr(object,"smallBetter") 55 | if(missing(case)| missing(smallBetter)) stop("arguments case and alpha need to be given in as.challenge()") 56 | 57 | 58 | if (inherits(object,"list")){ 59 | matlist=llply(1:length(object), 60 | function(id){ 61 | piece=object[[id]] 62 | if (length(unique(piece[[algorithm]]))<=1){ 63 | warning("only one ", algorithm, " available in element ", names(object)[id]) 64 | } 65 | if (is.numeric(na.treat)) piece[,value][is.na(piece[,value])]=na.treat 66 | else if (is.function(na.treat)) piece[,value][is.na(piece[,value])]=na.treat(piece[,value][is.na(piece[,value])]) 67 | else if (na.treat=="na.rm") piece=piece[!is.na(piece[,value]),] 68 | mat=Decision(piece, value, algorithm, case, alpha, smallBetter, 69 | p.adjust.method=p.adjust.method, 70 | alternative=alternative, 71 | test.fun=test.fun) 72 | mat=as.data.frame(mat) 73 | mat[is.na(mat)]=0 74 | mat=as.matrix(mat) 75 | class(mat)=c(class(mat),"challenge.incidence") 76 | mat 77 | 78 | }, 79 | .parallel=parallel, 80 | .progress=progress ) 81 | names(matlist)=names(object) 82 | return(matlist) 83 | } else { 84 | if (length(unique(object[[algorithm]]))<=1){ 85 | warning("only one ", algorithm, " available") 86 | matlist=(matrix(NA,1,1)) 87 | } else { 88 | mat=Decision(object, 89 | value, 90 | algorithm, 91 | case, 92 | alpha, 93 | smallBetter, 94 | p.adjust.method=p.adjust.method, 95 | alternative=alternative, 96 | test.fun=test.fun) 97 | } 98 | mat=as.data.frame(mat) 99 | mat[is.na(mat)]=0 100 | mat=as.matrix(mat) 101 | class(mat)=c(class(mat),"challenge.incidence") 102 | return(mat) 103 | 104 | } 105 | } 106 | 107 | 108 | Decision=function(object, 109 | value, 110 | by, 111 | case, 112 | alpha, 113 | smallBetter=TRUE, 114 | p.adjust.method="none", 115 | alternative="one.sided", 116 | test.fun=function(x,y) wilcox.test(x,y, 117 | alternative = alternative,exact=FALSE, 118 | paired = TRUE)$p.value){ 119 | algorithms=unique(object[[by]]) 120 | if (length(unique(object[[case]]))==1){ 121 | warning("Only one case in task.") 122 | } 123 | 124 | combinations=expand.grid(algorithms,algorithms)[,2:1] 125 | combinations=combinations[apply(combinations,1,function(z) anyDuplicated(z)==0),] # remove i==j 126 | 127 | pvalues=sapply(1:nrow(combinations), function(it){ 128 | dat1=object[object[[by]]==combinations[it,1],] 129 | dat2=object[object[[by]]==combinations[it,2],] 130 | id=intersect(dat2[,case],dat1[,case]) 131 | dat1=dat1[match(id,dat1[,case]),value] 132 | dat2=dat2[match(id,dat2[,case]),value] 133 | test.fun(dat1,dat2) 134 | 135 | }) 136 | decisions=as.numeric(p.adjust(pvalues, 137 | method=p.adjust.method)<= alpha) 138 | res=cbind(combinations,decisions) 139 | reshape2::acast(res, 140 | Var2~Var1, 141 | value.var="decisions") 142 | } 143 | 144 | 145 | as.relation.challenge.incidence=function(x, 146 | verbose = FALSE, ...) { 147 | r <- relation(incidence = x, ...) 148 | 149 | props <- check_strict_preference(r) 150 | class <- "strictpref" 151 | r$.Meta$is_decreasing <- FALSE 152 | 153 | r$.Meta <- c(r$.Meta, 154 | structure(props, names = sprintf("is_%s", names(props)))) 155 | 156 | if ( verbose ) { 157 | for ( p in names(props) ) { 158 | cat(sprintf("%s = %s:\n", p, props[[p]])) 159 | print(relation_violations(r, p, TRUE)) 160 | } 161 | } 162 | 163 | structure(r, class = c(class, class(r))) 164 | } 165 | 166 | check_strict_preference= 167 | function(x) { 168 | list(irreflexive = relation_is_irreflexive(x), 169 | asymmetric = relation_is_asymmetric(x), 170 | transitive = relation_is_transitive(x), 171 | negatively_transitive = relation_is_negatively_transitive(x), 172 | trichotomous = relation_is_trichotomous(x)) 173 | } 174 | 175 | 176 | significance=function(object, 177 | value, 178 | algorithm, 179 | case, 180 | alpha, 181 | smallBetter=TRUE,...) { 182 | 183 | xx=as.challenge(object, 184 | value=value, 185 | algorithm=algorithm, 186 | case=case, 187 | smallBetter = smallBetter, 188 | check=FALSE) 189 | a=decision.challenge(xx, alpha=alpha, ...) 190 | prop_significance=rowSums(a)/(ncol(a)-1) 191 | return(data.frame("prop_significance"=prop_significance, 192 | row.names = names(prop_significance))) 193 | } 194 | -------------------------------------------------------------------------------- /Helmholtz_Imaging_Logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 16 | 18 | 36 | 40 | 44 | 45 | 46 | -------------------------------------------------------------------------------- /R/subset.R: -------------------------------------------------------------------------------- 1 | # Copyright (c) German Cancer Research Center (DKFZ) 2 | # All rights reserved. 3 | # 4 | # This file is part of challengeR. 5 | # 6 | # challengeR is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU General Public License as published by 8 | # the Free Software Foundation, either version 2 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # challengeR is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU General Public License 17 | # along with challengeR. If not, see . 18 | 19 | subset <- function(x,...) UseMethod("subset") 20 | subset.default <- function(x, ...) base::subset(x, ...) 21 | 22 | 23 | subset.comparedRanks.list=function(x, 24 | tasks,...){ 25 | res=x[tasks] 26 | class(res)="comparedRanks.list" 27 | res 28 | } 29 | 30 | subset.list=function(x, 31 | tasks,...){ 32 | x[tasks] 33 | } 34 | 35 | subset.aggregated.list=function(x, 36 | tasks,...){ 37 | call=match.call(expand.dots = T) 38 | if (!is.null(as.list(call$top))) stop("Subset of algorithms only sensible for single task challenges.") 39 | matlist=x$matlist[tasks] 40 | res=list(matlist=matlist, 41 | call=list(x$call,call), 42 | data=x$data, 43 | FUN = . %>% (x$FUN) %>% (call) 44 | ) 45 | 46 | class(res)=class(x) 47 | res 48 | 49 | } 50 | 51 | which.top=function(object, 52 | top){ 53 | mat=object$mat[object$mat$rank<=top,] 54 | rownames(mat)#[order(mat$rank)] 55 | } 56 | 57 | #' Extracts a subset of algorithms or tasks 58 | #' 59 | #' Extracts the top performing algorithms or a subset of tasks. 60 | #' 61 | #' @section Reports for subsets (top list) of algorithms: 62 | #' If ties are present in the ranking, the subset will consist of more than \code{top} algorithms. 63 | #' Line plots for ranking robustness can be used to check whether algorithms performing well in other 64 | #' ranking methods are excluded. Bootstrapping still takes entire uncertainty into account. 65 | #' Podium plots and ranking heatmaps neglect excluded algorithms. Only available for single-task challenges 66 | #' (for multi-task challenges not sensible because each task would contain a different set of algorithms). 67 | #' 68 | #' @section Reports for subsets of tasks: 69 | #' You may want to recompute the consensus ranking after creating the subset. An error will be raised 70 | #' if a task identifier is not contained in the assessment data set to avoid subsequent errors. 71 | #' 72 | #' 73 | #' @param x The ranked asssessment data set. 74 | #' @param top A positive integer specifying the amount of top performing algorithms to be retrieved. 75 | #' @param tasks A vector of strings containing the task identifiers that should remain in the subset. 76 | #' @param ... Further arguments passed to or from other functions. 77 | #' 78 | #' @return An S3 object of class "ranked.list" to represent a ranked assessment data set. 79 | #' 80 | #' @examples 81 | #' 82 | #' \dontrun{ 83 | #' # only show the top 3 algorithms according to the chosen ranking method 84 | #' subset(ranking, top = 3) %>% report(...) 85 | #' } 86 | #' 87 | #' \dontrun{ 88 | #' # restrict report to tasks "task1" and "task2" 89 | #' subset(ranking, tasks=c("task1", "task2")) %>% report(...) 90 | #' } 91 | #' 92 | #' @export 93 | subset.ranked.list <- function(x, 94 | top, 95 | tasks,...) { 96 | 97 | if (!missing(top) & length(x$matlist) != 1) stop("Subset of algorithms only sensible for single-task challenges. Otherwise no consensus ranking is possible.") 98 | 99 | if (!missing(top)){ 100 | taskMat <- x$matlist[[1]] 101 | taskData <- x$data[[1]] 102 | objectTop=x 103 | objectTop$matlist[[1]]=taskMat[taskMat$rank<=top,] 104 | 105 | taskMatRowNames <- rownames(objectTop$matlist[[1]]) 106 | attribute <- attr(objectTop$data,"algorithm") 107 | 108 | selectedRowNames <- taskData[[attribute]] %in% taskMatRowNames 109 | objectTop$data[[1]] <- taskData[selectedRowNames,] 110 | if (is.factor(objectTop$data[[1]][[attribute]])) objectTop$data[[1]][[attribute]] <- droplevels(objectTop$data[[1]][[attribute]]) 111 | 112 | objectTop$fulldata=x$data 113 | return(objectTop) 114 | } else if (!missing(tasks)){ 115 | 116 | if (is.character(tasks) && any(!tasks%in%names(x$matlist))) { 117 | stop("There is/are no task(s) called ",paste(tasks[!tasks%in%names(x$matlist)],collapse = " and "),".") 118 | } 119 | res=list(matlist=x$matlist[tasks], 120 | data=x$data[tasks], 121 | call=x$call, 122 | FUN=x$FUN, 123 | FUN.list=x$FUN.list 124 | ) 125 | 126 | attrib=attributes(x$data) 127 | attrib$names=attr(res$data,"names") 128 | attributes(res$data)=attrib 129 | class(res)=c("ranked.list","list") 130 | return(res) 131 | } 132 | } 133 | 134 | 135 | #' Extracts a subset of algorithms or tasks 136 | #' 137 | #' Extracts the top performing algorithms or a subset of tasks. 138 | #' 139 | #' @section Reports for subsets (top list) of algorithms: 140 | #' If ties are present in the ranking, the subset will consist of more than \code{top} algorithms. 141 | #' Line plots for ranking robustness can be used to check whether algorithms performing well in other 142 | #' ranking methods are excluded. Bootstrapping still takes entire uncertainty into account. 143 | #' Podium plots and ranking heatmaps neglect excluded algorithms. Only available for single-task challenges 144 | #' (for multi-task challenges not sensible because each task would contain a different set of algorithms). 145 | #' 146 | #' @section Reports for subsets of tasks: 147 | #' You may want to recompute the consensus ranking after creating the subset. An error will be raised 148 | #' if a task identifier is not contained in the assessment data set to avoid subsequent errors. 149 | #' 150 | #' 151 | #' @param x The bootstrapped, ranked asssessment data set. 152 | #' @param top A positive integer specifying the amount of top performing algorithms to be retrieved. 153 | #' @param tasks A vector of strings containing the task identifiers that should remain in the subset. 154 | #' @param ... Further arguments passed to or from other functions. 155 | #' 156 | #' @return An S3 object of class "bootstrap.list" to represent a bootstrapped, ranked assessment data set. 157 | #' 158 | #' @examples 159 | #' 160 | #' \dontrun{ 161 | #' # only show the top 3 algorithms according to the chosen ranking method 162 | #' subset(ranking_bootstrapped, top = 3) %>% report(...) 163 | #' } 164 | #' 165 | #' \dontrun{ 166 | #' # restrict report to tasks "task1" and "task2" and recompute consensus ranking 167 | #' meanRanks <- subset(ranking, tasks = c("task1", "task2")) %>% consensus(method = "euclidean") 168 | #' } 169 | #' 170 | #' @export 171 | subset.bootstrap.list=function(x, 172 | top, 173 | tasks, ...) { 174 | 175 | if (!missing(top) & length(x$matlist) != 1) stop("Subset of algorithms only sensible for single-task challenges. Otherwise no consensus ranking is possible.") 176 | 177 | if (!missing(top)){ 178 | objectTop <- subset.ranked.list(x, top = top) 179 | 180 | objectTop$bootsrappedRanks[[1]] <- objectTop$bootsrappedRanks[[1]][rownames(objectTop$matlist[[1]]),] 181 | objectTop$bootsrappedAggregate[[1]] <- objectTop$bootsrappedAggregate[[1]][rownames(objectTop$matlist[[1]]),] 182 | return(objectTop) 183 | } else if (!missing(tasks)){ 184 | if (is.character(tasks) && any(!tasks%in%names(x$matlist))) { 185 | stop("There is/are no task(s) called ",paste(tasks[!tasks%in%names(x$matlist)],collapse = " and "),".") 186 | } 187 | 188 | res=list(bootsrappedRanks=x$bootsrappedRanks[tasks], 189 | bootsrappedAggregate=x$bootsrappedAggregate[tasks], 190 | matlist=x$matlist[tasks], 191 | data=x$data[tasks], 192 | FUN=x$FUN 193 | ) 194 | 195 | attrib=attributes(x$data) 196 | attrib$names=attr(res$data,"names") 197 | attributes(res$data)=attrib 198 | class(res)="bootstrap.list" 199 | return(res) 200 | } 201 | } 202 | --------------------------------------------------------------------------------