Commit e346fce2 authored by dmattek's avatar dmattek
Browse files

Bayesian clustering tab

parent f43d2993
# RShiny module for performing Bayesian clustering using bclust
# Use:
# in ui.R
# tabPanel(
# 'Hierarchical',
# clustBayUI('TabClustBay'))
#
# in server.R
# callModule(clustBay, 'TabClustBay', dataMod)
# where dataMod is the output from a reactive function that returns dataset ready for clustering
require(gplots) # heatmap.2
require(dendextend) # color_branches
require(RColorBrewer) # brewer.pal
require(d3heatmap) # interactive heatmap
require(bclust) # Bayesian clustering
l.col.pal = list(
"Spectral" = 'Spectral',
"White-Orange-Red" = 'OrRd',
"Yellow-Orange-Red" = 'YlOrRd',
"Reds" = "Reds",
"Oranges" = "Oranges",
"Greens" = "Greens",
"Blues" = "Blues"
)
# UI
clustBayUI <- function(id, label = "Sparse Hierarchical CLustering") {
ns <- NS(id)
tagList(
h4(
"Bayesian clustering using ",
a("bclust", href = "https://cran.r-project.org/web/packages/bclust/index.html")
),
p('The algorithm does not deal with missing values. Use conversion to zeroes in the right panel.'),
p(
'Column labels in the heat-map are additionally labeled according to their Bayes weight (\"importance\"):'
),
tags$ol(
tags$li("Blue with \"-\" - variable not likely to participate in optimal clustering (negative weight)"),
tags$li("Black - low importance (weight factor in 1st quartile)"),
tags$li("Green with \"*\" - medium importance (weight factor in 2nd quartile)"),
tags$li("Orange with \"**\" - high importance (weight factor in 3rd quartile)"),
tags$li("Red with \"***\" - very high importance (weight factor in 4th quartile)")
),
br(),
fluidRow(
column(6,
selectInput(
ns("selectPlotBayHmPalette"),
label = "Select colour palette:",
choices = l.col.pal,
selected = 'Spctral'
),
checkboxInput(ns('inPlotBayHmRevPalette'), 'Reverse colour palette', TRUE),
checkboxInput(ns('selectPlotBayDend'),
'Plot dendrogram and re-order samples', TRUE),
checkboxInput(ns('selectPlotBayKey'), 'Plot colour key', TRUE)
),
column(6,
uiOutput(ns('inPlotBayHmNclustSlider')),
sliderInput(
ns('inPlotBayHmGridColor'),
'Shade of grey for grid lines (0 - black, 1 - white)',
min = 0,
max = 1,
value = 0.6,
step = .1,
ticks = TRUE
)
)
),
fluidRow(
column(
2,
numericInput(
ns('inPlotBayHmMarginX'),
'Margin below x-axis',
10,
min = 1,
width = 100
)
),
column(
2,
numericInput(
ns('inPlotBayHmMarginY'),
'Margin right of y-axis',
10,
min = 1,
width = 100
)
),
column(
2,
numericInput(
ns('inPlotBayHmFontX'),
'Font size row labels',
1,
min = 0,
width = 100,
step = 0.1
)
),
column(
2,
numericInput(
ns('inPlotBayHmFontY'),
'Font size column labels',
1,
min = 0,
width = 100,
step = 0.1
)
),
column(2,
numericInput(
ns('inPlotHeight'),
'Display plot height',
value = 1000,
min = 100,
step = 100
)
)
),
br(),
downPlotUI(ns('downPlotBayHM')),
br(),
checkboxInput(ns('inPlotBayInteractive'), 'Interactive Plot?', value = FALSE),
uiOutput(ns("plotBayInt_ui"))
)
}
# SERVER
clustBay <- function(input, output, session, dataMod) {
userFitBclus <- reactive({
cat(file = stderr(), 'userFitBclus \n')
loc.dm = dataMod()
if (is.null(loc.dm))
return(NULL)
bclust(loc.dm, transformed.par = c(0, -50, log(16), 0, 0, 0))
})
userDendBclus <- reactive({
cat(file = stderr(), 'userDendBclus \n')
d.bclus = userFitBclus()
if (is.null(d.bclus))
return(NULL)
dend <- as.dendrogram(d.bclus)
# dend <- color_branches(dend, k = d.bclus$optim.clustno)
dend <- color_branches(dend, k = input$inPlotBayHmNclust)
# browser()
})
userVarImpBclus <- reactive({
cat(file = stderr(), 'userVarImpBclus \n')
d.bclus = userFitBclus()
if (is.null(d.bclus))
return(NULL)
return(imp(d.bclus)$var)
})
output$inPlotBayHmNclustSlider = renderUI({
ns <- session$ns
loc.dm = dataMod()
if (is.null(loc.dm))
return(NULL)
loc.d.bclus = userFitBclus()
if (is.null(loc.d.bclus))
return(NULL)
sliderInput(
ns('inPlotBayHmNclust'),
'#clusters to colour (default: optimal # from bclust)',
min = 1,
max = nrow(loc.dm),
value = loc.d.bclus$optim.clustno,
step = 1,
ticks = TRUE,
round = TRUE
)
})
plotBayHm <- function() {
cat(file = stderr(), 'plotBayHm \n')
loc.dm = dataMod()
if (is.null(loc.dm))
return(NULL)
loc.dend = userDendBclus()
if (is.null(loc.dend))
return(NULL)
loc.var.imp = imp(userFitBclus())$var
if (is.null(loc.var.imp))
return(NULL)
col_labels <- get_leaves_branches_col(loc.dend)
col_labels <- col_labels[order(order.dendrogram(loc.dend))]
if (input$inPlotBayHmRevPalette)
my_palette <-
rev(colorRampPalette(brewer.pal(9, input$selectPlotBayHmPalette))(n = 99))
else
my_palette <-
colorRampPalette(brewer.pal(9, input$selectPlotBayHmPalette))(n = 99)
if (input$selectPlotBayDend) {
assign("var.tmp.1", loc.dend)
var.tmp.2 = "row"
} else {
assign("var.tmp.1", FALSE)
var.tmp.2 = "none"
}
loc.colnames = paste0(ifelse(loc.var.imp < 0, "- ",
ifelse(
loc.var.imp < quantile(loc.var.imp, 0.25), "",
ifelse(loc.var.imp < quantile(loc.var.imp, 0.5), "* ",
ifelse(loc.var.imp < quantile(loc.var.imp, 0.75), "** ", "*** "))
)), colnames(loc.dm))
loc.colcol = ifelse(loc.var.imp < 0, "blue",
ifelse(
loc.var.imp < quantile(loc.var.imp, 0.25), "black",
ifelse(loc.var.imp < quantile(loc.var.imp, 0.5), "green",
ifelse(loc.var.imp < quantile(loc.var.imp, 0.75), "orange", "red"))
))
heatmap.2(
loc.dm,
Colv = "NA",
Rowv = var.tmp.1,
srtCol = 90,
dendrogram = var.tmp.2,
trace = "none",
key = input$selectPlotBayKey,
margins = c(input$inPlotBayHmMarginX, input$inPlotBayHmMarginY),
col = my_palette,
na.col = grey(input$inPlotBayHmNAcolor),
denscol = "black",
density.info = "density",
RowSideColors = col_labels,
colRow = col_labels,
colCol = loc.colcol,
labCol = loc.colnames,
sepcolor = grey(input$inPlotBayHmGridColor),
colsep = 1:ncol(loc.dm),
rowsep = 1:nrow(loc.dm),
cexRow = input$inPlotBayHmFontX,
cexCol = input$inPlotBayHmFontY,
main = "Bayesian Clustering (bclust)"
)
}
plotBayImp <- function() {
cat(file = stderr(), 'plotBayImp \n')
loc.dm = dataMod()
if (is.null(loc.dm))
return(NULL)
loc.d.bclus = userFitBclus()
if (is.null(loc.d.bclus))
return(NULL)
#cat(imp(loc.d.bclus)$var)
viplot(
imp(loc.d.bclus)$var,
xlab = colnames(loc.dm),
xlab.srt = 90,
xlab.mar = input$inPlotBayHmMarginX,
xlab.cex = input$inPlotBayHmFontY,
main = '\nVariable importance\n'
)
}
output$outPlotBayHm <- renderPlot({
plotBayHm()
})
output$plotBayInt <- renderD3heatmap({
cat(file = stderr(), 'plotBayInt \n')
loc.dm = dataMod()
if (is.null(loc.dm))
return(NULL)
loc.dend = userDendBclus()
if (is.null(loc.dend))
return(NULL)
loc.var.imp = imp(userFitBclus())$var
if (is.null(loc.var.imp))
return(NULL)
col_labels <- get_leaves_branches_col(loc.dend)
col_labels <- col_labels[order(order.dendrogram(loc.dend))]
if (input$inPlotBayHmRevPalette)
my_palette <-
rev(colorRampPalette(brewer.pal(9, input$selectPlotBayHmPalette))(n = 99))
else
my_palette <-
colorRampPalette(brewer.pal(9, input$selectPlotBayHmPalette))(n = 99)
if (input$selectPlotBayDend) {
assign("var.tmp.1", loc.dend)
var.tmp.2 = "row"
} else {
assign("var.tmp.1", FALSE)
var.tmp.2 = "none"
}
loc.colnames = paste0(ifelse(loc.var.imp < 0, "- ",
ifelse(
loc.var.imp < quantile(loc.var.imp, 0.25), "",
ifelse(loc.var.imp < quantile(loc.var.imp, 0.5), "* ",
ifelse(loc.var.imp < quantile(loc.var.imp, 0.75), "** ", "*** "))
)), colnames(loc.dm))
d3heatmap(
loc.dm,
Rowv = var.tmp.1,
dendrogram = var.tmp.2,
trace = "none",
revC = FALSE,
margins = c(input$inPlotBayHmMarginX, input$inPlotBayHmMarginY),
colors = my_palette,
na.col = grey(input$inPlotBayNAcolor),
cexRow = input$inPlotBayHmFontY,
cexCol = input$inPlotBayHmFontX,
xaxis_height = input$inPlotBayHmMarginX,
yaxis_width = input$inPlotBayHmMarginY,
show_grid = TRUE,
labRow = rownames(loc.dm),
labCol = loc.colnames
)
})
output$plotBayInt_ui <- renderUI({
ns <- session$ns
if (input$inPlotBayInteractive)
d3heatmapOutput(ns("plotBayInt"), height = paste0(input$inPlotHeight, "px"))
else {
plotOutput(ns('outPlotBayHm'), height = paste0(input$inPlotHeight, "px"))
}
})
callModule(downPlot, "downPlotBayHM", 'clust_bayesian_dend.pdf', plotBayHm)
}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment