diff --git a/NAMESPACE b/NAMESPACE index ce666ef..154e70a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,211 +1,210 @@ S3method("+",ggList) S3method(print,ggList) export( "aggregate.bootstrap", "aggregate.bootstrap.list", "aggregate.challenge", "aggregate.ranked.list", "aggregateThenRank", "as.challenge", "as.relation.challenge.incidence", "as.relation.ranked.list", "bootstrap", "bootstrap.ranked.list", #"bootstrap.default", "boxplot.ranked.list", "boxplot.bootstrap.list", "boxplot.comparedRanks.list", #"check_strict_preference", "compareRanks", "compareRanks.ranked", "compareRanks.ranked.list", # "compareRanks.default", "consensus", "consensus.ranked.list", #"consensus.default", "Decision", "decision.challenge", "default_colors", "density.bootstrap.list", "dendrogram", "dendrogram.ranked.list", "extract.workflow", "kendall", "kendall.bootstrap.list", # "merge.list", "lineplot.challenge", "methodsplot","methodsplot.challenge", "network", "plot.network", "podium","podium.ranked.list", "podium.challenge",#"podium.default", "print.aggregated", "print.aggregated.list", "print.comparedRanks", "print.ranked", "print.ranked.list", #"quickmerge.list", "rank", "rank.aggregated.list", "rank.aggregatedRanks.list", "rank.challenge", #"rank.default", "rankFrequencies", "rankFrequencies.bootstrap", "rankFrequencies.bootstrap.list", #"rankFrequencies.default", #"rankNA2", "rankThenAggregate", "rankingHeatmap", "rankingHeatmap.ranked.list", "relation_dissimilarity.ranked.list", "report", "report.bootstrap.list", "second", "select.if", "select.if.aggregated.list", "select.if.comparedRanks.list", "select.if.list", "select.if.ranked.list", "significanceMap", "spearmansFootrule", "spearmansWeightedFootrule", "splitby", "stability", "stabilityByAlgorithm", "stabilityByAlgorithmStacked","stabilityByTask", "stability.ranked.list", "relation_dissimilarity", "stabilityByAlgorithm.bootstrap.list", "stabilityByAlgorithmStacked.bootstrap.list", "stabilityByTask.bootstrap.list", "subset", "subset.aggregated.list", "subset.comparedRanks.list", "subset.list", "subset.ranked.list", "subset.bootstrap.list", #"which.top", "test", "test.challenge", "test.default", "testThenRank", "violin", "violin.bootstrap.list", "winner", "winner.bootstrap", "winner.bootstrap.list", "winner.default", "winner.ranked", "winner.ranked.list", "winnerFrequencies", "winnerFrequencies.bootstrap", "winnerFrequencies.bootstrap.list", "winnerFrequencies.default" ) importFrom("dplyr", "bind_rows","group_by","summarise","select_if","filter","mutate","right_join","anti_join","ungroup","arrange","desc") importFrom("rlang",":=",".data","!!") importFrom("reshape2","melt", "acast") importFrom("utils", "capture.output", "methods") importFrom("plyr", "llply") importFrom("knitr", "kable") importFrom("tidyr", "complete","expand") importFrom("purrr", "%>%") importFrom("rmarkdown", "render","word_document","pdf_document","html_document") importFrom("viridisLite", "viridis","cividis") importFrom("ggplot2", "aes","aes_string","geom_abline", "geom_bar", "geom_boxplot", "geom_count", "geom_density", "geom_jitter", "geom_line", "geom_point", "geom_raster", "geom_step", "geom_text", "geom_violin","annotate","guide_legend", "geom_vline", "ggplot", "ggtitle","vars","xlab","ylab","scale_size_area","theme_get","rel","geom_hline","ggplot_build","scale_fill_manual", "scale_y_continuous","coord_cartesian", "element_text", "facet_wrap", "position_jitter", "stat", "stat_summary", "theme", "unit","guides","scale_fill_viridis_c", "theme_set", "theme_light", "scale_color_manual", "element_blank") importFrom("grDevices", "col2rgb", "gray", "rgb", "grey") importFrom("graphics", "abline", "axis", "barplot", "box", "layout", "legend", "par", "plot", "points", "segments","boxplot", "stripchart", "title", "grconvertX", "plot.new") importFrom("stats", "as.dist", "as.formula", "median", "p.adjust", "density", "quantile", "aggregate", "cor", "wilcox.test", "terms.formula", "complete.cases") importFrom("methods", "new") importFrom("relations","relation","as.relation", "relation_domain", "relation_incidence", "relation_is_asymmetric","relation_consensus","relation_ensemble", "relation_is_irreflexive", "relation_is_negatively_transitive", "relation_is_transitive", "relation_is_trichotomous", "relation_scores", "relation_violations","relation_dissimilarity") importFrom("graph", "addEdge") S3method(print, comparedRanks) S3method(print, aggregated) S3method(print, ranked) S3method(print, aggregated.list) S3method(print, ranked.list) S3method(aggregate, challenge) S3method(aggregate, ranked.list) S3method(aggregate, bootstrap.list) S3method(aggregate, bootstrap) S3method(test, default) S3method(test, challenge) S3method(Aggregate, default) -S3method(Aggregate, data.frame) S3method(Aggregate, list) S3method(Rank, default) S3method(Rank, list) S3method(rank, default) S3method(rank, challenge) S3method(rank, aggregated.list) S3method(rank, aggregatedRanks.list) S3method(bootstrap, default) S3method(bootstrap, ranked.list) S3method(dendrogram, default) S3method(dendrogram, ranked.list) S3method(winner, default) S3method(winner, ranked) S3method(winner, ranked.list) S3method(winner, bootstrap) S3method(winner, bootstrap.list) S3method(rankFrequencies, default) S3method(rankFrequencies, bootstrap) S3method(rankFrequencies, bootstrap.list) S3method(winnerFrequencies, default) S3method(winnerFrequencies, bootstrap) S3method(winnerFrequencies, bootstrap.list) S3method(compareRanks,default) S3method(compareRanks,ranked) S3method(compareRanks,ranked.list) S3method(merge,list) S3method(melt,ranked.list) S3method(melt,aggregated.list) S3method(boxplot,ranked.list) S3method(boxplot,comparedRanks.list) S3method(boxplot,bootstrap.list) S3method(select.if,default) S3method(select.if,list) S3method(select.if,aggregated.list) S3method(select.if,ranked.list) S3method(select.if,comparedRanks.list) S3method(subset,list) S3method(subset,bootstrap.list) S3method(subset,aggregated.list) S3method(subset,ranked.list) S3method(subset,comparedRanks.list) S3method(podium,default) S3method(podium,challenge) S3method(podium,ranked.list) S3method(network,default) S3method(network,ranked.list) S3method(network,dist) S3method(plot,network) S3method(density,bootstrap.list) S3method(as.relation,challenge.incidence) S3method(as.relation,ranked.list) S3method(subset,bootstrap.list) S3method(subset,ranked.list) S3method(subset,list) S3method(subset,comparedRanks.list) S3method(subset,aggregated.list) S3method(decision,challenge) S3method(decision,default) S3method(lineplot,challenge) S3method(lineplot,default) S3method(methodsplot,challenge) S3method(methodsplot,default) S3method(significanceMap,data.frame) S3method(significanceMap,ranked.list) S3method(significanceMap,default) S3method(violin,bootstrap.list) S3method(violin,default) S3method(rankingHeatmap,ranked.list) S3method(rankingHeatmap,default) S3method(relation_dissimilarity,ranked.list) S3method(relation_dissimilarity,default) S3method(stabilityByTask,bootstrap.list) S3method(stabilityByTask,default) S3method(stability,default) S3method(stability,ranked.list) S3method(stabilityByAlgorithm,bootstrap.list) S3method(stabilityByAlgorithm,default) S3method(stabilityByAlgorithmStacked,bootstrap.list) S3method(stabilityByAlgorithmStacked,default) S3method(consensus,ranked.list) S3method(consensus,default) S3method(report,bootstrap.list) S3method(report,ranked.list) S3method(report,default) diff --git a/R/Aggregate.R b/R/Aggregate.R index 5211082..23b9d59 100644 --- a/R/Aggregate.R +++ b/R/Aggregate.R @@ -1,166 +1,96 @@ Aggregate <- function(object,...) UseMethod("Aggregate") Aggregate.default <- function(object, ...) aggregate(object,...) #stats::aggregate - -Aggregate.data.frame <-function(object, - x, - algorithm, - FUN=mean, - na.treat="na.rm", #can be na.rm, numeric value or function - case, - alpha=0.05, p.adjust.method="none", - alternative="one.sided", - test.fun=function(x,y) wilcox.test(x, - y, - alternative = alternative, - exact=FALSE, - paired = TRUE)$p.value, - largeBetter=TRUE, # only needed for significance - ... ){ - call=match.call(expand.dots = T) - if (is.numeric(na.treat)) object[,x][is.na(object[,x])]=na.treat - else if (is.function(na.treat)) object[,x][is.na(object[,x])]=na.treat(object[,x][is.na(object[,x])]) - else if (na.treat=="na.rm") object=object[!is.na(object[,x]),] - else stop("Argument 'na.treat' is invalid. It can be 'na.rm', numeric value or function.") - - if (is.character(FUN) && FUN=="significance"){ - if(missing(case)| missing(largeBetter)| missing(alpha)) stop("If FUN='significance' arguments case, largeBetter and alpha need to be given") - if (length(unique(object[[algorithm]]))<=1){ - warning("only one ", algorithm, " available") - agg=data.frame() - } else { - agg = significance(object, - x, - algorithm, - case, - alpha, - largeBetter, - p.adjust.method = p.adjust.method, - alternative = alternative, - ... - ) - } - isSignificance=TRUE - } else { - if (is.function(FUN)) FUNname <-gsub('\")',"",gsub('UseMethod(\"',"",deparse(functionBody(FUN)),fixed = T),fixed=T) - else if (is.character(FUN)) FUNname=FUN - if (is.character(FUN)) FUN=try(eval(parse(text=FUN)),silent = T) - - if (!is.function(FUN)) stop("FUN has to be a function (possibly as character) or 'significance'") - agg <- aggregate(object[, x], - by = list(object[, algorithm]), - FUN = function(z) do.call(FUN, args = list(x = z)) - ) - names(agg)=c(algorithm, - paste0(x,"_", - FUNname)) - rownames(agg)=agg[,1] - agg=agg[,-1,drop=F] - isSignificance=FALSE - } - res=list(FUN = . %>% (call), - FUN.list=list(FUN), - call=list(call), - data=object, - mat=agg, - isSignificance= isSignificance) - - class(res)=c("aggregated",class(res)) - res - -} - - Aggregate.list <-function(object, x, algorithm, FUN = mean, na.treat = "na.rm", parallel = FALSE, progress = "none", case, alpha = 0.05, p.adjust.method = "none", alternative = "one.sided", test.fun = function(x, y) wilcox.test(x, y, alternative = alternative, exact = FALSE, paired = TRUE)$p.value, largeBetter = TRUE, # only needed for significance ... ) { call=match.call(expand.dots = T) if (is.character(FUN) && FUN=="significance"){ if(missing(case)| missing(largeBetter)| missing(alpha)) stop("If FUN='significance' arguments case, largeBetter and alpha need to be given") matlist=llply(1:length(object), function(id){ piece=object[[id]] if (length(unique(piece[[algorithm]]))<=1){ warning("Only one algorithm available in task '", names(object)[id], "'.") return(data.frame("prop_significance"=rep(NA,length(unique(piece[[algorithm]]))), row.names = unique(piece[[algorithm]]))) } if (is.numeric(na.treat)) piece[,x][is.na(piece[,x])]=na.treat else if (is.function(na.treat)) piece[,x][is.na(piece[,x])]=na.treat(piece[,x][is.na(piece[,x])]) else if (na.treat=="na.rm") piece=piece[!is.na(piece[,x]),] else stop("Argument 'na.treat' is invalid. It can be 'na.rm', numeric value or function.") xmean <- significance(piece, x, algorithm, case, alpha, p.adjust.method=p.adjust.method, largeBetter, alternative=alternative, ...) class(xmean)=c("aggregated", class(xmean)) xmean }, .parallel=parallel, .progress=progress ) isSignificance=TRUE } else { if (is.function(FUN)) FUNname <-gsub('\")',"",gsub('UseMethod(\"',"",deparse(functionBody(FUN)),fixed = T),fixed=T) else if (is.character(FUN)) FUNname=FUN if (is.character(FUN)) FUN=try(eval(parse(text=FUN)), silent = T) if (!is.function(FUN)) stop("FUN has to be a function (possibly as character) or 'significance'") matlist=llply(object, function(piece){ if (is.numeric(na.treat)) piece[,x][is.na(piece[,x])]=na.treat else if (is.function(na.treat)) piece[,x][is.na(piece[,x])]=na.treat(piece[,x][is.na(piece[,x])]) else if (na.treat=="na.rm") piece=piece[!is.na(piece[,x]),] else stop("Argument 'na.treat' is invalid. It can be 'na.rm', numeric value or function.") xmean <- aggregate(piece[,x], by=list(piece[,algorithm]), FUN=function(z) do.call(FUN,args=list(x=z))) names(xmean)=c(algorithm, paste0(x,"_",FUNname)) rownames(xmean)=xmean[,1] xmean=xmean[,-1,drop=F] xmean }, .parallel=parallel, .progress=progress ) isSignificance=FALSE } names(matlist)=names(object) res=list(FUN = . %>% (call), FUN.list=list(FUN), call=list(call), data=object, matlist=matlist, isSignificance=isSignificance ) class(res)=c("aggregated.list",class(res)) res } diff --git a/R/Bootstrap.R b/R/Bootstrap.R index 549c7c4..f85f99c 100644 --- a/R/Bootstrap.R +++ b/R/Bootstrap.R @@ -1,179 +1,160 @@ bootstrap <- function(object,...) UseMethod("bootstrap") bootstrap.default <- function(object, ...) stop("not implemented for this class") bootstrap.ranked.list=function(object, nboot, parallel=FALSE, progress="text", ...){ algorithm=attr(object$data,"algorithm") by=attr(object$data,"case") # exclude if only 1 data set or less than 3 algorithms tidy.data.id=sapply(object$data, function(data.subset) { ifelse((length(unique(data.subset[[by]]))==1 | length(unique(data.subset[[algorithm]]))<=2 ), yes=FALSE, no=TRUE) }) tidy.data=object$data[tidy.data.id] tidy.matlist=object$matlist[tidy.data.id] res= llply(1:nboot, function(it){ # draw 1 sample for each task bootDatalist = lapply(tidy.data, function(data.subset) { index = unique(data.subset[[by]]) # bootIndex=sample(index,size=length(index),replace=TRUE) # bootData=bind_rows(lapply(bootIndex,function(zz) data.subset[data.subset[[by]]==zz,])) # faster: bootIndex = data.frame(sample(index, size = length(index), replace = TRUE)) colnames(bootIndex) = by bootData = merge(bootIndex, data.subset, by = by) bootData }) attr(bootDatalist, "inverseOrder") = attr(object$data, "inverseOrder") attr(bootDatalist, "algorithm") = attr(object$data, "algorithm") attr(bootDatalist, "case") = attr(object$data, "case") attr(bootDatalist, "check") = FALSE object$FUN(bootDatalist)$mat }, .parallel = parallel, .progress = progress) - - - # rankmatlist=lapply(res[[1]],function(z) z[,"rank",drop=F]) - # for (j in 2:length(res)){ - # rankmatlist=merge.list(rankmatlist,lapply(res[[j]],function(z) z[,"rank",drop=F]),by="row.names", suffixes = c(paste0(".",j-1),paste0(".",j))) - # rankmatlist=lapply(rankmatlist, function(z) { - # rownames(z)=z[,"Row.names"] - # z=z[,-1] - # }) - # } - # - # aggmatlist=lapply(res[[1]],function(z) z[,-2,drop=F]) - # for (j in 2:length(res)){ - # aggmatlist=merge.list(aggmatlist,lapply(res[[j]],function(z) z[,-2,drop=F]),by="row.names", suffixes = c(paste0(".",j-1),paste0(".",j))) - # aggmatlist=lapply(aggmatlist, function(z) { - # rownames(z)=z[,"Row.names"] - # z=z[,-1] - # }) - # } rankmatlist = lapply(res[[1]], function(z) z[, "rank", drop = F] ) for (j in 2:length(res)) { rankmatlist = quickmerge.list(rankmatlist, lapply(res[[j]], function(z) z[, "rank", drop = F])) } aggmatlist = lapply(res[[1]], function(z) z[, -2, drop = F]) for (j in 2:length(res)) { aggmatlist = quickmerge.list(aggmatlist, lapply(res[[j]], function(z) z[, -2, drop = F])) } final=list(bootsrappedRanks=rankmatlist, bootsrappedAggregate=aggmatlist, data=object$data, matlist=tidy.matlist, FUN=object$FUN, FUN.list=object$FUN.list) class(final)=c("bootstrap.list") final } #################################################################################################### # deprecate following functions? rankFrequencies <- function(object,...) UseMethod("rankFrequencies") rankFrequencies.default <- function(object, ...) stop("not implemented for this class") rankFrequencies.bootstrap=function(object, who,...){ if (is.data.frame(who)) who=rownames(who) if (length(who)==1){ res=table(t(object$bootsrappedRanks[rownames(object$bootsrappedRanks)==who,])) cat("\n",who,"\n") print(res) } else { res=lapply(who, function(w){ rr=table(t(object$bootsrappedRanks[rownames(object$bootsrappedRanks)==w,])) cat(w,"\n") print(rr) cat("\n") rr }) } res=c(list(rankFrequencies=res),object) invisible(res) } rankFrequencies.bootstrap.list=function(object, who,...){ if (is.data.frame(who)) who=rownames(who) res=lapply(object$bootsrappedRanks,function(bootMat){ if (length(who)==1){ res=table(t(bootMat[rownames(bootMat)==who,])) cat("\n",who,"\n") print(res) } else { res=lapply(who, function(w){ rr=table(t(bootMat[rownames(bootMat)==w,])) cat(w,"\n") print(rr) cat("\n") rr }) } res }) res=c(list(rankFrequencies=res),object) invisible(res) } winnerFrequencies <- function(object,...) UseMethod("winnerFrequencies") winnerFrequencies.default <- function(object, ...) stop("not implemented for this class") # Achtung: bester rank muss ==1 sein und nicht z.B. 1.5 winnerFrequencies.bootstrap=function(object,...){ rankings_dicho=ifelse(object$bootsrappedRanks==1,1,0) winnerFrequencies=data.frame(winnerFrequency=rowSums(rankings_dicho),row.names = rownames(object$bootsrappedRanks)) res=merge(object$mat,winnerFrequencies,by="row.names",...) rownames(res)=res[,1] res=res[,-1] # res=c(res=res,object) # class(res)="bootstrapResults" res } winnerFrequencies.bootstrap.list=function(object,...){ res=lapply(1:length(object$bootsrappedRanks),function(id){ rankings_dicho=ifelse(object$bootsrappedRanks[[id]]==1,1,0) winnerFrequencies=data.frame(winnerFrequency=rowSums(rankings_dicho),row.names = rownames(object$bootsrappedRanks[[id]])) res=merge(object$matlist[[id]],winnerFrequencies,by="row.names",...) rownames(res)=res[,1] res=res[,-1] res }) names(res)=names(object$bootsrappedRanks) res } diff --git a/R/merge.list.R b/R/merge.list.R index ebfcf91..fa741b9 100644 --- a/R/merge.list.R +++ b/R/merge.list.R @@ -1,55 +1,43 @@ -# merge.list=function(x,y,by="row.names",suffixes = c(".1",".2"),...){ -# if (is.list(x) & is.list(y)){ -# if (!all.equal(names(x),names(y))) stop("list elements must have same names and lists must have same length") -# res=lapply(1:length(x), function(z){ -# merge(x[[z]],y[[z]],by=by,suffixes=suffixes,...) -# }) -# names(res)=names(x) -# res -# -# } else stop("Comparison of a list and a data.frame under construction") -# } - merge.list=function(x,y,by="row.names",suffixes = c(".1",".2"),...){ if (is.list(x) & is.list(y)){ #if (!all.equal(names(x),names(y))) stop("list elements must have same names and lists must have same length") common.elements=intersect(names(x),names(y)) - + res=lapply(common.elements, function(z){ merge(x[[z]],y[[z]],by=by,suffixes=suffixes,...) }) names(res)=common.elements res - + } else stop("Comparison of a list and a data.frame under construction") } - + quickmerge.list=function(x,y){ if (is.list(x) & is.list(y)){ #if (!all.equal(names(x),names(y))) stop("list elements must have same names and lists must have same length") common.elements=intersect(names(x),names(y)) - + res=lapply(common.elements, function(z){ dat1=x[[z]] dat2=y[[z]] dat1=dat1[order(rownames(dat1)),,drop=F] dat2=dat2[order(rownames(dat2)),,drop=F] if (all(rownames(dat1)==rownames(dat2))) { qq=cbind(dat1,dat2) rownames(qq)=rownames(dat1) qq } else { id=intersect(rownames(dat1),rownames(dat2)) dat1=dat1[match(id,rownames(dat1)),] dat2=dat2[match(id,rownames(dat2)),,drop=F] qq=cbind(dat1,dat2) rownames(qq)=rownames(dat1) qq } }) names(res)=common.elements res - + } else stop("Comparison of a list and a data.frame under construction") }