###########################################################
      #                      Arrow plot                         #
      ###########################################################

 
     
###########          Algorithm 1: non-parametric OVL estimation     ##################

# this function will return the minimum ordinate, y, if there exists
# more than one equal abscissa on the same list 
# e.g. (3,5) and (3,7) return 5

m_y<-function(x,L){
             z<-which(L[,1]==x)
             return(min(L[z,2]))
                   }


# this function will return the point before an abscissa x on the same list

 xant<-function(x,L){
 z<-which(L[,1]<x)
 r<-max(L[z,1])
 y<-m_y(r,L) 
 a<-ifelse(is.null(r)|r=="-Inf",NA,r)
 y1<-ifelse(y=="Inf",NA,y)
 return(c(a,y1))
}

#this function will return the point after an abscissa x on the same list

xseg<-
function(x,L){
z<-which(L[,1]>x)
if(length(z)==0){
r<-NA
y<-NA
}
else
{r<-min(L[z,1])
y<-m_y(r,L)}
return(c(r,y))
}



# this function will return the points with the same abscissa on the same list

xigu<-
function(x,L){
 z<-which(L[,1]==x)
 y<-m_y(x,L)
 y1<-ifelse(y=="Inf",NA,y)
 return(c(x,y1))

}



#this function select the points who should be included on the final list
#this function should be run for both estimated densities 
## first (L1,L2) and then (L2,L1)

pontos<- function(L1,L2) {
 x<-L1[,1]
 y<-L1[,2]
 L2igu<-sapply(x,function(x)xigu(x,L2))
 t<-L1[which(L2igu[2,]!="NA" & L2igu[2,]>=y),]
 L2ant<-sapply(x,function(x)xant(x,L2))
 L2seg<-sapply(x,function(x)xseg(x,L2)) 
 k<-L1[which(is.na(L2igu[2,]) & L2ant[2,]!="NA" & L2seg[2,]!="NA"
        & y<=L2ant[2,] & y<=L2seg[2,]),]
return(rbind(t,k))
}



# This function gathers and sorts the above selected points  


junta_pontos <- function(L1,L2) {
L3<-rbind(L1,L2)
return(L3[order(L3[,1]),])
}



# this function will estimate the jump points and returns 
# the final list
# L1 have to correspond to the labeled 1 group
# L2 have to correspond to the labeled 2 group


final<-function(L,L1,L2){
i<-1
p<-data.frame()
while (i <= nrow(L)-1 ){

if (L[i,3]!=L[(i+1),3]) {

    x1<-L[i,1]
    y1<-L[i,2]
    x4<-L[(i+1),1]
    y4<-L[(i+1),2]

if (L[i,3]==1) {x2<-xseg(L[i,1],L1)[1]} else
    x2<-xseg(L[i,1],L2)[1]

 if  (L[i,3]==1) {y2<-xseg(L[i,1],L1)[2]} else
     y2<-xseg(L[i,1],L2)[2]
 
if (L[(i+1),3]==1) {x3<-xant(L[(i+1),1],L1)[1]} else
     x3<-xant(L[(i+1),1],L2)[1]

if (L[(i+1),3]==1){y3<-xant(L[(i+1),1],L1)[2]} else
     y3<-xant(L[(i+1),1],L2)[2]

D<-(x1-x2)*(y3-y4)-(y1-y2)*(x3-x4)

  if (D!=0){
     x_int<-(1/D)*((x3-x4)*(x1*y2-y1*x2)-(x1-x2)*(x3*y4-y3*x4))
     y_int<-(1/D)*((y3-y4)*(x1*y2-y1*x2)-(y1-y2)*(x3*y4-y3*x4))
     r<-c(x_int,y_int)         
            }
   
	p<-rbind(p,c(L[i,1],L[i,2]))
      p<-rbind(p,c(x_int,y_int))

       } else

     p<-rbind(p,c(L[i,1],L[i,2]))

i<-i+1

   }

  total<-rbind(p,c(L[nrow(L),1],L[nrow(L),2]))

return(total)

}


# OVL estimation using the trapezoidal rule

library(bitops)
library(caTools)


#OVL<-trapz(,)



########################################

# get the kernel densities estimates from your samples  
# you have to use labels 1 and 2
# to identify your sample groups, control=1 and experimental=2 (or vice-versa)

