diff --git a/R/boxplot.R b/R/boxplot.R index 789812c..6fa8eab 100644 --- a/R/boxplot.R +++ b/R/boxplot.R @@ -1,81 +1,80 @@ boxplot.ranked.list=function(x, color="blue", jitter.width=0.25,...){ algo=attr(x$data,"algorithm") value=attr(x$data,"value") ranking=x x=x$data for (i in names(x)) { x[[i]][[algo]]=factor(x[[i]][[algo]], levels=rownames(ranking$matlist[[i]][order(ranking$matlist[[i]]$rank),])) } a=lapply(1:length(x),function(id){ ggplot(aes_string(algo,value),data=x[[id]])+ geom_jitter(position=position_jitter(width=jitter.width, height=0), color=color,...)+ geom_boxplot(outlier.shape = NA,fill=NA)+ ggtitle(names(x)[id]) + theme(axis.text.x=element_text(angle = -90, hjust = 0)) + xlab("Algorithm") + ylab("Metric value") }) # Remove title for single-task data set if (length(a) == 1) { a[[1]]$labels$title <- NULL } else { names(a) = names(x$matlist) - class(a) <- "ggList" } - + class(a) <- "ggList" a } boxplot.comparedRanks.list=function(x,...){ tau=sapply(x,function(z) z$tau) boxplot(tau,ylim=c(0,1.0),las=2, outline=FALSE, ylab="Kendall's tau",...) stripchart(tau, vertical = TRUE, method = "jitter", pch = 21, col = "blue", add=TRUE,...) } boxplot.bootstrap.list=function(x,...){ winner.noboot=winner.ranked.list(x) x2=winnerFrequencies(x) n.bootstraps= ncol(x$bootsrappedRanks[[1]]) perc_boot_Winner=lapply(1:length(x2),function(i){ x2.i=x2[[i]] winner.id=which(rownames(x2.i)%in%rownames(winner.noboot[[i]])) #could be multiple winners!!!! 100*x2.i[winner.id,3,drop=F]/n.bootstraps }) boxplot(unlist(perc_boot_Winner),ylim=c(0,100),las=2, outline=FALSE, ylab="% Bootstraps",xlab="Winner ranks 1", sub=paste(n.bootstraps,"Bootstraps"),...) stripchart(unlist(perc_boot_Winner), vertical = TRUE, method = "jitter", pch = 21, col = "blue", add=TRUE,...) } # winnerFrequencies(bb) # winner.datax=winner(datax, largeBetter=TRUE) #no bootstrap # x2=numberRank1(datax,originalranking.datax,datax_boot) # boot_W_1=x2[which(x2$algorithm_id==winner.datax),3] # boot_NW_1=sum(x2[-which(x2$algorithm_id==winner.datax),3]>9) # perc_boot_Winner=boot_W_1/Data$N_Bootstraps # perc_boot_NotWinner=Data$Bootstrap_Rank1_NotWinner/(Data$N_Algo-1) diff --git a/R/rankingHeatmap.R b/R/rankingHeatmap.R index f55ee45..588a550 100644 --- a/R/rankingHeatmap.R +++ b/R/rankingHeatmap.R @@ -1,63 +1,63 @@ rankingHeatmap <- function(x,...) UseMethod("rankingHeatmap") rankingHeatmap.default <- function(x, ...) stop("not implemented for this class") 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,"largeBetter"), 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 } else { names(a) = names(x$matlist) - class(a) <- "ggList" } + class(a) <- "ggList" a } 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/significancePlot.R b/R/significancePlot.R index 1929b8b..4e7d816 100644 --- a/R/significancePlot.R +++ b/R/significancePlot.R @@ -1,149 +1,149 @@ significanceMap <- function(object,...) UseMethod("significanceMap") significanceMap.default <- function(object, ...) stop("not implemented for this class") 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 } else { names(res) = names(object$matlist) - class(res) <- "ggList" } + 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 #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.major_source, linetype=lt, color=th_get$panel.grid$colour, size=rel(th_get$panel.grid.major$size))+ geom_hline(yintercept=f$layout$panel_params[[1]]$y.major_source, linetype=lt, color=th_get$panel.grid$colour, size=rel(th_get$panel.grid.major$size))+ 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) }