R/heatmap.r

In Biclustering/biclust: BiCluster Algorithms

heatmapBC <- function(x,bicResult,number=0,local=TRUE,order=FALSE,outside = FALSE, ...){
    n <- bicResult@Number
    
    
    if(is.numeric(number)){
        if(length(number)==1){
            
            if(number==0){
                bicRows <- numeric()
                bicCols <- numeric()
                xl <- numeric(n)
                xr <- numeric(n)
                yt <- numeric(n)
                yb <- numeric(n)
                xlo <- numeric(n)
                yto <- numeric(n)
                res <- list()
                
                for(i in 1:n){
                    res <- heatorder(x, bicResult, bicRows, bicCols, order, i, n, i+1)
                    bicRows <- res[[1]]
                    bicCols <- res[[2]]
                    xl[i] <- res[[3]]
                    xr[i] <- res[[4]]
                    yt[i] <- res[[5]]
                    yb[i] <- res[[6]]
                    xlo[i] <- res[[7]]
                    yto[i] <- res[[8]]
                    
                }
                
                bicRows <- c(bicRows, which(!(1:dim(x)[1] %in% bicRows)))
                bicCols <- c(bicCols, which(!(1:dim(x)[2] %in% bicCols)))
                
                
                nr = dim(x[rev(bicRows),bicCols])[1]
                nc = dim(x[rev(bicRows),bicCols])[2]
                
                
                image(1:nc, 1:nr, t(x[rev(bicRows),bicCols]), axes=FALSE,
                      xlab = "", ylab = "", ...)
                
                
                axis(3, 1:nc, labels=colnames(x[rev(bicRows),bicCols]),
                     tick=0, las = 2, line = -0.5, cex.axis =  0.2 + 1/log10(nc))
                
                axis(2, 1:nr, labels=rownames(x[rev(bicRows),bicCols]),
                     tick=0, las = 2, line = -0.5, cex.axis = 0.2 + 1/log10(nr))
                
                rect(xleft = xl[1]+0.5, xright = xr[1] + 0.5, ytop = length(bicRows) - yt[1] + 0.5, ybottom = length(bicRows) - yb[1] + 0.5)
                for(i in 2:n){
                    rect(xleft = xl[i]- xlo[i-1]+0.5, xright = xr[i] + 0.5, ytop = length(bicRows) - yt[i] + yto[i-1] + 0.5, ybottom = length(bicRows) - yb[i] + 0.5)
                }
                
                if(outside){
                    overR <- which(bicResult@RowxNumber[,1])
                    overC <- which(bicResult@NumberxCol[1,])
                    res <- list()
                    for(i in 2:n){
                        res <- printrect(x, bicResult, overR, overC, i, i-1, order, bicRows, bicCols, xl, xlo, yt, yto, xr, yb)
                        overR <- res[[1]]
                        overC <- res[[2]]
                    }
                }
                
                
            }
            else {
                bicRows=which(bicResult@RowxNumber[,number])
                yb <- length(bicRows)
                bicCols=which(bicResult@NumberxCol[number,])
                xr <- length(bicCols)
                
                if(order)
                {
                    bicRows <- bicRows[order(rowSums(x[bicRows,bicCols]))]
                    bicCols <- bicCols[order(colSums(x[bicRows,bicCols]))]
                }
                
                if(!local){
                    bicRows <- c(bicRows, which(!(1:dim(x)[1] %in% bicRows)))
                    bicCols <- c(bicCols, which(!(1:dim(x)[2] %in% bicCols)))
                }
                
                
                nr = dim(x[rev(bicRows),bicCols])[1]
                nc = dim(x[rev(bicRows),bicCols])[2]
                
                
                image(1:nc, 1:nr, t(x[rev(bicRows),bicCols]), axes=FALSE,
                      xlab = "", ylab = "", ...)
                
                
                axis(3, 1:nc, labels=colnames(x[rev(bicRows),bicCols]),
                     tick=0, las = 2, line = -0.5, cex.axis =  0.2 + 1/log10(nc))
                
                axis(2, 1:nr, labels=rownames(x[rev(bicRows),bicCols]),
                     tick=0, las = 2, line = -0.5, cex.axis = 0.2 + 1/log10(nr))
                
                if(!local){
                    rect(xleft = 0.5, xright = xr + 0.5, ytop = length(bicRows)+0.5, ybottom = length(bicRows) - yb + 0.5)
                }
                
            }
            
        }
        if(length(number)>1){
            bicRows <- numeric()
            bicCols <- numeric()
            xl <- numeric(n)
            xr <- numeric(n)
            yt <- numeric(n)
            yb <- numeric(n)
            xlo <- numeric(n)
            yto <- numeric(n)
            res <- list()
            
            for(i in 1:length(number)){
                res <- heatorder(x, bicResult, bicRows, bicCols, order, number[i], number[length(number)], number[min(i+1,length(number))])
                bicRows <- res[[1]]
                bicCols <- res[[2]]
                xl[i] <- res[[3]]
                xr[i] <- res[[4]]
                yt[i] <- res[[5]]
                yb[i] <- res[[6]]
                xlo[i] <- res[[7]]
                yto[i] <- res[[8]]
            }
            
            
            nr = dim(x[rev(bicRows),bicCols])[1]
            nc = dim(x[rev(bicRows),bicCols])[2]
            
            
            image(1:nc, 1:nr, t(x[rev(bicRows),bicCols]), axes=FALSE,
                  xlab = "", ylab = "", ...)
            
            
            axis(3, 1:nc, labels=colnames(x[rev(bicRows),bicCols]),
                 tick=0, las = 2, line = -0.5, cex.axis =  0.2 + 1/log10(nc))
            
            axis(2, 1:nr, labels=rownames(x[rev(bicRows),bicCols]),
                 tick=0, las = 2, line = -0.5, cex.axis = 0.2 + 1/log10(nr))
            
            rect(xleft = xl[1]+0.5, xright = xr[1] + 0.5, ytop = length(bicRows) - yt[1] + 0.5, ybottom = length(bicRows) - yb[1] + 0.5)
            for(i in 2:length(number)){
                rect(xleft = xl[i]- xlo[i-1]+0.5, xright = xr[i] + 0.5, ytop = length(bicRows) - yt[i] + yto[i-1] + 0.5, ybottom = length(bicRows) - yb[i] + 0.5)
            }
            
            
            
            
        }
        
        
    }else{
        
        
        nr = dim(x)[1]
        nc = dim(x)[2]
        
        
        image(1:nc, 1:nr, t(x), axes=FALSE,
              xlab = "", ylab = "", ...)
        
        
        axis(3, 1:nc, labels=colnames(x),
             tick=0, las = 2, line = -0.5, cex.axis =  0.2 + 1/log10(nc))
        
        axis(2, 1:nr, labels=rownames(x),
             tick=0, las = 2, line = -0.5, cex.axis = 0.2 + 1/log10(nr))
    }
    
    
    
    
    
}