for (i in 1:n){    #n number of genes

    k1<-density(control[i,],n=100)   
    G1<-data.frame(x=c(k1$x),y=c(k1$y),lista=rep(1,length(k1$x))) 
    k2<-density(experimental[i,],n=100) 
    G2<-data.frame(x=c(k2$x),y=c(k2$y),lista=rep(2,length(k2$x))) 		  
    G12<-pontos(G1,G2)
    G21<-pontos(G2,G1)
      G<-junta_pontos(G12,G21)
 G_final<-final(G,G1,G2)
  OVL[i]<-round(trapz(G_final[,1],G_final[,2]),3) 
               }

#######################################

###########          Algorithm 2: bimodality or multimodality classification     ##################
##########                     of the estimated kernel densities 


    bimodality<-function(L1,L2){

    L1ord<-L1[order(L1$x),]
    L2ord<-L2[order(L2$x),]
    
    x1<-L1ord[,1]
    x2<-L2ord[,1]

    L1ord.seg<-sapply(x1,function(x1)xseg(x1,L1ord))
    L1ord.igu<-sapply(x1,function(x1)xigu(x1,L1ord))

    z1<-ifelse(L1ord.igu[2,]<=L1ord.seg[2,],1,0)
    z1<-na.omit(z1)
    r1<-diff(which(z1!=1))
        
    bim1<-ifelse(length(subset(r1,r1>1))!=0,TRUE,FALSE)
    L2ord.seg<-sapply(x2,function(x2)xseg(x2,L2ord))
    L2ord.igu<-sapply(x2,function(x2)xigu(x2,L2ord))

    z2<-ifelse(L2ord.igu[2,]<=L2ord.seg[2,],1,0)
    z2<-na.omit(z2)
    r2<-diff(which(z2!=1))
    
    
    bim2<-ifelse(length(subset(r2,r2>1))!=0,TRUE,FALSE)
      
    
    group1<-ifelse(bim1==TRUE,1,0)
    group2<-ifelse(bim2==TRUE,1,0)
    both<-ifelse(bim1==TRUE & bim2==TRUE, 1,0)

    return(c(group1,group2,both))
    }


#######################

BIM<-NULL    
  for (i in 1:z)   {       # z number of candidates to special genes 
                           # in this case genes which have 0.4<AUC<0.6 and OVL<0.4
       BIM<-rbind(BIM,bimodality(G1,G2))   
                   } 

#######################



################   Algorithm 2: Arrow plot    #########################


# empirical AUC estimation

library(ROC)

# you will need the "data" object, which is were your data is stored
# and a numeric vector "rec.info" with 0's and 1's,
# where 0 is the label  of the control group and 1 is the label  of the experimental
# group,  with many 0's and 1's as the sample dimension in each group
# consults the manual of the ROC  package from Bioconductor


for (i in 1:n){

AUC[i]<-AUC(rocdemo.sca(rec.info,data[i,],dxrule.sca, caseLabel="",
markerLabel=""))

              }

###############  arrow plot 


plot(OVL,AUC,ylab="AUC",xlab="OVL", main="Arrow plot")


# coloring Arrow plot

abline(h=0.1)   #arbitrary cut-off point, AUC 
abline(h=0.9)   #arbitrary cut-off point, AUC
abline(v=0.4)   #arbitrary cut-off point, OVL
abline(h=0.6)   #arbitrary cut-off point, AUC
abline(h=0.4)   #arbitrary cut-off point, AUC

OVL.AUC<-data.frame(AUC,OVL)
rownames(OVL.AUC)<-rownames(data)


OVL.AUC2<-OVL.AUC[AUC>0.9 & OVL<0.4,]   # up-regulated genes, arbitrary cut-off points
OVL.AUC3<-OVL.AUC[AUC<0.1 & OVL<0.4,]   # down-regulated genes, arbitrary cut-off points


points(OVL.AUC2$OVL,OVL.AUC2$AUC,col="red",pch=19) # up-regulated genes
points(OVL.AUC3$OVL,OVL.AUC3$AUC,col="blue",pch=19) # down-regulated genes
points(OVL.AUC$OVL[v1],OVL.AUC$AUC[v1],col="green",pch=19)#special genes with bimodal or multimodal
                                                          #densities in both groups,  v1 is a vector
                                                          #where genes with this behavior is stored
                                                          #you will get those information in BIM 
points(OVL.AUC$OVL[v2],OVL.AUC$AUC[v2],col="cyan",pch=19) #special genes with bimodal or multimodal
                                                          #densities in experimental group,  v2 is a vector
                                                          #where genes with this behavior is stored
                                                          #you will get those information in BIM
points(OVL.AUC$OVL[v3],OVL.AUC$AUC[v3],col="orange",pch=19)#special genes with bimodal or multimodal
                                                          #densities in control group,  v3 is a vector
                                                          #where genes with this behavior is stored
                                                          #you will get those information in BIM