diff --git a/R/testBased.R b/R/testBased.R index 818e5a7..62dce3a 100644 --- a/R/testBased.R +++ b/R/testBased.R @@ -1,175 +1,175 @@ decision <- function(x,...) UseMethod("decision") decision.default <- function(x, ...) stop("not implemented for this class") decision.challenge=function(x, na.treat=NULL, # it can be 'na.rm', numeric value or function 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, parallel=FALSE, progress="none",...){ if (is.null(na.treat)){ #na.treat only optional if no missing values in data set if (!inherits(x,"list")){ if (!any(is.na(x[,attr(x, "value")]))) na.treat="na.rm" # there are no missings so set na.treat by dummy "na.rm" has no effect else stop("Please specify na.treat in as.challenge()") } else { if (!any(sapply(x, function(task) any(is.na(task[,attr(x, "value")]))))) na.treat="na.rm" # there are no missings so set na.treat by dummy "na.rm" has no effect else stop("Please specify na.treat in as.challenge()") } } if (alternative!="two.sided") alternative=ifelse(!attr(x,"smallBetter"), yes="greater", no="less") call=match.call(expand.dots = T) object=x algorithm=attr(object,"algorithm") case=attr(object,"case") value=attr(object,"value") smallBetter=attr(object,"smallBetter") if(missing(case)| missing(smallBetter)) stop("arguments case and alpha need to be given in as.challenge()") if (inherits(object,"list")){ matlist=llply(1:length(object), function(id){ piece=object[[id]] if (length(unique(piece[[algorithm]]))<=1){ warning("only one ", algorithm, " available in element ", names(object)[id]) } if (is.numeric(na.treat)) piece[,value][is.na(piece[,value])]=na.treat else if (is.function(na.treat)) piece[,value][is.na(piece[,value])]=na.treat(piece[,value][is.na(piece[,value])]) else if (na.treat=="na.rm") piece=piece[!is.na(piece[,value]),] mat=Decision(piece, value, algorithm, case, alpha, smallBetter, p.adjust.method=p.adjust.method, alternative=alternative, test.fun=test.fun) mat=as.data.frame(mat) mat[is.na(mat)]=0 mat=as.matrix(mat) class(mat)=c(class(mat),"challenge.incidence") mat }, .parallel=parallel, .progress=progress ) names(matlist)=names(object) return(matlist) } else { if (length(unique(object[[algorithm]]))<=1){ warning("only one ", algorithm, " available") matlist=(matrix(NA,1,1)) } else { mat=Decision(object, value, algorithm, case, alpha, smallBetter, p.adjust.method=p.adjust.method, alternative=alternative, test.fun=test.fun) } mat=as.data.frame(mat) mat[is.na(mat)]=0 mat=as.matrix(mat) class(mat)=c(class(mat),"challenge.incidence") return(mat) } } Decision=function(object, value, by, case, alpha, smallBetter=TRUE, p.adjust.method="none", alternative="one.sided", test.fun=function(x,y) wilcox.test(x,y, alternative = alternative,exact=FALSE, paired = TRUE)$p.value){ algorithms=unique(object[[by]]) if (length(unique(object[[case]]))==1){ warning("Only one case in task.") } combinations=expand.grid(algorithms,algorithms)[,2:1] combinations=combinations[apply(combinations,1,function(z) anyDuplicated(z)==0),] # remove i==j pvalues=sapply(1:nrow(combinations), function(it){ dat1=object[object[[by]]==combinations[it,1],] dat2=object[object[[by]]==combinations[it,2],] id=intersect(dat2[,case],dat1[,case]) dat1=dat1[match(id,dat1[,case]),value] dat2=dat2[match(id,dat2[,case]),value] test.fun(dat1,dat2) }) decisions=as.numeric(p.adjust(pvalues, method=p.adjust.method)<= alpha) res=cbind(combinations,decisions) reshape2::acast(res, Var2~Var1, value.var="decisions") } as.relation.challenge.incidence=function(x, verbose = FALSE, ...) { r <- relation(incidence = x, ...) props <- check_strict_preference(r) class <- "strictpref" r$.Meta$is_decreasing <- FALSE r$.Meta <- c(r$.Meta, structure(props, names = sprintf("is_%s", names(props)))) if ( verbose ) { for ( p in names(props) ) { cat(sprintf("%s = %s:\n", p, props[[p]])) print(relation_violations(r, p, TRUE)) } } structure(r, class = c(class, class(r))) } check_strict_preference= function(x) { list(irreflexive = relation_is_irreflexive(x), asymmetric = relation_is_asymmetric(x), transitive = relation_is_transitive(x), negatively_transitive = relation_is_negatively_transitive(x), trichotomous = relation_is_trichotomous(x)) } significance=function(object, value, algorithm, case, alpha, smallBetter=TRUE,...) { xx=as.challenge(object, value=value, algorithm=algorithm, case=case, smallBetter = smallBetter, check=FALSE) - a=decision.challenge(xx,...) + a=decision.challenge(xx, alpha=alpha, ...) prop_significance=rowSums(a)/(ncol(a)-1) return(data.frame("prop_significance"=prop_significance, row.names = names(prop_significance))) } diff --git a/R/wrapper.R b/R/wrapper.R index 3a70371..54435b6 100644 --- a/R/wrapper.R +++ b/R/wrapper.R @@ -1,21 +1,21 @@ aggregateThenRank=function(object,FUN,ties.method = "min",...){ object %>% aggregate(FUN=FUN,...) %>% rank(ties.method = ties.method) } -testThenRank=function(object,FUN,ties.method = "min",...){ +testThenRank=function(object, ties.method = "min",...){ object %>% aggregate(FUN="significance",...) %>% rank(ties.method = ties.method) } rankThenAggregate=function(object, FUN, ties.method = "min" ){ object %>% rank(ties.method = ties.method)%>% aggregate(FUN=FUN) %>% rank(ties.method = ties.method) # small rank is always best, i.e. smallBetter always TRUE }