diff --git a/R/podium.R b/R/podium.R index a853f4d..4a9708d 100644 --- a/R/podium.R +++ b/R/podium.R @@ -1,221 +1,221 @@ #' @export podium <- function(object,...) UseMethod("podium") #' @export podium.default <- function(object, ...) stop("not implemented for this class") #' Creates podium plots #' #' Creates podium plots from one or more ranked assessment data sets. #' #' @param object The ranked asssessment data set. #' @param xlab A string specifying the x-axis label. #' @param ylab A string specifying the y-axis label. #' @param lines.show #' @param lines.alpha #' @param lines.lwd #' @param col #' @param lines.col #' @param dots.pch #' @param dots.cex #' @param places.lty #' @param places.col #' @param legendfn #' @param layout.heights #' @param ... Further arguments passed to or from other functions. #' #' @return #' #' @examples #' #' @seealso `browseVignettes("challengeR")` #' #' @family functions to visualize assessment data #' @export podium.ranked.list=function(object, xlab = "Podium", ylab = "Performance", lines.show = TRUE, lines.alpha = 0.2, lines.lwd = 1, col, lines.col = col, dots.pch = 19, dots.cex = 1, places.lty = 2, places.col = 1, legendfn = function(algs, cols) { legend("topleft", algs, lwd = 1, col = cols, bg = "white") }, layout.heights=c(1,0.4), ...){ x=object$data podiumPlots <- length(names(x)) for (subt in names(x)) { ordering=t(object$matlist[[subt]][,"rank",drop=F])["rank",] if (missing(col)) col=default_colors(length(ordering), algorithms = names(ordering)) dd=as.challenge(x[[subt]], value=attr(x,"value"), algorithm=attr(x,"algorithm"), case=attr(x,"case"), by=attr(x, "by"), annotator = attr(x,"annotator"), smallBetter = attr(x,"smallBetter"), na.treat=object$call[[1]][[1]]$na.treat) podiumPlot <- podium(dd, ordering=ordering, xlab = xlab, ylab = ylab, lines.show = lines.show, lines.alpha = lines.alpha, lines.lwd = lines.lwd, col=col, lines.col = lines.col, dots.pch = dots.pch, dots.cex = dots.cex, places.lty = places.lty, places.col = places.col, legendfn = legendfn, layout.heights=layout.heights, ...) if (length(names(x)) > 1) { title(subt,outer=T,line=-3) } append(podiumPlots, podiumPlot) } } #' Creates a podium plot #' #' Creates a podium plot from a challenge object. #' #' @param object The challenge object. #' @param ordering #' @param xlab A string specifying the x-axis label. #' @param ylab A string specifying the y-axis label. #' @param lines.show #' @param lines.alpha #' @param lines.lwd #' @param col #' @param lines.col #' @param dots.pch #' @param dots.cex #' @param places.lty #' @param places.col #' @param legendfn #' @param layout.heights -#' @param ... +#' @param ... Further arguments passed to or from other functions. #' #' @return #' #' @examples #' #' @seealso `browseVignettes("challengeR")` #' #' @family functions to visualize assessment data #' @export podium.challenge=function(object, ordering, xlab = NULL, ylab = NULL, lines.show = FALSE, lines.alpha = 0.2, lines.lwd = 1, col,lines.col = col, dots.pch = 19, dots.cex = 1, places.lty = 2, places.col = 1, legendfn = function(algs, cols) { legend("topleft", algs, lwd = 1, col = cols, bg = "white") }, layout.heights=c(1,0.4), ...) { ranking=object%>%rank( ties.method = "random" ) task <- ranking$matlist[[1]] dat=as.data.frame(table(task[[attr(object, "algorithm")]], task$rank, dnn=c("algorithm","rank")), responseName = "Count") form=as.formula(paste(attr(object,"case"), attr(object,"algorithm"), sep="~")) ranks=acast(task, form, value.var="rank") values=acast(task, form, value.var=attr(object, "value")) nranks=acast(dat, algorithm~rank, value.var="Count") nalgs <- ncol(ranks) algs <- colnames(ranks) barorder <- order(ordering) orderedAlgorithms= names(ordering)[barorder] ylim=range(task[[attr(object,"value")]], na.rm = TRUE) dotplotborders <- (0:nalgs) * nalgs dotplaces <- (1:nalgs) - 0.5 names(dotplaces) <- orderedAlgorithms linecols <- sapply(lines.col, function(c) { r <- col2rgb(c) rgb(r[1], r[2], r[3], alpha = round(255 * lines.alpha), maxColorValue = 255) }) opar <- par(no.readonly = TRUE) layout(matrix(c(1, 2), nrow = 2, byrow = TRUE), heights =layout.heights) mar <- par("mar") par(mar = c(0, mar[2], mar[3], mar[4])) plot(dotplotborders, rep(ylim[2], nalgs + 1), type = "n", ylim = ylim, ylab = ylab, xlab = "", axes = F) axis(1, at = dotplotborders, labels = NA, lwd = par("lwd")) axis(2, lwd = par("lwd")) box() abline(v = dotplotborders, lty = places.lty, col = places.col) linesegments <- function(x, y, ...) { n <- length(x) segments(x[-n], y[-n], x[-1], y[-1], ...) } drawthe <- function(fn, col, ...) { for (i in 1:nrow(values)) { r <- ranks[i, ] o <- order(r) performances <- (values[i, ])[o] places <- (dotplaces[names(r)] + ((r - 1) * nalgs))[o] fn(places, performances, col = col[names(r)[o]], ...) } } if (lines.show) drawthe(linesegments, linecols, lwd = lines.lwd) drawthe(points, col, pch = dots.pch, cex = dots.cex) legendfn(orderedAlgorithms, col[orderedAlgorithms]) par(mar = c(mar[1], mar[2], 0, mar[4])) barplot(nranks[barorder,], beside = TRUE, width = 1, axes = F, space = c(0, 0), border = NA, ylim = c(0, nrow(ranks)), names.arg = paste(1:nalgs, ".", sep = ""), col = col[orderedAlgorithms], xlab = xlab) axis(1, at = c(0, dotplotborders), labels = NA, lwd = par("lwd")) box() par(opar) } diff --git a/inst/appdir/characterizationOfAlgorithmsBootstrapping.Rmd b/inst/appdir/characterizationOfAlgorithmsBootstrapping.Rmd index 1b6ac2c..21225d7 100644 --- a/inst/appdir/characterizationOfAlgorithmsBootstrapping.Rmd +++ b/inst/appdir/characterizationOfAlgorithmsBootstrapping.Rmd @@ -1,69 +1,67 @@ ### Ranking stability: Ranking variability via bootstrap approach -Blob plot of bootstrap results over the different tasks separated +A blob plot of bootstrap results over the different tasks separated by algorithm allows another perspective on the assessment data. This gives deeper insights into the characteristics -of tasks and the ranking uncertainty of the algorithms in each -task. +of tasks and the ranking uncertainty of the algorithms in each task. \bigskip ```{r blobplot_bootstrap_byAlgorithm,fig.width=7,fig.height = 5} #stabilityByAlgorithm.bootstrap.list if (length(boot_object$matlist)<=6 &nrow((boot_object$matlist[[1]]))<=10 ){ stabilityByAlgorithm(boot_object, ordering=ordering_consensus, max_size = 9, size=4, shape=4, single = F) + scale_color_manual(values=cols) } else { pl=stabilityByAlgorithm(boot_object, ordering=ordering_consensus, max_size = 9, size=4, shape=4, single = T) for (i in 1:length(pl)) print(pl[[i]] + scale_color_manual(values=cols) + guides(size = guide_legend(title="%"),color="none") ) } ``` An alternative representation is provided by a stacked frequency plot of the observed ranks, separated by algorithm. Observed ranks across bootstrap samples are -displayed with coloring according to task. For algorithms that +displayed with coloring according to the task. For algorithms that achieve the same rank in different tasks for the full assessment data set, vertical lines are on top of each other. Vertical lines allow to compare the achieved rank of each algorithm over different tasks. \bigskip ```{r stackedFrequencies_bootstrap_byAlgorithm,fig.width=7,fig.height = 5} -#stabilityByAlgorithm.bootstrap.list if (length(boot_object$matlist)<=6 &nrow((boot_object$matlist[[1]]))<=10 ){ stabilityByAlgorithm(boot_object, ordering=ordering_consensus, stacked = TRUE, single = F) } else { pl=stabilityByAlgorithm(boot_object, ordering=ordering_consensus, stacked = TRUE, single = T) print(pl) } ```