mixOmics2: Omics Data Integration Project

################################################################################
# Author:
#   Francois Bartolo,
#   Florian Rohart,
#
# created: 29-08-2016
# last modified: 30-08-2016
#
# Copyright (C) 2016
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
################################################################################

# -----------------------------------------------------------------------------
# Internal helpers functions to run "plot.perf" functions
# -----------------------------------------------------------------------------


.graphicPerf<- function (error.rate, error.rate.sd, overlay, type,
measure, dist, legend.position, xlab, ylab, color, ...)
{
    # error.rate is a list [[measure]]
    # error.rate[[measure]] is a matrix of dist columns and ncomp rows
    # color is a vector of length dist
    
    # concatenation of the error in a single matrix
    error.rate.concat = matrix(nrow = nrow(error.rate[[1]]), ncol = 0)
    for(mea in measure)
    {
        temp = error.rate[[mea]][, dist, drop = FALSE]
        colnames(temp) = paste(mea, colnames(temp),sep="_")
        error.rate.concat = cbind(error.rate.concat, temp)
    }
    
    if(!is.null(error.rate.sd))
    {
        error.rate.sd.concat = matrix(nrow = nrow(error.rate.sd[[1]]), ncol = 0)
        for(mea in measure)
        {
            temp = error.rate.sd[[mea]][, dist, drop = FALSE]
            colnames(temp) = paste(mea, colnames(temp),sep="_")
            error.rate.sd.concat = cbind(error.rate.sd.concat, temp)
        }
        ylim = range(c(error.rate.concat + error.rate.sd.concat),
        c(error.rate.concat - error.rate.sd.concat))
        
    } else {
        error.rate.sd.concat = NULL
        ylim = range(error.rate.concat)
        
    }
    
    #extract component numbers from rownames(error.rate.concat)
    
    rownames(error.rate.concat) = sapply(strsplit(rownames(error.rate.concat),
    " "), function(x){x[2]})
    component = as.numeric(rownames(error.rate.concat))
    
    if(overlay == "all")
    {
        out<-matplot(component, error.rate.concat, type = type, lty =
        rep(c(1:length(measure)), each = length(dist)),
        col = rep(color, length(measure)),
        lwd = 2, xlab = xlab, ylab = ylab, xaxt="n", ylim = ylim)
        
        axis(1, rownames(error.rate.concat))#, rownames(error.rate.concat))
        
        if(legend.position == "vertical")
        {
            legend('topright', legend = c(measure, dist),
            lty = c(1:length(measure), rep(NA, length(dist))),
            pch = c(rep(NA, length(measure)), rep(16, length(dist))),
            col = c(rep('black', length(measure)), color), ncol = 1, lwd = 2)
        } else if(legend.position == "horizontal") {
            legend('topright', legend = c(measure, "" , dist),
            lty = c(1:length(measure), rep(NA, (length(dist)+1))),
            pch = c(rep(NA, (length(measure)+1)), rep(16, length(dist))),
            col = c(rep('black', length(measure)), NA, color), ncol = 2,
            lwd = 2)
            
        }
        if(!is.null(error.rate.sd.concat))
        {
            col = matrix(rep(color, length(measure)),
            nrow = nrow(error.rate.concat), ncol = length(measure)*length(dist),
            byrow=TRUE)
            
            for(j in 1:ncol(error.rate.concat))
            plot_error_bar(x = component, y = error.rate.concat[, j],
            uiw=error.rate.sd.concat[, j], add=TRUE, col = col[, j])
        }
    } else if(overlay == "measure") {
        
        # overlaying all measure on one graph, a graph per distance
        par(mfrow=c(1, length(dist)))
        for(di in dist)
        {
            new_mat.error =
            error.rate.concat[, grep(di, colnames(error.rate.concat)),
            drop = FALSE]
            
            out<-matplot(new_mat.error, type = type, lty = c(1:length(measure)),
            col = rep(color[which(di == dist)]),
            lwd = 2, xlab = xlab, ylab = ylab, xaxt="n", ylim = ylim)
            
            axis(1, rownames(error.rate.concat))#, rownames(error.rate.concat))
            #axis(2)
            
            if(legend.position == "vertical")
            {
                legend('topright', legend = measure, lty = 1:length(measure),
                col = rep(color[which(di == dist)]), ncol = 1, lwd = 2)
            } else if(legend.position == "horizontal") {
                legend('topright', legend = c(measure), lty = 1:length(measure),
                col = rep(color[which(di == dist)]), ncol = 2, lwd = 2)
            }
            if(!is.null(error.rate.sd.concat))
            {
                new_sd.error = error.rate.sd.concat[, grep(di,
                colnames(error.rate.sd.concat)), drop = FALSE]
                for(j in 1:ncol(new_mat.error))
                plot_error_bar(x = component, y = new_mat.error[, j],
                uiw=new_sd.error[, j], add=TRUE, col = color[which(di == dist)])
            }
            #add title for each subgraph
            title(di, line = 1)
        }
        
    } else if(overlay == "dist") {
        
        # overlaying all distance on one graph, a graph per measure
        
        par(mfrow=c(1, length(measure)))
        for(mea in measure)
        {
            new_mat.error=error.rate.concat[, grep(mea,
            colnames(error.rate.concat)), drop = FALSE]
            
            out<-matplot(new_mat.error, type = type, lty = c(1:length(dist)),
            col = color,
            lwd = 2, xlab = xlab, ylab = ylab, xaxt="n", ylim = ylim)
            
            axis(1, rownames(error.rate.concat))#, rownames(error.rate.concat))
            #axis(2)
            
            if(legend.position == "vertical")
            {
                legend('topright', legend = dist, lty = 1:length(dist),
                col = color, ncol = 1, lwd = 2)
            } else if(legend.position == "horizontal") {
                legend('topright', dist, lty = 1:length(dist),
                col = color, ncol = 2, lwd = 2)
            }
            if(!is.null(error.rate.sd.concat))
            {
                col = matrix(color, nrow = nrow(error.rate.concat),
                ncol = length(dist), byrow=TRUE)

                new_sd.error=error.rate.sd.concat[,
                grep(mea, colnames(error.rate.sd.concat)), drop = FALSE]
                for(j in 1:ncol(new_mat.error))
                plot_error_bar(x = component, y = new_mat.error[, j],
                uiw=new_sd.error[, j], add=TRUE, col = col[, j])
            }
            title(mea, line = 1)
        }
        
    }
    
}


