Heatmapshiny.R
### Author: Franck Soubès
### Bioinformatics Master Degree - University of Bordeaux, France
### Link: https://github.com/GeT-TRiX/MA_Trix_App/
### Where: GET-TRiX's facility
### Application: MATRiX is a shiny application for Mining and functional Analysis of TRanscriptomics data
### Licence: GPL-3.0
###############################
########heatmap function & co #
###############################
boolhm <- F
output$heatmbool <- reactive({
boolhm
})
observe({
print(boolhm)
})
outputOptions(output, "heatmbool", suspendWhenHidden = F)
observe({
req(csvf(),length(selected_test()) >0,input$reactheat == T| global$clicked)
observe({boolhm <<-T}) # modify and lock the bool value to false
output$heatmbool <- reactive({
boolhm
})
})
#' rowname is a reactive function which aim is to hide or show the rownames
#'
#' @param input$rowname a boolean radio button input
#'
#' @return rowname a reactive boolean value
#'
#' @export
rowname <- reactive({
rowname <- switch(input$rowname,
hide = F,
show = T,
F)
return(rowname)
})
#' colname is a reactive function which aim is to show or hide the colnames
#'
#' @param input$colname a boolean radio button input
#'
#' @return colname a reactive reactive boolean value
#'
#' @export
colname <- reactive({
colname <- switch(input$colname,
hide = T,
show = F,
F)
return(colname)
})
heatmapobj <- NULL
formatidus <- NULL
hmbis <- reactiveValues()
hmboth <- reactiveValues()
hmobj <- reactiveValues()
hmsize <- reactiveValues()
colors <- callModule(colorChooser, "myPanelcolhm", data = reactive(subsetgroup_hm()$Grp)) #assign color input widget for each groups
observe({
#' heatmapfinal is an isolate function that only react to a user's click on the heatmap button
#'
#' @param hmbis a data frame with all the individuals selected
#' @param subsetDEG a data frame with the indexes corresponding to the sigificant genes
#' @param subsetgroup_hm a data frame with the corresponding groups
#' @param my_palette a vector of colors
#' @param k a numeric value which aim is to defined the treshold value to cut the dendogram input$clusters
#' @param Rowdistfun a character value set by the user to defined the method to calculate the dendogram matrix distance for the genes input$dist
#' @param Coldistfun a character value set by the user to defined the method to calculate the dendogram matrix distance for the contrasts input$dist
#' @param mycex a numeric value which aim is to change the size of the legend in the heatmap defined by the user input$legsize
#' @param cexrow a numeric value to change the size of the police legend for the rows input$rowsize
#' @param cexcol a numeric value to change the size of the police legend for the columns input$colsize
#' @param meanGrp a boolean value to compute or not the mean of each contrasts in the heatmap input$meangrp
#' @param mypal a list of values
#' @param showcol a boolean value used to hide or show the colnames input$colname
#' @param showrow a boolean value used to hide or show the rownames input$rowname
#' @param genename a data frame
#' @param notplot a boolean value for applying dev.off or not on the heatmap
#' @param rowv dendogram object
#' @param ColOrd positive numbers, used as cex.axis in for the row or column axis labeling
#' @param gpcol matrix with colors associated to each groups
#' @param gpcolr matrix with gray color depending on the clusters
#' @param distfunTRIX function that computes whether euclidian or pearson for Hierarchical Clustering
#' @param height a numeric object corresponding to the selected cluster to display
#' @param rastering a graphical boolean
#' @param geneSet
#'
#' @return a data frame with the cluster and the corresponding genes
#'
#' @export
#'
heatmapfinal <- function(isplot = F, israstering = T) {
if (is.null(my_intermediate()))
mypal = (colorRampPalette(c("green", "black", "red"))(n = 75))
else
mypal = (colorRampPalette(c(
col_choice1(), my_intermediate(), col_choice3()
))(n = 75))
plotHeatmaps(
isolate(hmbis()[[1]]),
geneSet = isolate(hmbis()[[7]]),
droplevels(subsetgroup_hm()$Grp),
my_palette = (colorRampPalette(
c(col_choice1(), my_intermediate(), col_choice3()))(n = 75)),
mycex = input$legsize ,
cexrow = input$rowsize ,
cexcol = input$colsize ,
mypal = unlist(colors()),
showcol = colname(),
showrow = rowname(),
genename = csvf()[[3]],
notplot = isplot,
rowv = hmbis()[[4]],
ColvOrd = hmbis()[[3]],
gpcol = hmbis()[[5]],
gpcolr = hmbis()[[6]],
distfunTRIX = isolate(hmbis()[[2]]),
height = hmbis()[[8]],
scale = ifelse(input$dist == "correlation", "row", "none"),
rastering = israstering
)
}
output$warningsheat <- renderPrint({
validate(need(
csvf(),
'You need to import data to visualize to plot the Heatmap' ) %next%
need(length(selected_test()) >0, 'You need to select a contrast(s)') %next%
need(input$heatm , 'You need to click on the heatmap button down below the heatmap settings')
)
})
if (input$reactheat == T)
source(file.path("server", "Plotreact.R"), local = TRUE)$value #
else
source(file.path("server", "Plotreact2.R"), local = TRUE)$value #
observe({
req(hmobj$obj)
callModule(downoutputfiles, "savehm", projectname = projectname , suffix = "_heatmap." , data = hmobj$obj , w =9, h = 12, hm =T, rown = reactive(input$rowname))
})
callModule(downoutputables, "downloadcut", projectname = projectname , suffix = "_clustered_hm.csv" , data = ordered , case = 3 )
ordered <- reactive({
req(hmobj$hm)
if (input$decidemethod == "FDR")
met = prefstat$greppre[[1]]
else
met = prefstat$greppre[[3]]
# export only FDR sata
# ~ mycont = paste0(met, selected_test())
# Export All Restable DAta (adj.p, logFC and pvalue
# colnames to be selected for export table
mycont <- unlist(lapply(prefstat$greppre[c(2,3,1)],function(x)paste0(x,selected_test())))
ordered = csvf()[[3]] %>% filter( csvf()[[3]][[1]] %in% hmobj$hm[[2]] ) %>%
select(dataid(), mycont) %>%
full_join(hmobj$hm[,-1], ., by = dataid() ) %>%
select(dataid(), GeneName,cluster, mycont) %>%
# mutate_if(is.numeric, funs(format(., digits = 3)))
mutate_if(is.numeric, list(~format(., digits = 3)))
rightor = sort(as.integer(rownames(ordered)), decreasing = T)
ordered = ordered[match(rightor, rownames(ordered)), ]
return(ordered)
})
grouplength <- reactive({
req(ordered())
mydfhmgen = (subset( hmobj$hm, !duplicated(subset( hmobj$hm, select=GeneName))))
lengthofmyclust = sapply(1:NROW(unique( hmobj$hm$cluster)),function(x)
return(length(which(hmobj$hm$cluster ==x)))) %>%
cbind(.,sapply(1:NROW(unique( hmobj$hm$cluster)),function(x)
return(length(which(mydfhmgen$cluster ==x))))) %>% as.data.frame() %>%
setNames(.,c(ifelse(dataid() == "ProbeName", "total number of probes", "total number of transcripts"),"total number of genes")) %>%
`row.names<-`(., sapply(1:NROW(unique(hmobj$hm$cluster)), function(x)return(paste("cluster", x)))) %>%
rbind(. ,c(sum(unlist(.$`total number of probes`)), sum(unlist(.$`total number of genes`))))
rownames(lengthofmyclust)[length(rownames(lengthofmyclust))]<- "total"
lengthofmyclust <- tibble::rownames_to_column(lengthofmyclust, var=" ")
return(lengthofmyclust)
})
callModule(stylishTables, "totalgenbyc", data = grouplength , searching = F, pageLength = 10)
callModule(stylishTables, "clusteringtable", data = ordered , searching = F, scrollX = T,lengthpage= c('5', '10', '15'), pageLength = 10)
})
