`pvalstest` <-
function(datacgh,data.info,teststat="Chi-square",sepfile="no",dataclinvar,whclinvar=1, group,groupnames,mc="no",comparison="all",lgonly=0,af=0,niter=1000){
    #Xmat<-datacgh;teststat="Chi-square";niter=50;sepfile<- "no";mc="no";group<- c(96,49);comparison<-"all"; groupnames  <- c("er-pos", "er-neg");lgonly<-0;af<-0.1

########FUNCTIONS #################

    pvalpermtwono <- function(pl,nit){
        pv <- c(1)
        for (i in 2:nit){
            if(pl[i]==pl[i-1]) pv <- c(pv,pv[i-1]) else pv <- c(pv,(nit-i+1)/nit)
        }
        return(pv)
    }
    
    pvalpermtwoyes <- function(pl,nit){
        pv <- c(1)
        pv2 <- c(1)
        l <- length(pl)
        pl2 <- pl[l:1]
        for (i in 2:nit){
            if(pl[i]==pl[i-1]) pv <- c(pv,pv[i-1]) else pv <- c(pv,(nit-i+1)/nit)
            if(pl2[i]==pl2[i-1]) pv2 <- c(pv2,pv2[i-1]) else pv2 <- c(pv2,(nit-i+1)/nit)
        }
        pvmin <- 2*apply(cbind(pv,pv2[l:1]),1,min2)
        return(pvmin)
    }
    
    min2 <- function(lst){
        return(min(lst[1],lst[2],0.5))
    }
    
    pvalfuntwono <- function(lijst,nit){
        obs <- lijst[1]
        lijstperm <- lijst[2:(nit+1)] #changed 23/7/09
        tlarg <- length(lijstperm[lijstperm >= obs])/nit
        return(tlarg)
    }
    
    pvalfuntwoyes <- function(lijst,nit){
        #lijst<-TESTpermobs[1738,];nit<-10
        obs <- lijst[1]
        lijstperm <- lijst[2:(nit+1)] #changed 23/7/09
        tlarg <- length(lijstperm[lijstperm >= obs])/nit
        tsmall <- length(lijstperm[lijstperm <= obs])/nit
        return(min(1,2*min(tlarg,tsmall)))
     }
    
    
    
    countlev <- function(row,level)
    {
    length(row[row==level])
    }
    
    countall <- function(row,levels)
    {
    sapply(levels,countlev,row=row)
    }
    
    includewh <- function(exprow, cutp)
    {
    exprow2 <- matrix(exprow,nrow=2)
    exprow3 <- exprow2[1,]+exprow2[2,]
    sapply(exprow3,function(x)ifelse(x>cutp,1,0))
    }
    
    levels<-sort(unique(unlist(as.list(datacgh))))
    Xmat <- as.matrix(datacgh)
  
    if (comparison=="all") {mcgroups <- matrix(c(1,2),ncol=2,byrow=TRUE)} else 
    {mcgroups <- matrix(comparison,ncol=2,byrow=TRUE)}
    
    if(sepfile=="yes"){orderclvar<-"no"} else {orderclvar <- "yes"}
    if (teststat=="KW" | teststat=="KWperm" | teststat =="Chi-square") {twosided <- "no"}
    if (teststat=="Wilcoxon" | teststat=="mcsteelperm") {twosided <- "yes"}
    
    if (orderclvar == "yes")
    {
    groupcum <- c(0,cumsum(group))
    }
    
    lossonly <- function(x){min(x,0)}
    gainonly <- function(x){if(x>=1){return(1)} else {return(0)}}
    gainandamplification <- function(x){if(x<1){return(0)} else {return(x)}}
    countnonnull <- function(row){return(length(row[row!=0]))}
    
    if (lgonly==-1) 
    {
    Xmat <- apply(Xmat,c(1,2),lossonly)
    levels <- c(-1,0)
    }
    if (lgonly==1)
    {
    Xmat <- apply(Xmat,c(1,2),gainonly)
    levels <- c(0,1)
    }
    
    wr <- apply(Xmat,1,countnonnull)
    nc <-ncol(Xmat)
    whichrows <- which(wr>=nc*af)
    Xmat <- Xmat[whichrows,]
    
    
    if (orderclvar=="no"){
        clinvarname <- colnames(dataclinvar)[whclinvar]
        dcv <- dataclinvar[,whclinvar]
        whichnotna <- which(!is.na(dcv))
        dcv <- dcv[whichnotna]
        Xmat <- Xmat[,whichnotna]
        sortdcv <- order(dcv)
        dcvsort <- dcv[sortdcv]
        whlev <- levels(dcvsort)
        groupnames <- sapply(whlev,function(x)paste(clinvarname,"_",x,sep=""))
        Xmat <- Xmat[,sortdcv] #columns of data matrix are ordered according to the groups. Columns should be ordered #according to rows in clinical var data set!
        group <- sapply(whlev,function(x)length(dcvsort[dcvsort==x]))
        groupcum <- c(0,cumsum(group))
    }
    groupnames
    
    nc <-ncol(Xmat)
    
    ###Remove non-relevant groups####
    if (mc=="yes"){
        partgr <- unique(as.vector(mcgroups))
        if (length(partgr) < length(group)){
            groupn <- group[partgr]
            groupcumn <- c(0,cumsum(groupn))
            groupnames <- groupnames[partgr]
            Xmatn <- c()
            for (k in 1:length(partgr)) {
                Xmatn <- cbind(Xmatn,Xmat[,(groupcum[partgr[k]]+1):(groupcum[partgr[k]+1])])
            }
            Xmat <- Xmatn
            group <- groupn
            groupcum <- groupcumn
        }
    }
    #####
    
    
    groupcumpl1 <- groupcum+1
    allreg <- c()
    for (j in 1:length(group)) allreg <- rbind(allreg,c(groupcumpl1[j],groupcum[j+1]))
    nclass <- length(levels)
    ngroup <- length(group)
    datacl <- data.info[whichrows,]
    nr <- nrow(Xmat)
    ncomp <- nrow(mcgroups)



    ###########HERE COMES A MODULE WITH TEST STATS ###########
    sumsq <- function(lt,reg) (sum(lt[reg[1]:reg[2]]))^2
    sumgr <- function(lt,reg1,reg2) sum(rank(c(lt[reg1[1]:reg1[2]],lt[reg2[1]:reg2[2]]),ties.method="average")[1:(reg1[2]-reg1[1]+1)])
    mcstat<- function(compgr, lijst, all) sumgr(lijst,all[compgr[1],],all[compgr[2],])
    mcstatperm<- function(compgr, lijst, all) sum(lijst[all[compgr[1],1]:all[compgr[1],2]])
    
    expectfun <- function(compgr, lijst, all)
    {
    mj <- matrix(c(group[compgr[1]],group[compgr[2]]),nrow=2)
    M <- sum(mj)
    sam1 <- lijst[all[compgr[1],1]:all[compgr[1],2]]
    sam2 <- lijst[all[compgr[2],1]:all[compgr[2],2]]
    count1 <- countall(sam1,levels)
    count2 <- countall(sam2,levels)
    counttot <- count1 + count2
    expect <- mj%*%counttot/M
    #obsminexpsq <- sum((rbind(count1,count2)-expect)^2/expect)
    return(expect)
    }
    
    
    TESTkw <- function(all,lijst,groupsize)
    {
    sum(apply(all,1,sumsq,lt=lijst)/groupsize)
    } 
    
    TESTsteel <- function(all,lijst,mcgroups)
    {
    statcomp <- apply(mcgroups,1,mcstat,lijst=lijst, all=all)
    return(statcomp)
    } 
    
    TESTsteelperm <- function(all,lijst,mcgroups)
    {
    statcomp <- apply(mcgroups,1,mcstatperm,lijst=lijst, all=all)
    return(statcomp)
    } 
    #TESTsteel(allreg,Xmat[1,],mcgroups)
    #TESTsteelperm(allreg,Xmat[1,],mcgroups)
    #mcstat(c(2,3),Xmat[1,],allreg)
    
    TESTchisq <- function(lijstX,compgr,ncX,nctot1,nctot2) #lijst is data, all is sample subsets per group
    {
    lijst <- lijstX[1:ncX]
    expect0 <- matrix(lijstX[(ncX+1):nctot1],nrow=2)
    include0 <- lijstX[(nctot1+1):nctot2]
    if (length(include0[include0==1]) <=1) return(0)
    else
    {
    expect0inc <- rbind(include0,expect0)[,include0==1]
    expect0 <- expect0inc[-1,]
    sam1 <- lijst[1:group[compgr[1]]]
    sam2 <- lijst[(group[compgr[1]]+1):ncX]
    count1 <- countall(sam1,levels)
    count2 <- countall(sam2,levels)
    count12inc <-(rbind(include0,count1,count2))[,include0==1]
    count12 <- count12inc[-1,]
    obsminexpsq <- sum((count12-expect0)^2/expect0)
    #return(list(sam2,count12,expect0,obsminexpsq))
    return(obsminexpsq)
    }
    }
    
    
   
    
    ####observed values  #########  AND  ####Permutation algorithm   #####
    #KW type tests
    if (teststat =="KW")
    {
    rangobs <- t(apply(Xmat,1,rank,ties.method="average"))
    TESTobs <- apply(rangobs,1,TESTkw, all=allreg,groupsize=group)
    
    pmt <- proc.time()
    all_label <- 1:groupcum[ngroup+1]
    TESTpermall <- c()
    #niter <- 2500
    for (i in (1:niter))
    {
    ranseq <- sample(all_label)
    permmat <- Xmat[,ranseq]
    rangmatperm <- t(apply(permmat,1,rank,ties.method="average"))
    TESTperm <- apply(rangmatperm,1,TESTkw, all=allreg,groupsize=group)
    TESTpermall <- cbind(TESTpermall,TESTperm)
    }
    proc.time() - pmt
    }
    
    
    if (teststat =="KWperm")
    {
    #rangobs <- t(apply(Xmat,1,rank,ties.method="average"))
    TESTobs <- apply(Xmat,1,TESTkw, all=allreg,groupsize=group)
    
    pmt <- proc.time()
    all_label <- 1:groupcum[ngroup+1]
    TESTpermall <- c()
    #niter <- 2500
    for (i in (1:niter))
    {
    print(i)
    ranseq <- sample(all_label)
    permmat <- Xmat[,ranseq]
    TESTperm <- apply(permmat,1,TESTkw, all=allreg, groupsize=group)
    TESTpermall <- cbind(TESTpermall,TESTperm)
    }
    proc.time() - pmt
    }
    
    
    #CHANGED MCSTEEL (Wilcoxon) AND MCSTEELPERM 23/7/9. Pairwise permutation instead of joint.
    if (teststat =="Wilcoxon")
    {
    TESTobs <- c() 
    for (j in 1:ncomp) 
    {
    gr <- mcgroups[j,,drop=FALSE]
    Xmatgr <- cbind(Xmat[,allreg[gr[1],1]:allreg[gr[1],2]],Xmat[,allreg[gr[2],1]:allreg[gr[2],2]])
    ncX <- ncol(Xmatgr)
    allgr <- rbind(c(1,(1+allreg[gr[1],2]-allreg[gr[1],1])),c(2+allreg[gr[1],2]-allreg[gr[1],1],ncX))
    gr2 <- matrix(c(1,2),nrow=1)
    TESTobs0 <- apply(Xmatgr,1,TESTsteel,mcgroups=gr2,all=allgr)
    TESTobs <- c(TESTobs,TESTobs0)
    }
    
    pmt <- proc.time()
    TESTpermall <- c()
    #niter <- 500
    for (j in (1:ncomp))
    {
    gr <- mcgroups[j,,drop=FALSE]
    Xmatgr <- cbind(Xmat[,allreg[gr[1],1]:allreg[gr[1],2]],Xmat[,allreg[gr[2],1]:allreg[gr[2],2]])
    ncX <- ncol(Xmatgr)
    allgr <- rbind(c(1,(1+allreg[gr[1],2]-allreg[gr[1],1])),c(2+allreg[gr[1],2]-allreg[gr[1],1],ncX))
    gr2 <- matrix(c(1,2),nrow=1)
    TESTperm <- c()
    for (i in (1:niter))
    {
    ranseq <- sample(1:ncX)
    permmat <- Xmatgr[,ranseq]
    TESTperm0 <- apply(permmat,1,TESTsteel, mcgroups=gr2,all=allgr)
    TESTperm <- cbind(TESTperm,TESTperm0) 
    }
    TESTpermall <- rbind(TESTpermall,TESTperm)
    }
    proc.time() - pmt
    }
    
    if (teststat =="mcsteelperm")
    {
    TESTobs <- c() 
    for (j in 1:ncomp) 
    {
    gr <- mcgroups[j,,drop=FALSE]
    Xmatgr <- cbind(Xmat[,allreg[gr[1],1]:allreg[gr[1],2]],Xmat[,allreg[gr[2],1]:allreg[gr[2],2]])
    ncX <- ncol(Xmatgr)
    allgr <- rbind(c(1,(1+allreg[gr[1],2]-allreg[gr[1],1])),c(2+allreg[gr[1],2]-allreg[gr[1],1],ncX))
    gr2 <- matrix(c(1,2),nrow=1)
    TESTobs0 <- apply(Xmatgr,1,TESTsteelperm,mcgroups=gr2,all=allgr)
    TESTobs <- c(TESTobs,TESTobs0)
    }
    
    pmt <- proc.time()
    TESTpermall <- c()
    #niter <- 500
    for (j in (1:ncomp))
    {
    gr <- mcgroups[j,,drop=FALSE]
    Xmatgr <- cbind(Xmat[,allreg[gr[1],1]:allreg[gr[1],2]],Xmat[,allreg[gr[2],1]:allreg[gr[2],2]])
    ncX <- ncol(Xmatgr)
    allgr <- rbind(c(1,(1+allreg[gr[1],2]-allreg[gr[1],1])),c(2+allreg[gr[1],2]-allreg[gr[1],1],ncX))
    gr2 <- matrix(c(1,2),nrow=1)
    TESTperm <- c()
    for (i in (1:niter))
    {
    ranseq <- sample(1:ncX)
    permmat <- Xmatgr[,ranseq]
    TESTperm0 <- apply(permmat,1,TESTsteelperm, mcgroups=gr2,all=allgr)
    TESTperm <- cbind(TESTperm,TESTperm0) 
    }
    TESTpermall <- rbind(TESTpermall,TESTperm)
    }
    proc.time() - pmt
    }
    
    
   
    
    
    #chi-square mc type tests # performs separate permutations on each group to keep margins constant
    #compute first expected values which are constant over perms
    if (teststat =="Chi-square")
    {
    TESTobs <- c() 
    expectall <- c()
    includeall <- c()
    for (j in 1:ncomp) 
    {
    gr <- mcgroups[j,]
    expect0 <- t(apply(Xmat,1,expectfun,compgr=gr,all=allreg))
    includecol <- t(apply(expect0,1,includewh,cutp=0))
    Xmatgr <- cbind(Xmat[,allreg[gr[1],1]:allreg[gr[1],2]],Xmat[,allreg[gr[2],1]:allreg[gr[2],2]])
    XE <- cbind(Xmatgr,expect0,includecol)
    ncX <- ncol(Xmatgr)
    nctot1 <- ncol(Xmatgr) + ncol(expect0)
    nctot2 <- ncol(Xmatgr) + ncol(expect0) + ncol(includecol)
    TESTobs0 <- apply(XE,1,TESTchisq,compgr=gr,ncX=ncX,nctot1=nctot1,nctot2=nctot2)
    expectall <- rbind(expectall,expect0)
    includeall <- rbind(includeall,includecol)
    TESTobs <- c(TESTobs,TESTobs0)
    }
    
    pmt <- proc.time()
    TESTpermall <- c()
    #niter <- 500
    for (j in (1:ncomp))
    {
    gr <- mcgroups[j,]
    Xmatgr <- cbind(Xmat[,allreg[gr[1],1]:allreg[gr[1],2]],Xmat[,allreg[gr[2],1]:allreg[gr[2],2]])
    expect0 <- expectall[((j-1)*nr+1):(j*nr),]
    include0 <- includeall[((j-1)*nr+1):(j*nr),]
    ncX <- ncol(Xmatgr)
    nctot1 <- ncol(Xmatgr) + ncol(expect0)
    nctot2 <- ncol(Xmatgr) + ncol(expect0) + ncol(includecol)
    TESTperm <- c()
    for (i in (1:niter))
    {
    ranseq <- sample(1:ncX)
    permmat <- cbind(Xmatgr[,ranseq],expect0,include0)
    TESTperm0 <- apply(permmat,1,TESTchisq, compgr=gr, ncX=ncX,nctot1=nctot1,nctot2=nctot2)
    TESTperm <- cbind(TESTperm,TESTperm0) 
    }
    TESTpermall <- rbind(TESTpermall,TESTperm)
    }
    proc.time() - pmt
    }
    
    TESTpermsort <- matrix(apply(TESTpermall,1,sort),byrow=TRUE,nrow=nrow(TESTpermall))
    TESTpermind <- matrix(apply(TESTpermall,1,order),byrow=TRUE,nrow=nrow(TESTpermall))
    TESTpermobs <- cbind(TESTobs,TESTpermsort)
    
    if (twosided=="yes") {
    pvalue <- apply(TESTpermobs,1,pvalfuntwoyes, nit=niter)
    pvpa <- apply(TESTpermsort,1,pvalpermtwoyes, nit=niter)
    pvpa <- apply(cbind(t(pvpa),TESTpermind),1,function(x){el <- length(x);
    x1 <- x[1:(el/2)];x2 <- x[(el/2+1):el]; f1 <- array(dim=c(el/2));f1[x2]<-x1;return(f1)})
    } else
    {
    pvalue <- apply(TESTpermobs,1,pvalfuntwono, nit=niter)
    pvpa <- apply(TESTpermsort,1,pvalpermtwono, nit=niter)
    pvpa <- apply(cbind(t(pvpa),TESTpermind),1,function(x){el <- length(x);
    x1 <- x[1:(el/2)];x2 <- x[(el/2+1):el]; f1 <- array(dim=c(el/2));f1[x2]<-x1;return(f1)})
    }
    
    
    if (mc == "yes"){
        dataclnew <- c()
        groupfreqnew <- c()
        comparison <- c()
        for (j in 1:ncomp) {
            dataclnew <- rbind(dataclnew,datacl)
            groupfreqnew <- rbind(groupfreqnew,groupfreq)
            comparison <- c(comparison,rep(paste(groupnames[mcgroups[j,1]],"_vs_",groupnames[mcgroups[j,2]],sep=""),nr))
        }
        datawithsig <- cbind(dataclnew,comparison)
     }
    
    if (mc == "no") {datawithsig <- datacl}
    
    pvs <- list(pvals=pvalue,pvperm=t(pvpa),info=datawithsig)
    
    return(pvs)  #pvalue + pvpa
}
