R/HeatMapPlotter.R

In JRC-COMBINE/PhysioSpaceMethods: Creates and uses physio spaces as a dimension reduction mapping

#' @title Drawing Heatmap of CalculatePhysioMap's Output
#'
#' @description Draws a custom heatmap based on the result matrix generated
#' by CalculatePhysioMap() function.
#'
#' @param PhysioResults Matrix of scores generated by CalculatePhysioMap().
#' @param ColorLevels An integer indicating how many colors to use when
#' plotting the heatmap. Default is 100.
#' @param Width Width of the output plot, in inches. Default is 7.
#' @param Height Height of the output plot, in inches. Default is 7.
#' @param main The title of the heatmap. Default is an empty string
#' (no title).
#' @param PlotSize A numerical value with which you can zoom in and out
#' of the heatmap. Default is NA, which makes PhysioHeatmap choose the
#' PlotSize automatically.
#' @param SymmetricColoring Logical value that determines if color coding
#' should distribute symmetrically around 0.
#' Default is false, which means colors will be distributed from minimum
#' to maximum value of PhysioResults.
#' @param RowColCex Row and column cex (a numerical value giving the amount
#' by which plotting text and symbols should be magnified).
#' Default is NA, in which case PhysioHeatmap itself assigns a value to
#' RowColCex based on PhysioResults size.
#' @param KeyLabelCex Colorkey text labels cex (a numerical value giving
#' the amount by which plotting text and symbols should
#' be magnified relative). Default is NA, in which case PhysioHeatmap
#' itself assigns a value to KeyLabelCex based on PhysioResults size.
#' @param SpaceClustering Logical value for choosing if the rows of
#' PhysioResults (Space axes) should be ordered using hierarchical
#' clustering. Default is FALSE.
#' @param Space Space with which PhysioResults is calculated.
#' It is needed if SpaceClustering is TRUE.
#' @param ReducedPlotting Logical or numeric value indicating if only
#' important rows in PhysioResults should be plotted. If ReducedPlotting
#' is FALSE, all rows of PhysioResults are plotted. If ReducedPlotting is
#' TRUE, for each sample (column in PhysioResults) only the 10 most
#' important rows (axes in Space) are selected and plotted. And the case
#' of ReducedPlotting being a numerical value, e.g. N, is similar to
#' ReducedPlotting == TRUE, except rather than 10, the N most important
#' rows are kept.
#'
#' @import grDevices graphics
#'
#' @return PhysioHeatmap returns(Invisibly) a 'TRUE' logical value.
#'
#' @examples
#'randMatInpt <-
#'    matrix(data = rnorm(n = 4000, mean = 10, sd = 20), nrow = 400)
#'rownames(randMatInpt) <- paste("ROWS", 1:400)
#'colnames(randMatInpt) <- paste("Sample", 1:10)
#'
#'randMatRef <-
#'    matrix(data = rnorm(n = 12000, mean = 10, sd = 20), nrow = 400)
#'rownames(randMatRef) <- paste("ROWS", 1:400)
#'colnames(randMatRef) <- paste("Space", 1:30)
#'
#'res <-
#'    calculatePhysioMap(InputData = randMatInpt, Space = randMatRef)
#'
#'PhysioHeatmap(PhysioResults = res,
#'              main = "Heatmap Testing")
#'PhysioHeatmap(
#'    PhysioResults = res,
#'    main = "Heatmap Testing",
#'    ColorLevels = 3
#')
#'PhysioHeatmap(
#'    PhysioResults = res,
#'    main = "Heatmap Testing",
#'    SpaceClustering = TRUE,
#'    Space = randMatRef
#')
#'PhysioHeatmap(
#'    PhysioResults = res,
#'    main = "Heatmap Testing",
#'    ReducedPlotting = 2
#')
#' @export PhysioHeatmap