printrect <- function(x, bicResult, overR1, overC1, number, before, order, bicRows, bicCols, xl, xlo, yt, yto, xr, yb){
    overR <- which(bicResult@RowxNumber[,number])
    overC <- which(bicResult@NumberxCol[number,])
    
    overR <- overR[(overR %in% overR1)]
    overC <- overC[(overC %in% overC1)]
    R1 <- c(overR[!(overR %in% overR1)],overR1)
    C1 <- c(overC[(overC %in% overC1)], overC1)
    
    if(order){
        # print("order")
        # print(overR)
        if(length(overR)>0){
            for (j in 1:length(overR)){
                a<-which(overR[j] == bicRows)
                rect(xleft = xl[number]- xlo[before]+0.5, xright = xr[number] + 0.5, ytop = length(bicRows) - a  + 0.5, ybottom = length(bicRows) - a - 0.5)
            }
        }
        if(length(overC)>0){
            for (j in 1:length(overC)){
                b <- which(overC[j] == bicCols)
                rect(xleft = b+0.5, xright = b-0.5, ytop = yt[number]  + 0.5, ybottom = length(bicRows) - yb[number] + 0.5)
            }
        }
        
    } else {
        # print("nichtorder")
        if(length(overR)>0){
            overR <- overR[!(overR %in% which(bicResult@RowxNumber[,before]))]
            print(overR)
            for (j in 1:length(overR)){
                a <- which(overR[j] == bicRows)
                rect(xleft = xl[number]- xlo[before]+0.5, xright = xr[number] + 0.5, ytop = length(bicRows) - a  + 0.5, ybottom = length(bicRows) - a - 0.5)
            }
        }
        if(length(overC)>0){
            overC <- overC[!(overC %in% which(bicResult@NumberxCol[before,]))]
            for (j in 1:length(overC)){
                b <-which(overC[j] == bicCols)
                rect(xleft = b+0.5, xright = b-0.5, ytop = yt[number] + yto[before] + 0.5, ybottom = length(bicRows) - yb[number] + 0.5)
            }
        }
    }
    
    list(overR=R1, overC=C1)
}



heatorder <- function(x, bicResult, bicRows1, bicCols1, order, number, end, bicnext){
    xl <- length(bicCols1)
    yt <- length(bicRows1)
    
    bicRows <- which(bicResult@RowxNumber[,number])
    bicCols <- which(bicResult@NumberxCol[number,])
    if(order)
    {
        bicRows <- bicRows[order(rowSums(x[bicRows,bicCols]))]
        bicCols <- bicCols[order(colSums(x[bicRows,bicCols]))]
    }
    
    bicRows <- bicRows[!(bicRows %in% bicRows1)]
    bicCols <- bicCols[!(bicCols %in% bicCols1)]
    
    if(!(number == end) && !order){
        
        bicRows2 <- which(bicResult@RowxNumber[,bicnext])
        bicRows <- c(bicRows[!(bicRows %in% bicRows2)],
                     bicRows[ (bicRows %in% bicRows2)])
        yto <- sum((bicRows %in% bicRows2))
        # print(paste("yto",yto))
        bicCols2 <- which(bicResult@NumberxCol[bicnext,])
        bicCols <- c(bicCols[!(bicCols %in% bicCols2)],
                     bicCols[ (bicCols %in% bicCols2)])
        
        xlo <- sum((bicCols %in% bicCols2))
        # print(paste("xlo",xlo))
    }else {
        yto <- 0
        xlo <- 0
        
    }
    
    list(bicRows=c(bicRows1,bicRows), bicCols=c(bicCols1, bicCols), xl=xl, xr=length(c(bicCols1,bicCols)), yt=yt, yb=length(c(bicRows1,bicRows)), xlo=xlo, yto=yto , bicCols, bicRows)
}