diff --git a/R/rankingHeatmap.R b/R/rankingHeatmap.R index 6c71d59..32a41cd 100644 --- a/R/rankingHeatmap.R +++ b/R/rankingHeatmap.R @@ -1,98 +1,99 @@ #' @export rankingHeatmap <- function(x,...) UseMethod("rankingHeatmap") #' @export rankingHeatmap.default <- function(x, ...) stop("not implemented for this class") #' Creates ranking heatmaps #' #' Creates ranking heatmaps from one or more ranked assessment data sets. #' #' @param x The ranked asssessment data set. #' @param ties.method A string specifying how ties are treated, see [base::rank()]. #' @param ... Further arguments passed to or from other functions. #' #' @return #' #' @examples #' #' @seealso `browseVignettes("challengeR")` #' #' @family functions to visualize assessment data #' @export rankingHeatmap.ranked.list=function (x,ties.method="min",...) { xx=x$data a=lapply(names(x$matlist),function(subt){ ordering=rownames(x$matlist[[subt]])[order(x$matlist[[subt]]$rank)] dd=as.challenge(xx[[subt]], value=attr(xx,"value"), algorithm=attr(xx,"algorithm") , case=attr(xx,"case"), by=attr(xx, "by"), annotator = attr(xx,"annotator"), smallBetter = attr(xx,"smallBetter"), na.treat=x$call[[1]][[1]]$na.treat) rankingHeatmap(dd, ordering=ordering, ties.method=ties.method,...) + ggtitle(subt) }) # Remove title for single-task data set if (length(a) == 1) { a[[1]]$labels$title <- NULL + return(a[[1]]) } else { names(a) = names(x$matlist) + class(a) <- "ggList" + return(a) } - class(a) <- "ggList" - a } #' Creates a ranking heatmap #' #' Creates a ranking heatmap from a challenge object. #' #' @param x The challenge object. #' @param ordering #' @param ties.method A string specifying how ties are treated, see [base::rank()]. #' @param ... Further arguments passed to or from other functions. #' #' @return #' #' @examples #' #' @seealso `browseVignettes("challengeR")` #' #' @family functions to visualize assessment data #' @export rankingHeatmap.challenge=function(x, ordering, ties.method="min",...) { ranking=x%>%rank( ties.method = ties.method ) task <- ranking$matlist[[1]] dat=as.data.frame(table(task[[attr(x,"algorithm")]], task$rank, dnn=c("algorithm","rank")), responseName = "Count") dat$algorithm=factor(dat$algorithm, levels=ordering) ncases=length(unique(task[[attr(x,"case")]])) ggplot(dat)+ geom_raster(aes(algorithm, rank, fill= Count))+ geom_hline(yintercept = seq(1.5,max(task$rank)-.5,by=1), color=grey(.8),size=.3)+ geom_vline(xintercept = seq(1.5,length(unique(dat$algorithm))-.5,by=1), color=grey(.8),size=.3)+ scale_fill_viridis_c(direction = -1, limits=c(0,ncases) )+ theme(axis.text.x = element_text(angle = 90), aspect.ratio=1)+ xlab("Algorithm")+ ylab("Rank") } diff --git a/R/significanceMap.R b/R/significanceMap.R index d3fab6b..84eaada 100644 --- a/R/significanceMap.R +++ b/R/significanceMap.R @@ -1,173 +1,172 @@ #' @export significanceMap <- function(object,...) UseMethod("significanceMap") #' @export significanceMap.default <- function(object, ...) stop("not implemented for this class") #' Creates significance maps #' #' Creates significance maps from a ranked assessment data set. #' #' @param object The ranked assessment data set. #' @param alpha A numeric values specifying the significance level. #' @param p.adjust.method A string specifying the adjustment method for multiple testing, see [stats::p.adjust()]. #' @param order #' @param size.rank #' @param ... Further arguments passed to or from other functions. #' #' @return #' #' @examples #' #' @seealso `browseVignettes("challengeR")` #' #' @family functions to visualize ranking stability #' @export significanceMap.ranked.list=function(object, alpha=0.05,p.adjust.method="holm", order=FALSE, size.rank=.3*theme_get()$text$size,...){ a=object$data%>%decision.challenge(na.treat=object$call[[1]][[1]]$na.treat, alpha=alpha, p.adjust.method=p.adjust.method) aa=lapply(a, as.relation.challenge.incidence) names(aa)=names(object$data) relensemble= do.call(relation_ensemble,args = aa) res=list() for (task in names(object$data)){ res[[task]]=significanceMap.data.frame(object=object$matlist[[task]], relation_object=relensemble[[task]], order=order, size.rank=size.rank,... ) + ggtitle(task) } # Remove title for single-task data set if (length(res) == 1) { res[[1]]$labels$title <- NULL + return(res[[1]]) } else { names(res) = names(object$matlist) - + class(res) <- "ggList" + return(res) } - - class(res) <- "ggList" - res -} + } significanceMap.data.frame=function(object, relation_object, order=FALSE, size.rank=.3*theme_get()$text$size,...){ object$algorithm=rownames(object) inc=relation_incidence(relation_object) if (order){ scores=apply(inc,1, function(x) sum(x==0)-1) scores2=apply(inc,2, function(x) sum(x==1))[names(scores)]#+1-nrow(inc)) scores=data.frame(algorithm=names(scores), score=scores, score2=scores2, stringsAsFactors =F) scores=right_join(scores, object, by="algorithm") ordering= (scores[order(scores$score, scores$score2, scores$rank),"algorithm"]) scores=scores[,1:3] } else ordering= names(sort(t(object[,"rank",drop=F])["rank",])) inc=inc[ordering,] incidence.mat=melt(inc) colnames(incidence.mat)=c("algorithm","notsigPair", "decision") incidence.mat$algorithm=as.character(incidence.mat$algorithm) incidence.mat$notsigPair=as.character(incidence.mat$notsigPair) incidence.mat=right_join(incidence.mat, object, by="algorithm") if (order) incidence.mat=right_join(incidence.mat, scores, by="algorithm") incidence.mat=incidence.mat%>%mutate(algorithm=factor(.data$algorithm, levels=ordering), notsigPair=factor(.data$notsigPair, levels=ordering)) incidence.mat$decision=as.factor(incidence.mat$decision) p=ggplot(incidence.mat) + geom_raster(aes(algorithm, notsigPair, fill=decision),...)+ geom_raster(aes(algorithm,algorithm), fill="white")+ geom_abline(slope=1) + coord_cartesian(clip = 'off')+ theme(aspect.ratio=1, axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1), plot.margin=unit(c(1,1,1,1), "lines"), legend.position="none")+ ylab("Algorithm")+ xlab("Algorithm")+ scale_fill_manual(values=cividis(2,begin=0,end=1,alpha=.7)) fixy=0 th_get=theme_get() # grid on top lt=th_get$panel.grid$linetype if (is.null(lt)) lt=th_get$line$linetype gridSize=c(th_get$panel.grid.major$size,th_get$panel.grid$size,th_get$line$size)[1] #p=p+theme(panel.background = element_rect(fill = NA),panel.ontop=TRUE) #-> grid will be on top of diagonal #fix: f=ggplot_build(p) p= p + geom_vline(xintercept=f$layout$panel_params[[1]]$x$breaks, linetype=lt, color=th_get$panel.grid$colour, size=gridSize)+ geom_hline(yintercept=f$layout$panel_params[[1]]$y$breaks, linetype=lt, color=th_get$panel.grid$colour, size=gridSize)+ geom_abline(slope=1)+ geom_text(aes(x=algorithm,y=fixy,label=rank), nudge_y=.5, vjust = 0, size=size.rank, fontface="plain",family="sans" ) if (order) p= p+ geom_text(aes(x=algorithm,y=fixy,label=score), nudge_y=0, vjust = 0, size=size.rank, fontface="plain",family="sans") + annotate("text", x=0,y=fixy+.5, vjust = 0, size=size.rank, fontface="plain", family="sans", label="original")+ annotate("text",x=0,y=fixy, vjust = 0, size=size.rank, fontface="plain",family="sans",label="new") return(p) }