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)
}