Skip to content
GitLab
Commit 1b4ec97e authored by dmattek's avatar dmattek
Browse files

Improve flow with validate-need syntax

parent 352c21f8
Hide whitespace changes
Inline Side-by-side
modules/tabClHier.R
View file @ 1b4ec97e
......@@ -56,7 +56,7 @@ clustHierUI <- function(id, label = "Hierarchical Clustering") {
),
column(6,
sliderInput(
ns('inPlotHierNclust'),
ns('slPlotHierNclust'),
'Number of dendrogram branches to cut',
min = 1,
max = 20,
......@@ -95,10 +95,10 @@ clustHierUI <- function(id, label = "Hierarchical Clustering") {
checkboxInput(ns('chBsetColBounds'), 'Set bounds for colour scale', FALSE),
fluidRow(
column(3,
column(5,
uiOutput(ns('uiSetColBoundsLow'))
),
column(3,
column(5,
uiOutput(ns('uiSetColBoundsHigh'))
)
)
......@@ -191,16 +191,23 @@ clustHierUI <- function(id, label = "Hierarchical Clustering") {
}
# SERVER ----
clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, in.data4stimPlot) {
clustHier <- function(input, output, session, in.dataWide, in.dataLong, in.dataStim) {
# Return the number of clusters from the slider
# and delay by a constant in milliseconds defined in auxfunc.R
returnNclust = reactive({
return(input$slPlotHierNclust)
}) %>% debounce(MILLIS)
# not functional; see th note in UI
output$uiPlotHierClAss = renderUI({
ns <- session$ns
if(input$chBPlotHierClAss) {
selectInput(ns('inPlotHierClAss'), 'Assign cluster order',
choices = seq(1, input$inPlotHierNclust, 1),
choices = seq(1, returnNclust(), 1),
multiple = TRUE,
selected = seq(1, input$inPlotHierNclust, 1))
selected = seq(1, returnNclust(), 1))
}
})
......@@ -209,25 +216,29 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
if(input$chBPlotHierClSel) {
selectInput(ns('inPlotHierClSel'), 'Select clusters to display',
choices = seq(1, input$inPlotHierNclust, 1),
choices = seq(1, returnNclust(), 1),
multiple = TRUE,
selected = 1)
}
})
# UI for setting lower and upper bounds for heat map colour scale
output$uiSetColBoundsLow = renderUI({
ns <- session$ns
if(input$chBsetColBounds) {
loc.dt = in.data4trajPlot()
loc.dt = in.dataLong()
if (is.null(loc.dt))
return(NULL)
numericInput(
ns('inSetColBoundsLow'),
label = 'Lower',
step = 0.1,
value = floor(min(loc.dt[['y']], na.rm = T))
value = signif(min(loc.dt[['y']], na.rm = T), digits = 3)
)
}
})
......@@ -238,30 +249,61 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
if(input$chBsetColBounds) {
loc.dt = in.data4trajPlot()
loc.dt = in.dataLong()
if (is.null(loc.dt))
return(NULL)
numericInput(
ns('inSetColBoundsHigh'),
label = 'Upper',
step = 0.1,
value = ceil(max(loc.dt[['y']], na.rm = T))
value = signif(max(loc.dt[['y']], na.rm = T), digits = 3)
)
}
})
# calculate distance matrix for further clustering
# time series arranged in rows with columns corresponding to time points
userFitDistHier <- reactive({
cat(file = stderr(), 'userFitDistHier \n')
dm.t = in.data4clust()
loc.dm = in.dataWide()
if (is.null(dm.t)) {
if (is.null(loc.dm)) {
return(NULL)
}
# Throw some warnings if NAs present in the dataset.
# DTW cannot compute distance when NA's are preset.
# Other distance measures can be calculated but caution is required with interpretation.
# NAs in the wide format can result from explicit NAs in the measurment column or
# from missing rows that cause NAs to appear when convertinf from long to wide (dcast)
if(sum(is.na(loc.dm)) > 0) {
if (input$selectPlotHierDiss == "DTW") {
createAlert(session, "alertAnchorClHierNAsPresent", "alertNAsPresentDTW", title = "Error",
content = helpText.clHier[["alertNAsPresentDTW"]],
append = FALSE,
style = "danger")
closeAlert(session, 'alertNAsPresent')
return(NULL)
} else {
createAlert(session, "alertAnchorClHierNAsPresent", "alertNAsPresent", title = "Warning",
content = helpText.clHier[["alertNAsPresent"]],
append = FALSE,
style = "warning")
closeAlert(session, 'alertNAsPresentDTW')
}
} else {
closeAlert(session, 'alertNAsPresentDTW')
closeAlert(session, 'alertNAsPresent')
}
#pr_DB$set_entry(FUN = fastDTW, names = c("fastDTW"))
cl.dist = dist(dm.t, method = input$selectPlotHierDiss)
cl.dist = proxy::dist(loc.dm, method = input$selectPlotHierDiss)
return(cl.dist)
})
......@@ -271,16 +313,17 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
userFitDendHier <- reactive({
cat(file = stderr(), 'userFitDendHier \n')
dm.dist = userFitDistHier()
# calculate distance matrix
loc.dm.dist = userFitDistHier()
if (is.null(dm.dist)) {
if (is.null(loc.dm.dist)) {
return(NULL)
}
cl.hc = hclust(dm.dist, method = input$selectPlotHierLinkage)
loc.cl.hc = hclust(loc.dm.dist, method = input$selectPlotHierLinkage)
# number of clusters at which dendrigram is cut
loc.k = input$inPlotHierNclust
loc.k = returnNclust()
# make a palette with the amount of colours equal to the number of clusters
#loc.col = get(input$selectPlotHierPaletteDend)(n = loc.k)
......@@ -292,13 +335,13 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
# loc.col = loc.col[as.numeric(input$inPlotHierClAss)]
#}
dend <- as.dendrogram(cl.hc)
dend <- color_branches(dend,
loc.dend <- as.dendrogram(loc.cl.hc)
loc.dend <- color_branches(loc.dend,
col = loc.col,
k = loc.k)
return(dend)
})
return(loc.dend)
})
# returns table prepared with f-n getClCol
......@@ -310,7 +353,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
if (is.null(loc.dend))
return(NULL)
loc.dt = getClCol(loc.dend, input$inPlotHierNclust)
loc.dt = getClCol(loc.dend, returnNclust())
# Display clusters specified in the inPlotHierClSel field
# Data is ordered according to the order of clusters specified in this field
......@@ -325,11 +368,11 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
# return all unique track object labels (created in dataMod)
# Return all unique track object labels (created in dataMod)
# This will be used to display in UI for trajectory highlighting
getDataTrackObjLabUni_afterTrim <- reactive({
cat(file = stderr(), 'getDataTrackObjLabUni_afterTrim\n')
loc.dt = in.data4trajPlot()
loc.dt = in.dataLong()
if (is.null(loc.dt))
return(NULL)
......@@ -341,7 +384,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
# The condition is the column defined by facet groupings
getDataCond <- reactive({
cat(file = stderr(), 'getDataCond\n')
loc.dt = in.data4trajPlot()
loc.dt = in.dataLong()
if (is.null(loc.dt))
return(NULL)
......@@ -356,7 +399,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
data4trajPlotCl <- reactive({
cat(file = stderr(), 'data4trajPlotCl: in\n')
loc.dt = in.data4trajPlot()
loc.dt = in.dataLong()
if (is.null(loc.dt)) {
cat(file = stderr(), 'data4trajPlotCl: dt is NULL\n')
......@@ -366,7 +409,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
cat(file = stderr(), 'data4trajPlotCl: dt not NULL\n')
# get cellIDs with cluster assignments based on dendrogram cut
loc.dt.cl = getDataCl(userFitDendHier(), input$inPlotHierNclust)
loc.dt.cl = getDataCl(userFitDendHier(), returnNclust())
# add the column with cluster assignemnt to the main dataset
loc.dt = merge(loc.dt, loc.dt.cl, by = COLID)
......@@ -385,7 +428,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
data4stimPlotCl <- reactive({
cat(file = stderr(), 'data4stimPlotCl: in\n')
loc.dt = in.data4stimPlot()
loc.dt = in.dataStim()
if (is.null(loc.dt)) {
cat(file = stderr(), 'data4stimPlotCl: dt is NULL\n')
......@@ -406,7 +449,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
},
content = function(file) {
write.csv(x = getDataCl(userFitDendHier(), input$inPlotHierNclust), file = file, row.names = FALSE)
write.csv(x = getDataCl(userFitDendHier(), returnNclust()), file = file, row.names = FALSE)
}
)
......@@ -422,7 +465,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
}
# get cell id's with associated cluster numbers
loc.dt.cl = getDataCl(loc.dend, input$inPlotHierNclust)
loc.dt.cl = getDataCl(loc.dend, returnNclust())
# get cellIDs with condition name
loc.dt.gr = getDataCond()
......@@ -447,52 +490,33 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
})
createMethodStr = reactive({
paste0(input$selectPlotHierDiss,
'_',
input$selectPlotHierLinkage)
})
# Function instead of reactive as per:
# http://stackoverflow.com/questions/26764481/downloading-png-from-shiny-r
# This function is used to plot and to downoad a pdf
plotHier <- function() {
cat(file = stderr(), 'plotHier: in\n')
loc.dm = in.data4clust()
if (is.null(loc.dm))
return(NULL)
# make the f-n dependent on the button click
locBut = input$butPlotHierHeatMap
# Throw some warnings if NAs present in the dataset.
# DTW cannot compute distance when NA's are preset.
# Other distance measures can be calculated but caution is required with interpretation.
if(sum(is.na(loc.dm)) > 0) {
if (input$selectPlotHierDiss == "DTW") {
createAlert(session, "alertAnchorClHierNAsPresent", "alertNAsPresentDTW", title = "Error",
content = helpText.clHier[["alertNAsPresentDTW"]],
append = FALSE,
style = "danger")
return(NULL)
} else {
createAlert(session, "alertAnchorClHierNAsPresent", "alertNAsPresent", title = "Warning",
content = helpText.clHier[["alertNAsPresent"]],
append = FALSE,
style = "warning")
closeAlert(session, 'alertNAsPresentDTW')
}
} else {
closeAlert(session, 'alertNAsPresentDTW')
closeAlert(session, 'alertNAsPresent')
}
# Check if main data exists
# Thanks to solate all mods in the left panel are delayed
# until clicking the Plot button
loc.dm = isolate(in.dataWide())
loc.dend = isolate(userFitDendHier())
validate(
need(!is.null(loc.dm), "Nothing to plot. Load data first!"),
need(!is.null(loc.dend), "Did not create dendrogram")
)
loc.dend <- userFitDendHier()
if (is.null(loc.dend))
return(NULL)
# Dummy dependency to redraw the heatmap without clicking Plot
# when changing the number of clusters to highlight
loc.k = returnNclust()
loc.col.bounds = NULL
if (input$chBsetColBounds)
loc.col.bounds = c(input$inSetColBoundsLow, input$inSetColBoundsHigh)
loc.col.bounds = c(input$inSetColBoundsLow,
input$inSetColBoundsHigh)
else
loc.col.bounds = NULL
......@@ -527,13 +551,6 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, i
}
output$outPlotHier <- renderPlot({
locBut = input$butPlotHierHeatMap
if (locBut == 0) {
cat(file = stderr(), 'outPlotHier: Go button not pressed\n')
return(NULL)
}
plotHier()
}, height = getPlotHierHeatMapHeight)
......
modules/tabClHierSpar.R
View file @ 1b4ec97e
......@@ -171,7 +171,7 @@ clustHierSparUI <- function(id, label = "Sparse Hierarchical Clustering") {
),
br(),
actionButton(ns('butPlotHierSparHeatMap'), 'Plot!'),
actionButton(ns('butPlot'), 'Plot!'),
downPlotUI(ns('downPlotHierSparHM'), "Download Plot"),
withSpinner(plotOutput(ns('outPlotHierSpar')))
......@@ -198,12 +198,18 @@ clustHierSparUI <- function(id, label = "Sparse Hierarchical Clustering") {
# SERVER ----
clustHierSpar <- function(input, output, session,
in.data4clust,
in.dataWide,
in.data4trajPlot,
in.data4stimPlot) {
ns = session$ns
# Return the number of clusters from the slider
# and delay by a constant in milliseconds defined in auxfunc.R
returnNclust = reactive({
return(input$inPlotHierSparNclust)
}) %>% debounce(MILLIS)
# UI for advanced options
output$uiPlotHierSparNperms = renderUI({
ns <- session$ns
......@@ -284,7 +290,7 @@ clustHierSpar <- function(input, output, session,
userFitHierSpar <- reactive({
cat(file = stderr(), 'userFitHierSpar \n')
dm.t = in.data4clust()
dm.t = in.dataWide()
if (is.null(dm.t)) {
return()
}
......@@ -299,7 +305,7 @@ clustHierSpar <- function(input, output, session,
dissimilarity = input$selectPlotHierSparDiss
)
sparsehc <- HierarchicalSparseCluster(
loc.hc <- HierarchicalSparseCluster(
dists = perm.out$dists,
wbound = perm.out$bestw,
niter = ifelse(input$inHierSparAdv, input$inPlotHierSparNiter, 1),
......@@ -307,22 +313,22 @@ clustHierSpar <- function(input, output, session,
dissimilarity = input$selectPlotHierSparDiss
)
#cat('=============\nsparsehc:\n')
#print(sparsehc$hc)
#cat('=============\nloc.hc:\n')
#print(loc.hc$hc)
return(sparsehc)
return(loc.hc)
})
# return dendrogram colour coded according to the cut level of the dendrogram
userFitDendHierSpar <- reactive({
sparsehc = userFitHierSpar()
if (is.null(sparsehc)) {
loc.hc = userFitHierSpar()
if (is.null(loc.hc)) {
return()
}
# number of clusters at which dendrigram is cut
# number of clusters at which dendrogram is cut
loc.k = input$inPlotHierSparNclust
# make a palette with the amount of colours equal to the number of clusters
......@@ -330,7 +336,7 @@ clustHierSpar <- function(input, output, session,
loc.col = ggthemes::tableau_color_pal(input$selectPlotHierSparPaletteDend)(n = loc.k)
dend <- as.dendrogram(sparsehc$hc)
dend <- as.dendrogram(loc.hc$hc)
dend <- color_branches(dend,
col = loc.col,
k = loc.k)
......@@ -358,7 +364,7 @@ clustHierSpar <- function(input, output, session,
# This will be used to display in UI for trajectory highlighting
getDataTrackObjLabUni_afterTrim <- reactive({
cat(file = stderr(), 'getDataTrackObjLabUni_afterTrim\n')
loc.dt = in.data4clust()
loc.dt = in.dataWide()
if (is.null(loc.dt))
return(NULL)
......@@ -394,7 +400,7 @@ clustHierSpar <- function(input, output, session,
cat(file = stderr(), 'data4trajPlotClSpar: dt not NULL\n')
#cat('rownames: ', rownames(in.data4clust()), '\n')
#cat('rownames: ', rownames(in.dataWide()), '\n')
# get cellIDs with cluster assignments based on dendrogram cut
loc.dt.cl = getDataClSpar(userFitDendHierSpar(),
......@@ -485,28 +491,44 @@ clustHierSpar <- function(input, output, session,
# http://stackoverflow.com/questions/26764481/downloading-png-from-shiny-r
# This function is used to plot and to downoad a pdf
plotHierSpar <- function() {
cat(file = stderr(), 'plotHierSpar: in\n')
# make the f-n dependent on the button click
locBut = input$butPlot
# Check if main data exists
# Thanks to solate all mods in the left panel are delayed
# until clicking the Plot button
loc.dm = isolate(in.dataWide())
loc.hc = isolate(userFitHierSpar())
loc.dend = isolate(userFitDendHierSpar())
validate(
need(!is.null(loc.dm), "Nothing to plot. Load data first!"),
need(!is.null(loc.hc), "Did not cluster"),
need(!is.null(loc.dend), "Did not create dendrogram")
)
loc.dm = in.data4clust()
if (is.null(loc.dm)) {
return()
}
# Dummy dependency to redraw the heatmap without clicking Plot
# when changing the number of clusters to highlight
loc.k = returnNclust()
sparsehc <- userFitHierSpar()
loc.dend <- userFitDendHierSpar()
loc.colnames = paste0(ifelse(sparsehc$ws == 0, "",
# create column labels according to importance weights
loc.colnames = paste0(ifelse(loc.hc$ws == 0, "",
ifelse(
sparsehc$ws <= 0.1,
loc.hc$ws <= 0.1,
"* ",
ifelse(sparsehc$ws <= 0.5, "** ", "*** ")
ifelse(loc.hc$ws <= 0.5, "** ", "*** ")
)), colnames(loc.dm))
loc.colcol = ifelse(sparsehc$ws == 0,
# add color to column labels according to importance weights
loc.colcol = ifelse(loc.hc$ws == 0,
"black",
ifelse(
sparsehc$ws <= 0.1,
loc.hc$ws <= 0.1,
"blue",
ifelse(sparsehc$ws <= 0.5, "green", "red")
ifelse(loc.hc$ws <= 0.5, "green", "red")
))
loc.col.bounds = NULL
......@@ -625,14 +647,6 @@ clustHierSpar <- function(input, output, session,
# Sparse Hierarchical - display heatmap
output$outPlotHierSpar <- renderPlot({
locBut = input$butPlotHierSparHeatMap
if (locBut == 0) {
cat(file = stderr(), 'outPlotHierSpar: Go button not pressed\n')
return(NULL)
}
plotHierSpar()
}, height = getPlotHierSparHeatMapHeight)
......
Supports Markdown
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