R/plotheatmap.R

In psSubpathway: Flexible Identification of Phenotype-Specific Subpathways

##' plotheatmap
##'
##'
##' @title Plot a heatmap
##' @description Plot a heatmap of subpathway activity profile based on the parameters set by the user.
##' @param inputdata A list of result data generated by function `SubSEA` or `DCSA`.
##' @param plotSubSEA Determine the inputdata is the result data of function `SubSEA` (default:plotSubSEA=TRUE) or
##'  `DCSA` (plotSubSEA=FLASE).
##' @param fdr.th Cutoff value for FDR. The only subpathway with lower FDR is plotted. (default: 1).
##' @param SES Parameter `SES` is useful only when `plotSubSEA` is TRUE. When `plotSubSEA=TRUE`,if `SES` is positive,
##' the subpathway with high-expression will be plotted. when it is negative, plot low-expression subpathways.
##' @param phenotype Parameter `phenotype` is useful only when `plotSubSEA` is TRUE. `phenotype` decides which phenotypic
##' significant subpathways to screen (which phenotypic result is applied to parameter `fdr.th` and `SES`.) and plot a
##' heat map of these subpathways.By default,`phenotype="all"` which will screen the subpathways of all phenotypes and plot
##' a heat map. When the user wants to plot a subpathway heat map of the specified phenotype, this parameter should be set
##' to the name of the phenotype.
##' @details
##' The subpathways are screened according to the conditions set by the user and a heat map of the activity of these subpathways is drawn.
##' @return a heatmap
##' @author Xudong Han,
##' Junwei Han,
##' Qingfei Kong
##' @examples
##' # load depend package.
##' library(pheatmap)
##' # get the Subspwresult which is the result of SubSEA function.
##' Subspwresult<-get("Subspwresult")
##' # get the DCspwresult which is the result of DCSA function.
##' DCspwresult<-get("DCspwresult")
##' # plot significant up-regulation subpathway heat map specific for each breast cancer subtype.
##' plotheatmap(Subspwresult,plotSubSEA=TRUE,fdr.th=0.01,SES="positive",phenotype="all")
##' # plot significant down-regulation subpathway heat map specific for each breast cancer subtype.
##' plotheatmap(Subspwresult,plotSubSEA=TRUE,fdr.th=0.01,SES="negative",phenotype="all")
##' # plot basal subtype specific significant subpathway heat map.
##' plotheatmap(Subspwresult,plotSubSEA=TRUE,fdr.th=0.01,SES="all",phenotype="Basal")
##' # plot adrenocortical cancer disease stages specific significant subpathway heat map.
##' plotheatmap(DCspwresult,plotSubSEA=FALSE,fdr.th=0.01)
##' @importFrom pheatmap pheatmap
##' @importFrom grDevices cm.colors
##' @importFrom grDevices colorRampPalette
##' @export
plotheatmap<-function(inputdata,plotSubSEA=TRUE,fdr.th=1,SES="positive",phenotype="all"){
  if(plotSubSEA==TRUE){
    spwmatrix<-inputdata$spwmatrix
    phen<-names(table(colnames(spwmatrix)))
    pn<-length(phen)
    spwid<-row.names(spwmatrix)

    spwmatrix<-spwmatrix[,order(colnames(spwmatrix))]

    if(SES=="positive"){

      xzzspwnames<-lapply(1:pn, function(x){
        pp<-which(inputdata[[x]][,6]<=fdr.th&inputdata[[x]][,4]>0)
        spwname<-row.names(inputdata[[x]])[pp]
        return(spwname)
      })
      xzzspwnames1<-unlist(xzzspwnames)
      cfindex<-which(duplicated(xzzspwnames1)==TRUE)
      cfspwid<-xzzspwnames1[cfindex]
      cfspwid<-unique(cfspwid)

      if(phenotype=="all"){

        spspw<-NULL
        spcd<-NULL
        for(i in 1:pn){
          spcd<-c(spcd,length(setdiff(xzzspwnames[[i]],cfspwid)))
          spspw<-c(spspw,setdiff(xzzspwnames[[i]],cfspwid))
        }
        rtspw<-c(spspw,cfspwid)



        ppindex<-match(rtspw,spwid)
        rtmatrix<-spwmatrix[ppindex,]

        spwphen<-paste(phen,"-specific",sep = "")
        if(length(cfspwid)==0){
          rtspwcd<-spcd
          rowann = data.frame(
            Subpathway = factor(rep(c(spwphen),rtspwcd))
          )
        }else{
          rtspwcd<-c(spcd,length(cfspwid))
          rowann = data.frame(
            Subpathway = factor(rep(c(spwphen,"MultiplePhenotypic-specific"),rtspwcd))
          )
        }
        rownames(rowann) <-row.names(rtmatrix)
        colann=data.frame(Sample=factor(rep(names(table(colnames(rtmatrix))),
                                                 table(colnames(rtmatrix)))))

        samples<-paste(colnames(rtmatrix),1:length(rtmatrix[1,]))
        row.names(colann)<-samples
        colnames(rtmatrix)<-samples
        pheatmap(rtmatrix,color = colorRampPalette(c("navy", "white", "firebrick3"))(50),
                 cluster_rows=F,cluster_cols=F,
                 annotation_row =rowann,annotation_col =colann,
                 show_rownames=T,show_colnames=F,
                 main="Phenotype specific up-regulation subpathway heat map")

      }else{

        pz<-which(phen==phenotype)
        pp<-which(inputdata[[pz]][,6]<=fdr.th&inputdata[[pz]][,4]>0)
        spwname<-row.names(inputdata[[pz]])[pp]


        ppindex<-match(spwname,spwid)
        rtmatrix<-spwmatrix[ppindex,]

        rowann = data.frame(Subpathway = factor(rep(paste(phenotype,"-specific",sep = ""),length(rtmatrix[,1]))))
        rownames(rowann) <-row.names(rtmatrix)
        colann=data.frame(Sample=factor(rep(names(table(colnames(rtmatrix))),
                                                 table(colnames(rtmatrix)))))
        samples<-paste(colnames(rtmatrix),1:length(rtmatrix[1,]))
        row.names(colann)<-samples
        colnames(rtmatrix)<-samples
        pheatmap(rtmatrix,color = colorRampPalette(c("navy", "white", "firebrick3"))(50),
                 cluster_rows=F,cluster_cols=F,
                 annotation_row =rowann,annotation_col =colann,
                 show_rownames=T,show_colnames=F,
                 main=paste(phenotype,"specific up-regulation subpathway heat map"))


      }

    }

    if(SES=="negative"){

      xzzspwnames<-lapply(1:pn, function(x){
        pp<-which(inputdata[[x]][,6]<=fdr.th&inputdata[[x]][,4]<0)
        spwname<-row.names(inputdata[[x]])[pp]
        return(spwname)
      })
      xzzspwnames1<-unlist(xzzspwnames)
      cfindex<-which(duplicated(xzzspwnames1)==TRUE)
      cfspwid<-xzzspwnames1[cfindex]
      cfspwid<-unique(cfspwid)

      if(phenotype=="all"){

        spspw<-NULL
        spcd<-NULL
        for(i in 1:pn){
          spcd<-c(spcd,length(setdiff(xzzspwnames[[i]],cfspwid)))
          spspw<-c(spspw,setdiff(xzzspwnames[[i]],cfspwid))
        }
        rtspw<-c(spspw,cfspwid)



        ppindex<-match(rtspw,spwid)
        rtmatrix<-spwmatrix[ppindex,]

        spwphen<-paste(phen,"-specific",sep = "")
        if(length(cfspwid)==0){
          rtspwcd<-spcd
          rowann = data.frame(
            Subpathway = factor(rep(c(spwphen),rtspwcd))
          )
        }else{
          rtspwcd<-c(spcd,length(cfspwid))
          rowann = data.frame(
            Subpathway = factor(rep(c(spwphen,"MultiplePhenotypic-specific"),rtspwcd))
          )
        }
        rownames(rowann) <-row.names(rtmatrix)
        colann=data.frame(Sample=factor(rep(names(table(colnames(rtmatrix))),
                                                 table(colnames(rtmatrix)))))

        samples<-paste(colnames(rtmatrix),1:length(rtmatrix[1,]))
        row.names(colann)<-samples
        colnames(rtmatrix)<-samples
        pheatmap(rtmatrix,color = colorRampPalette(c("navy", "white", "firebrick3"))(50),
                 cluster_rows=F,cluster_cols=F,
                 annotation_row =rowann,annotation_col =colann,
                 show_rownames=T,show_colnames=F,
                 main="Phenotype specific down-regulation subpathway heat map")

      }else{

        pz<-which(phen==phenotype)
        pp<-which(inputdata[[pz]][,6]<=fdr.th&inputdata[[pz]][,4]<0)
        spwname<-row.names(inputdata[[pz]])[pp]


        ppindex<-match(spwname,spwid)
        rtmatrix<-spwmatrix[ppindex,]

        rowann = data.frame(Subpathway = factor(rep(paste(phenotype,"-specific",sep = ""),length(rtmatrix[,1]))))
        rownames(rowann) <-row.names(rtmatrix)
        colann=data.frame(Sample=factor(rep(names(table(colnames(rtmatrix))),
                                                 table(colnames(rtmatrix)))))
        samples<-paste(colnames(rtmatrix),1:length(rtmatrix[1,]))
        row.names(colann)<-samples
        colnames(rtmatrix)<-samples
        pheatmap(rtmatrix,color = colorRampPalette(c("navy", "white", "firebrick3"))(50),
                 cluster_rows=F,cluster_cols=F,
                 annotation_row =rowann,annotation_col =colann,
                 show_rownames=T,show_colnames=F,
                 main=paste(phenotype,"specific down-regulation subpathway heat map"))


      }

    }

    if(SES=="all"){
      xzzspwnames<-lapply(1:pn, function(x){
        pp<-which(inputdata[[x]][,6]<=fdr.th)
        spwname<-row.names(inputdata[[x]])[pp]
        return(spwname)
      })
      xzzspwnames1<-unlist(xzzspwnames)
      cfindex<-which(duplicated(xzzspwnames1)==TRUE)
      cfspwid<-xzzspwnames1[cfindex]
      cfspwid<-unique(cfspwid)

      if(phenotype=="all"){

        spspw<-NULL
        spcd<-NULL
        for(i in 1:pn){
          spcd<-c(spcd,length(setdiff(xzzspwnames[[i]],cfspwid)))
          spspw<-c(spspw,setdiff(xzzspwnames[[i]],cfspwid))
        }
        rtspw<-c(spspw,cfspwid)



        ppindex<-match(rtspw,spwid)
        rtmatrix<-spwmatrix[ppindex,]

        spwphen<-paste(phen,"-specific",sep = "")
        if(length(cfspwid)==0){
          rtspwcd<-spcd
          rowann = data.frame(
            Subpathway = factor(rep(c(spwphen),rtspwcd))
          )
        }else{
          rtspwcd<-c(spcd,length(cfspwid))
          rowann = data.frame(
            Subpathway = factor(rep(c(spwphen,"MultiplePhenotypic-specific"),rtspwcd))
          )
        }
        rownames(rowann) <-row.names(rtmatrix)
        colann=data.frame(Sample=factor(rep(names(table(colnames(rtmatrix))),
                                                 table(colnames(rtmatrix)))))

        samples<-paste(colnames(rtmatrix),1:length(rtmatrix[1,]))
        row.names(colann)<-samples
        colnames(rtmatrix)<-samples
        pheatmap(rtmatrix,color = colorRampPalette(c("navy", "white", "firebrick3"))(50),
                 cluster_rows=F,cluster_cols=F,
                 annotation_row =rowann,annotation_col =colann,
                 show_rownames=T,show_colnames=F,
                 main="All phenotype specific subpathway heat map")

      }else{

        pz<-which(phen==phenotype)
        pp<-c(which(inputdata[[pz]][,6]<=fdr.th&inputdata[[pz]][,4]<0),which(inputdata[[pz]][,6]<=fdr.th&inputdata[[pz]][,4]>0))
        spwname<-row.names(inputdata[[pz]])[pp]

        ppindex<-match(spwname,spwid)
        rtmatrix<-spwmatrix[ppindex,]

        rowann = data.frame(Subpathway = factor(rep(paste(phenotype,"-specific",sep = ""),length(rtmatrix[,1]))))
        rownames(rowann) <-row.names(rtmatrix)
        colann=data.frame(Sample=factor(rep(names(table(colnames(rtmatrix))),
                                                 table(colnames(rtmatrix)))))
        samples<-paste(colnames(rtmatrix),1:length(rtmatrix[1,]))
        row.names(colann)<-samples
        colnames(rtmatrix)<-samples
        pheatmap(rtmatrix,color = colorRampPalette(c("navy", "white", "firebrick3"))(50),
                 cluster_rows=F,cluster_cols=F,
                 annotation_row =rowann,annotation_col =colann,
                 show_rownames=T,show_colnames=F,
                 main=paste("All",phenotype,"specific subpathway heat map"))


      }
    }

  }else{
    spwmatrix<-inputdata$spwmatrix
    phen<-names(table(colnames(spwmatrix)))
    spwmatrix<-spwmatrix[,order(colnames(spwmatrix))]

    pp<-which(inputdata[[1]][,6]<=fdr.th)
    spwname<-row.names(inputdata[[1]])[pp]
    ppindex<-match(spwname,row.names(spwmatrix))
    rtmatrix<-spwmatrix[ppindex,]

    colann=data.frame(Sample=factor(rep(names(table(colnames(rtmatrix))),
                                             table(colnames(rtmatrix)))))
    samples<-paste(colnames(rtmatrix),1:length(rtmatrix[1,]))
    row.names(colann)<-samples
    colnames(rtmatrix)<-samples
    pheatmap(rtmatrix,color = colorRampPalette(c("navy", "white", "firebrick3"))(50),
             cluster_rows=F,cluster_cols=F,
             annotation_col =colann,
             show_rownames=T,show_colnames=F,
             main="Dynamically changing subpathway heat map")
  }
}