plot_error_bar <- function (x, y = as.numeric(x), uiw, add=FALSE, col = "black")
{
    # x are the xaxis values
    # y are the y axis values
    arglist <- list()#...)
    liw = uiw
    #y <- as.numeric(x)
    #x <- seq(along = x)
    z <- y
    ui <- z + uiw
    li <- z - liw
    arglist$xlab <- deparse(substitute(x))
    arglist$ylab <- deparse(substitute(y))
    arglist$ylim <- range(c(y, ui, li), na.rm = TRUE)
    arglist$xlim <- range(c(x, ui, li), na.rm = TRUE)
    plotpoints <- TRUE
    ul <- c(li, ui)
    pin <- par("pin")
    usr <- par("usr")
    x.to.in <- pin[1]/diff(usr[1:2])
    y.to.in <- pin[2]/diff(usr[3:4])
    gap <- rep(0, length(x)) * diff(par("usr")[3:4])
    smidge <- par("fin")[1] * 0.01
    nz <- abs(li - pmax(y - gap, li)) * y.to.in > 0.001
    scols <- col
    
    arrow.args <- c(list(lty = par("lty"), angle = 90, length = smidge,
    code = 1, col = scols))
    
    do.call("arrows", c(list(x[nz], li[nz], x[nz], pmax(y -
    gap, li)[nz]), arrow.args))
    
    nz <- abs(ui - pmin(y + gap, ui)) * y.to.in > 0.001
    #scols <- rep(scol, length.out = length(x))[nz]
    arrow.args$col <- scols
    
    do.call("arrows", c(list(x[nz], ui[nz], x[nz], pmin(y +
    gap, ui)[nz]), arrow.args))
    
    do.call("points", c(list(x, y, bg = par("bg"), col =col)))
    
    invisible(list(x = x, y = y))
}