R/plotDScoreHeatmap.R

In SubtypeDrug: Prioritization of Candidate Cancer Subtype Specific Drugs

##' plotDScoreHeatmap
##'
##'
##' @title Plot a heat map of the normalized drug-disease reverse association scores for cancer samples
##' @description According to the parameter setting, the function `plotDScoreHeatmap()` displays the heat map of the normalized
##' drug-disease reverse association score for the significant drugs.
##' @param data A list of result data generated by function `PrioSubtypeDrug()`.
##' @param subtype.label Character string indicates which sample of the cancer subtype was used to plot the heat map.
##' If subtype.label = "all" (default), all cancer samples will be shown in the heat map.
##' @param SDS A string indicates that the range of SDS is used for the heat map. if SDS="all" (default), the SDS will not be filtered.
##' SDS="negative", only drugs with SDS<0 are used. SDS="positive", only drugs with SDS>0 are used.
##' @param E_Pvalue.th A numeric.A threshold is used to filter the drug effected P value (default: 1).
##' @param E_FDR.th A numeric.A threshold is used to filter the drug effected FDR (default: 0.05).
##' @param S_Pvalue.th A numeric.A threshold is used to filter the Subtype specific P value (default: 1).
##' @param S_FDR.th A numeric.A threshold is used to filter the Subtype specific P value (default: 0.001).
##' @param show.rownames Boolean specifying if row names are be shown (default: TRUE).
##' @param show.colnames Boolean specifying if column names are be shown (default: FALSE).
##' @param color Vector of colors used in heatmap.
##' @param subtype_colors Vector of colors is used to annotate the sample subtype. Its length should correspond to the number of sample subtypes.
##' @param drug_colors Vector of colors is used to label subtype-specific drugs.
##' @param border_color Color of cell borders on heatmap, use NA if no border should be drawn.
##' @param cellwidth Individual cell width in points. If left as NA, then the values depend on the size of plotting window.
##' @param cellheight Individual cell height in points. If left as NA, then the values depend on the size of plotting window.
##' @param fontsize Base fontsize for the plot (default: 10).
##' @param fontsize.row Fontsize for rownames (default: 10).
##' @param fontsize.col Fontsize for colnames (default: 10).
##' @param scale Character indicating if the values should be centered and scaled in either the row direction or the column direction, or none. Corresponding values are "row" (default), "column" and "none".
##' @return A heat map.
##' @author Xudong Han,
##' Junwei Han,
##' Chonghui Liu
##' @examples
##' require(pheatmap)
##' ## Get the result data of PrioSubtypeDrug().
##' ## The data is based on the simulated breast cancer subtype data.
##' Subtype_drugs<-get("Subtype_drugs")
##' ## Heat map of all subtype-specific drugs.
##' #plotDScoreHeatmap(data=Subtype_drugs,E_Pvalue.th=0.05,
##' #                           S_Pvalue.th=0.05)
##' ## Plot only Basal subtype-specific drugs.
##' plotDScoreHeatmap(Subtype_drugs,subtype.label="Basal",SDS="all",E_Pvalue.th=0.05,
##'                   E_FDR.t=1,S_Pvalue.th=0.05,S_FDR.th=1)
##' @importFrom pheatmap pheatmap
##' @importFrom grDevices colorRampPalette
##' @export
plotDScoreHeatmap<-function(data,subtype.label="all",SDS="all",E_Pvalue.th=1,E_FDR.th=0.05,S_Pvalue.th=1,S_FDR.th=0.001,show.rownames = TRUE,
                          show.colnames = FALSE,color=colorRampPalette(c("#0A8D0A", "#F8F0EB", "red"))(190),subtype_colors=NA,
                          drug_colors=NA,border_color = "grey60",cellwidth = NA, cellheight = NA,fontsize = 10, fontsize.row = 10, fontsize.col = 10,scale = "row"){
  havepheatmap <- isPackageLoaded("pheatmap")
  if(havepheatmap==FALSE){
    stop("The 'pheatmap' library, should be loaded first")
  }

  phen<-names(table(data[["SampleInformation"]][["sampleSubtype"]]))
  phen<-phen[phen!=data[["Parameter"]][["control.label"]]]
   if(length(phen)==1){
    stop("There is no drug disease inverse association score matrix in the results of the two sample types")
   }

  colork<-get("Colork")
  if(is.na(subtype_colors)==TRUE){
    sycolor<-colork[1:length(phen)]
  }else{
    sycolor<-subtype_colors
  }
  names(sycolor)<-phen

  if(is.na(drug_colors)==TRUE){
    sycolor1<-colork[(length(phen)+2):(2*length(phen)+1)]
  }else{
    sycolor1<-drug_colors
  }

  zdz<-max(data[["DrugMatrix"]])
  zxz<-min(data[["DrugMatrix"]])
  bk <- c(seq(zxz,-0.1,by=0.01),seq(0,zdz,by=0.01))
    if(subtype.label=="all"){
      rowann<-NULL
      drugrtmatrix<-NULL
      drugNam<-NULL
      phen_length<-vector("numeric",length = length(phen))
      drug_fg<-vector("numeric",length = length(phen))
      for(i in 1:length(phen)){
        if(SDS=="all"){
          drugidnex_n<-which(data[[phen[i]]]$E_Pvalue<=E_Pvalue.th&data[[phen[i]]]$E_FDR<=E_FDR.th&
                            data[[phen[i]]]$S_Pvalue<=S_Pvalue.th&data[[phen[i]]]$S_FDR<=S_FDR.th&data[[phen[i]]][,4]<=0)
          drugidnex_p<-which(data[[phen[i]]]$E_Pvalue<=E_Pvalue.th&data[[phen[i]]]$E_FDR<=E_FDR.th&
                            data[[phen[i]]]$S_Pvalue<=S_Pvalue.th&data[[phen[i]]]$S_FDR<=S_FDR.th&data[[phen[i]]][,4]>0)
        }
        if(SDS=="negative"){
          drugidnex_n<-which(data[[phen[i]]]$E_Pvalue<=E_Pvalue.th&data[[phen[i]]]$E_FDR<=E_FDR.th&
                            data[[phen[i]]]$S_Pvalue<=S_Pvalue.th&data[[phen[i]]]$S_FDR<=S_FDR.th&data[[phen[i]]][,4]<=0)
          drugidnex_p<-NULL
        }
        if(SDS=="positive"){
          drugidnex_n<-NULL
          drugidnex_p<-which(data[[phen[i]]]$E_Pvalue<=E_Pvalue.th&data[[phen[i]]]$E_FDR<=E_FDR.th&
                            data[[phen[i]]]$S_Pvalue<=S_Pvalue.th&data[[phen[i]]]$S_FDR<=S_FDR.th&data[[phen[i]]][,4]>0)
        }
        rowann1 <- data.frame(SDS = factor(rep(c("Positive_side_effect","Negative_treatment"),c(length(drugidnex_p),length(drugidnex_n)))),
                            Drugs=factor(rep(paste(phen[i],"_specific",sep = ""),length(drugidnex_n)+length(drugidnex_p))))
        rowann<-rbind(rowann,rowann1)
        drugrtmatrix<-rbind(drugrtmatrix,data$DrugMatrix[c(drugidnex_p,drugidnex_n),])
        names(sycolor1)[i]<-paste(phen[i],"_specific",sep = "")
        drugNam<-c(drugNam,data[[phen[i]]]$Drug[c(drugidnex_p,drugidnex_n)])
        index<-which(data[["SampleInformation"]][["sampleSubtype"]]==phen[i])
        phen_length[i]<-length(index)
        drug_fg[i]<-c(length(drugidnex_n)+length(drugidnex_p))
      }

      if(is.element(TRUE,duplicated(drugNam))==TRUE){

        cfindex<-which(duplicated(drugNam)==TRUE)
        cfdrugs<-drugNam[cfindex]
        for(c in 1:length(cfdrugs)){
           cfindex<-which(drugNam==cfdrugs[c])
           drugNam[cfindex]<-paste(drugNam[cfindex],seq(1:length(drugNam[cfindex])),sep = "-")
        }
        row.names(drugrtmatrix)<-drugNam
        row.names(rowann)<-drugNam
      }else{
        row.names(drugrtmatrix)<-drugNam
        row.names(rowann)<-drugNam
      }

      ppindex<-match(colnames(drugrtmatrix),data[["SampleInformation"]][["sampleId"]])
      sample_labels<-data[["SampleInformation"]][["sampleSubtype"]][ppindex]
      pxindex<-order(sample_labels)
      sample_labels<-sample_labels[pxindex]
      drugrtmatrix<-drugrtmatrix[,pxindex]
      sample_v<-colnames(drugrtmatrix)

      colann<-data.frame(Subtype=sample_labels)
      if(is.element(TRUE,duplicated(sample_v))==TRUE){

        cfindex<-which(duplicated(sample_v)==TRUE)
        cfsample<-sample_v[cfindex]
        for(c in 1:length(cfsample)){
          cfindex<-which(sample_v==cfsample[c])
          sample_v[cfindex]<-paste(sample_v[cfindex],seq(1:length(sample_v[cfindex])),sep = "-")
        }
        colnames(drugrtmatrix)<-sample_v
        row.names(colann)<-sample_v
      }else{
        row.names(colann)<-sample_v
      }
      ann_colors<-list(SDS=c(Negative_treatment="blue",Positive_side_effect="red"),Subtype=sycolor,Drugs=sycolor1)
      pheatmap(drugrtmatrix,cluster_rows=FALSE,cluster_cols=FALSE,annotation_row =rowann,annotation_col =colann,
             color =color,breaks=bk,border_color=border_color,cellwidth=cellwidth,cellheight = cellheight,
             show_rownames=show.rownames, show_colnames=show.colnames,fontsize=fontsize, fontsize_row =fontsize.row,
             fontsize_col =fontsize.col,annotation_colors = ann_colors,main="Heat map of all subtype specific drugs",
             gaps_col=cumsum(phen_length),gaps_row = cumsum(drug_fg),scale=scale)

    }else{
      phen_length<-vector("numeric",length = length(phen))
      for(i in 1:length(phen)){
        index<-which(data[["SampleInformation"]][["sampleSubtype"]]==phen[i])
        phen_length[i]<-length(index)
      }

      if(SDS=="all"){
          drugidnex_n<-which(data[[subtype.label]]$E_Pvalue<=E_Pvalue.th&data[[subtype.label]]$E_FDR<=E_FDR.th&
                            data[[subtype.label]]$S_Pvalue<=S_Pvalue.th&data[[subtype.label]]$S_FDR<=S_FDR.th&data[[subtype.label]][,4]<=0)
          drugidnex_p<-which(data[[subtype.label]]$E_Pvalue<=E_Pvalue.th&data[[subtype.label]]$E_FDR<=E_FDR.th&
                            data[[subtype.label]]$S_Pvalue<=S_Pvalue.th&data[[subtype.label]]$S_FDR<=S_FDR.th&data[[subtype.label]][,4]>0)
        }
        if(SDS=="negative"){
          drugidnex_n<-which(data[[subtype.label]]$E_Pvalue<=E_Pvalue.th&data[[subtype.label]]$E_FDR<=E_FDR.th&
                            data[[subtype.label]]$S_Pvalue<=S_Pvalue.th&data[[subtype.label]]$S_FDR<=S_FDR.th&data[[subtype.label]][,4]<=0)
          drugidnex_p<-NULL
        }
        if(SDS=="positive"){
          drugidnex_n<-NULL
          drugidnex_p<-which(data[[subtype.label]]$E_Pvalue<=E_Pvalue.th&data[[subtype.label]]$E_FDR<=E_FDR.th&
                            data[[subtype.label]]$S_Pvalue<=S_Pvalue.th&data[[subtype.label]]$S_FDR<=S_FDR.th&data[[subtype.label]][,4]>0)
        }

      drugrtmatrix<-data$DrugMatrix[c(drugidnex_n,drugidnex_p),]
      rowann <- data.frame(SDS = factor(rep(c("Negative_treatment","Positive_side_effect"),c(length(drugidnex_n),length(drugidnex_p)))),
                           Drugs=factor(rep(paste(subtype.label,"_specific",sep = ""),nrow(drugrtmatrix))))
      rownames(rowann) <-row.names(drugrtmatrix)


      ppindex<-match(colnames(drugrtmatrix),data[["SampleInformation"]][["sampleId"]])
      sample_labels<-data[["SampleInformation"]][["sampleSubtype"]][ppindex]
      pxindex<-order(sample_labels)
      sample_labels<-sample_labels[pxindex]
      drugrtmatrix<-drugrtmatrix[,pxindex]
      sample_v<-colnames(drugrtmatrix)

      colann<-data.frame(Subtype=sample_labels)
      if(is.element(TRUE,duplicated(sample_v))==TRUE){

        cfindex<-which(duplicated(sample_v)==TRUE)
        cfsample<-sample_v[cfindex]
        for(c in 1:length(cfsample)){
          cfindex<-which(sample_v==cfsample[c])
          sample_v[cfindex]<-paste(sample_v[cfindex],seq(1:length(sample_v[cfindex])),sep = "-")
        }
        colnames(drugrtmatrix)<-sample_v
        row.names(colann)<-sample_v
      }else{
        row.names(colann)<-sample_v
      }

      pp<-which(names(sycolor)==subtype.label)
      sycolor2<-sycolor1[pp]
      names(sycolor2)<-paste(subtype.label,"_specific",sep = "")
      ann_colors<-list(SDS=c(Negative_treatment="blue",Positive_side_effect="red"),Subtype=sycolor,Drugs=sycolor2)
      pheatmap(drugrtmatrix,cluster_rows=FALSE,cluster_cols=FALSE,annotation_row =rowann,annotation_col =colann,
               color = color,breaks=bk,border_color=border_color,cellwidth=cellwidth,cellheight = cellheight,
               show_rownames=show.rownames, show_colnames=show.colnames,fontsize=fontsize, fontsize_row=fontsize.row,
               fontsize_col=fontsize.col,annotation_colors = ann_colors,main=paste("Heat map of the",subtype.label,"specific drugs"),
               gaps_col=cumsum(phen_length),scale=scale)
    }


}