#
PhysioHeatmap <- function(PhysioResults, ColorLevels = 100,
                            Width = 7, Height = 7, main = "",
                            PlotSize = NA, SymmetricColoring = FALSE,
                            RowColCex = NA, KeyLabelCex = NA,
                            SpaceClustering = FALSE,  Space = NA,
                            ReducedPlotting = FALSE){
    if(!is.matrix(PhysioResults)){
        stop("PhysioResults is expected to be a matrix!")
    }
    if(is.null(colnames(PhysioResults))) colnames(PhysioResults) <-
            as.character(seq_len(ncol(PhysioResults)))
    if(ReducedPlotting){
        if(is.numeric(ReducedPlotting)){
            ReductionLevel <- ceiling(ReducedPlotting/2)
        } else if(is.logical(ReducedPlotting)){
            ReductionLevel <- 5
        } else {
            stop("'ReducedPlotting' is supposed to",
                        "be Logical or a numeric value!")
        }
        if(nrow(PhysioResults) > 2*ReductionLevel){
            SingleReductionsIndices <- apply(PhysioResults,
                                                MARGIN = 2,
                                                function(X)
                                            order(X)[c(seq_len(ReductionLevel),
                                                    seq.int(from = (length(X) -
                                                            ReductionLevel + 1),
                                                            to = length(X)))])
            CombinedReductionIndices <- unique(c(SingleReductionsIndices))
            PhysioResults <- PhysioResults[CombinedReductionIndices,,
                                            drop = FALSE]
            if(!all(is.na(Space))) Space <- Space[,CombinedReductionIndices,
                                                    drop=FALSE]
        }
    }
    if(is.na(PlotSize)) PlotSize <- max(dim(PhysioResults)) + 10
    if(is.na(RowColCex)) RowColCex <- 0.6*min((50/PlotSize),1)
    if(is.na(KeyLabelCex)) KeyLabelCex <- 0.6*min((50/PlotSize),1)

    #Check to see if PhysioResults is too big for PlotSize:
    if(max(dim(PhysioResults)) > PlotSize-9){
        warning("PlotSize is probably too small for PhysioResults,",
                                        "try increasing PlotSize if",
                                        "the output plot is clipped")
    }
    PlotWidth <- (Width/max(Height,Width))*PlotSize
    #Check to see if it's gonna clip thru the heatmap(less likely):
    if(PlotWidth < ncol(PhysioResults)){
        warning("'Width' is too small, heatmap may not be plotted completely")
    }
    PlotHeight <- (Height/max(Height,Width))*PlotSize
    #Check to see if it's gonna clip thru the heatmap(more likely):
    if(PlotHeight < nrow(PhysioResults)){
        warning("'Height' is too small, heatmap may not be plotted completely")
    }

    if(SymmetricColoring){ #Want to have symmetric coloring around zero, or
        #from zero if all values are postive (or all
        #are negative)
        if(all(PhysioResults>=0)) {
            Mn <- 0
            Mx <- max(PhysioResults)
        } else if(all(PhysioResults<=0)){
            Mn <- min(PhysioResults)
            Mx <- 0
        } else {
            Mn <- min(min(PhysioResults),-max(PhysioResults))
            Mx <- max(-min(PhysioResults),max(PhysioResults))
        }
    } else {
        Mn <- min(PhysioResults)
        Mx <- max(PhysioResults)
    }
    PhysioResultsMorghed <- ceiling(ColorLevels*
                                        (PhysioResults-(Mn-0.00000001)) /
                                        (Mx-Mn))
    # -0.00000001 so values start at 1 not 0, so indexing of COLORInterpolated
    #won't break.
    # Also wanted to have integers from 1 (or more in case all
    #(PhysioResults>=0)) to ColorLevels.

    if(SpaceClustering & nrow(PhysioResultsMorghed)>1){
        if(all(is.na(Space))){
            warning("For SpaceClustering==TRUE,",
                    "'Space' is needed and should be provided!",
                    "'SpaceClustering' is switched to FALSE.")
        } else if(any(is.infinite(Space))){
            warning("For SpaceClustering==TRUE,",
                    "'Space' should be bounded.",
                    "'SpaceClustering' is switched to FALSE.")
        } else {
            PhysioResultsMorghed <-
                PhysioResultsMorghed[hclust(d = as.dist(1 - cor(Space,
                                        use = "pairwise.complete.obs")))$order,,
                                        drop=FALSE]
        }
    }

    COLORInterpolated <-
        colorRampPalette(colors = c(
            rgb(red = 0, green = 0, blue = 1),
            rgb(red = 1, green = 1, blue = 0.8),
            rgb(red = 1, green = 0, blue = 0)
        ))(n = ColorLevels + 1)

    plot.new()
    plot.window(xlim = c(0,PlotWidth), ylim = c(0,PlotHeight))
    #Number here limits the maximum number of boxes that can be drawn
    #in each direction

    Xoffset <- (PlotWidth/2) - ncol(PhysioResults)/2
    #ifelse(test = SpaceClustering, no = (PlotWidth/2) -
    #ncol(PhysioResults)/2, yes = (3*PlotWidth/4) - ncol(PhysioResults)/2)

    Yoffset <- (PlotHeight/2) - (nrow(PhysioResults)/2) +
        max(nchar(colnames(PhysioResults)))/20
    ColLabelYoffset <- Yoffset
    ColLabelXoffset <- Xoffset + (seq_len(ncol(PhysioResultsMorghed))) + 0.5
    RowLabelXoffset <- Xoffset

    text(labels = colnames(PhysioResultsMorghed),
            y = ColLabelYoffset, x = ColLabelXoffset,
            cex = RowColCex, srt=90, font = 2, adj = 1)
    text(labels = rownames(PhysioResultsMorghed),
            y = Yoffset+0.5+(seq_len(nrow(PhysioResultsMorghed))),
            x = RowLabelXoffset, cex = RowColCex, font = 2, adj = 1)
    title(main = main)

    for(ROW in seq_len(nrow(PhysioResultsMorghed))){
        for(COL in seq_len(ncol(PhysioResultsMorghed))){
            rect(xleft = Xoffset+COL,xright = Xoffset+COL+1,
                    ybottom = Yoffset+ROW,ytop = Yoffset+ROW+1,
                    col = COLORInterpolated[PhysioResultsMorghed[ROW,COL]],
                    lty = 1, border= "grey")
        }
    }

    #Making the color key:
    rect(xleft = seq(Xoffset+ncol(PhysioResults),
                        Xoffset+ncol(PhysioResults)+1.8,length.out = 10),
            xright = seq(Xoffset+ncol(PhysioResults)+0.2,
                        Xoffset+ncol(PhysioResults)+2,length.out = 10),
            ybottom = rep(Yoffset+nrow(PhysioResults)+2,10),
            ytop = rep(Yoffset+nrow(PhysioResults)+3,10),
            col = colorRampPalette(colors = c(
                rgb(red = 0, green = 0, blue = 1),
                rgb(red = 1, green = 1, blue = 0.8),
                rgb(red = 1, green = 0, blue = 0)
            ))(n = 10),
            border = NA)
    text(x = Xoffset+ncol(PhysioResults), y = Yoffset+nrow(PhysioResults)+3,
            labels = round(Mn), adj = 0, cex = KeyLabelCex, srt=90)
    text(x = Xoffset+ncol(PhysioResults)+2, y = Yoffset+nrow(PhysioResults)+3,
            labels = round(Mx), adj = 0, cex = KeyLabelCex, srt=90)
    #

    Success <- TRUE
    invisible(Success)
}