Commit 2fa41eb1 authored by dmattek's avatar dmattek

Improved recognition of input data column names

parent 69b35720
......@@ -45,6 +45,7 @@ s.cl.spar.linkage = c("average",
s.cl.diss = c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski", "DTW")
s.cl.spar.diss = c("squared.distance","absolute.value")
# list of palettes for the heatmap
l.col.pal = list(
"White-Orange-Red" = 'OrRd',
"Yellow-Orange-Red" = 'YlOrRd',
......@@ -55,6 +56,16 @@ l.col.pal = list(
"Spectral" = 'Spectral'
)
# list of palettes for the dendrogram
l.col.pal.dend = list(
"Rainbow" = 'rainbow_hcl',
"Sequential" = 'sequential_hcl',
"Heat" = 'heat_hcl',
"Terrain" = 'terrain_hcl',
"Diverge HCL" = 'diverge_hcl',
"Diverge HSV" = 'diverge_hsv'
)
# Creates a popup with help text
# From: https://gist.github.com/jcheng5/5913297
helpPopup <- function(title, content,
......@@ -341,6 +352,13 @@ userDataGen <- function() {
}
# Fast DTW computation
fastDTW <-function (x)
{
return(dtw(x, window.type = 'sakoechiba', distance.only = T)$normalizedDistance)
}
# Returns original dt with an additional column with normalized quantity.
# The column to be normalised is given by 'in.meas.col'.
# The name of additional column is the same as in.meas.col but with ".norm" suffix added.
......
......@@ -59,15 +59,22 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") {
column(3,
checkboxInput(ns('selectPlotHierDend'), 'Plot dendrogram and re-order samples', TRUE),
selectInput(
ns("selectPlotHierPalette"),
label = "Select colour palette:",
choices = l.col.pal,
selected = 'Spectral'
ns("selectPlotHierPaletteDend"),
label = "Dendrogram\'s colour palette:",
choices = l.col.pal.dend,
selected = 'Rainbow'
),
checkboxInput(ns('inPlotHierRevPalette'), 'Reverse colour palette', TRUE),
checkboxInput(ns('selectPlotHierKey'), 'Plot colour key', TRUE)
),
column(3,
selectInput(
ns("selectPlotHierPalette"),
label = "Heatmap\'s colour palette:",
choices = l.col.pal,
selected = 'Spectral'
),
checkboxInput(ns('inPlotHierRevPalette'), 'Reverse heatmap\'s colour palette', TRUE),
sliderInput(
ns('inPlotHierNAcolor'),
'Shade of grey for NA values (0 - black, 1 - white)',
......@@ -76,15 +83,17 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") {
value = 0.8,
step = .1,
ticks = TRUE
),
)
),
column(6,
h4('Classic hierarchical clustering'),
br(),
numericInput(ns('inPlotHierHeatMapHeight'),
'Display plot height [px]',
value = 600,
min = 100,
step = 100)
),
column(6,
h4('Classic hierarchical clustering')
)
),
......@@ -174,6 +183,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) {
return(NULL)
}
#pr_DB$set_entry(FUN = fastDTW, names = c("fastDTW"))
cl.dist = dist(dm.t, method = s.cl.diss[as.numeric(input$selectPlotHierDiss)])
return(cl.dist)
......@@ -191,11 +201,10 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) {
}
cl.hc = hclust(dm.dist, method = s.cl.linkage[as.numeric(input$selectPlotHierLinkage)])
#cl.lev = rev(row.names(dm.t))
dend <- as.dendrogram(cl.hc)
dend <- color_branches(dend,
col = rainbow_hcl, # make sure that n here equals max in the input$inPlotHierNclust slider
col = get(input$selectPlotHierPaletteDend), # make sure that n here equals max in the input$inPlotHierNclust slider
k = input$inPlotHierNclust)
return(dend)
......
......@@ -15,7 +15,7 @@ library(gplots) # for heatmap.2
library(plotly)
library(d3heatmap) # for interactive heatmap
library(dendextend) # for color_branches
library(colorspace) # for palettes (ised to colour dendrogram)
library(colorspace) # for palettes (used to colour dendrogram)
library(RColorBrewer)
library(sparcl) # sparse hierarchical and k-means
library(scales) # for percentages on y scale
......@@ -115,7 +115,7 @@ shinyServer(function(input, output, session) {
output$varSelTrackLabel = renderUI({
cat(file = stderr(), 'UI varSelTrackLabel\n')
locCols = getDataNucCols()
locColSel = locCols[locCols %like% 'rack.*abel'][1] # index 1 at the end in case more matches; select 1st
locColSel = locCols[grep('(T|t)rack|ID|id', locCols)[1]] # index 1 at the end in case more matches; select 1st; matches TrackLabel, tracklabel, Track Label etc
selectInput(
'inSelTrackLabel',
......@@ -129,7 +129,7 @@ shinyServer(function(input, output, session) {
output$varSelTime = renderUI({
cat(file = stderr(), 'UI varSelTime\n')
locCols = getDataNucCols()
locColSel = locCols[locCols %like% 'RealTime'][1] # index 1 at the end in case more matches; select 1st
locColSel = locCols[grep('(T|t)ime|Metadata_T', locCols)[1]] # index 1 at the end in case more matches; select 1st; matches RealTime, realtime, real time, etc.
cat(locColSel, '\n')
selectInput(
......@@ -153,13 +153,9 @@ shinyServer(function(input, output, session) {
locCols = getDataNucCols()
if (!is.null(locCols)) {
locColSel = locCols[locCols %like% 'ite']
if (length(locColSel) == 0)
locColSel = locCols[locCols %like% 'eries'][1] # index 1 at the end in case more matches; select 1st
else if (length(locColSel) > 1) {
locColSel = locColSel[1]
}
# cat('UI varSelGroup::locColSel ', locColSel, '\n')
locColSel = locCols[grep('(G|g)roup|(S|s)tim_All|(S|s)timulation|(S|s)ite', locCols)[1]]
#cat('UI varSelGroup::locColSel ', locColSel, '\n')
selectInput(
'inSelGroup',
'Select one or more facet groupings (e.g. Site, Well, Channel):',
......@@ -177,7 +173,7 @@ shinyServer(function(input, output, session) {
if (!input$chBtrackUni) {
locCols = getDataNucCols()
locColSel = locCols[locCols %like% 'ite'][1] # index 1 at the end in case more matches; select 1st
locColSel = locCols[grep('(S|s)ite|(S|s)eries', locCols)[1]] # index 1 at the end in case more matches; select 1st
selectInput(
'inSelSite',
......@@ -197,8 +193,7 @@ shinyServer(function(input, output, session) {
locCols = getDataNucCols()
if (!is.null(locCols)) {
locColSel = locCols[locCols %like% 'objCyto_Intensity_MeanIntensity_imErkCor.*' |
locCols %like% 'Ratio'][1] # index 1 at the end in case more matches; select 1st
locColSel = locCols[grep('objCyto_Intensity_MeanIntensity_imErkCor|(R|r)atio|(I|i)ntensity', locCols)[1]] # index 1 at the end in case more matches; select 1st
selectInput(
'inSelMeas1',
......@@ -217,7 +212,7 @@ shinyServer(function(input, output, session) {
if (!is.null(locCols) &&
!(input$inSelMath %in% c('', '1 / '))) {
locColSel = locCols[locCols %like% 'objNuc_Intensity_MeanIntensity_imErkCor.*'][1] # index 1 at the end in case more matches; select 1st
locColSel = locCols[grep('objNuc_Intensity_MeanIntensity_imErkCor', locCols)[1]] # index 1 at the end in case more matches; select 1st
selectInput(
'inSelMeas2',
......@@ -536,8 +531,8 @@ shinyServer(function(input, output, session) {
# Find column names with position
loc.s.pos.x = names(loc.dt)[names(loc.dt) %like% c('.*ocation.*X') | names(loc.dt) %like% c('.*os.x')]
loc.s.pos.y = names(loc.dt)[names(loc.dt) %like% c('.*ocation.*Y') | names(loc.dt) %like% c('.*os.y')]
loc.s.pos.x = names(loc.dt)[grep('(L|l)ocation.*X|(P|p)os.x|(P|p)osx', names(loc.dt))[1]]
loc.s.pos.y = names(loc.dt)[grep('(L|l)ocation.*X|(P|p)os.x|(P|p)osx', names(loc.dt))[1]]
if (length(loc.s.pos.x) == 1 & length(loc.s.pos.y) == 1)
locPos = TRUE
......@@ -548,13 +543,15 @@ shinyServer(function(input, output, session) {
# Find column names with ObjectNumber
# This is different from TrackObject_Label and is handy to keep
# because labels on segmented images are typically ObjectNumber
loc.s.objnum = names(loc.dt)[names(loc.dt) %like% c('ObjectNumber')]
if (length(loc.s.objnum) > 0) {
loc.s.objnum = names(loc.dt)[grep('(O|o)bject(N|n)umber', names(loc.dt))[1]]
#cat('data4trajPlot::loc.s.objnum ', loc.s.objnum, '\n')
if (is.na(loc.s.objnum)) {
locObjNum = FALSE
}
else {
loc.s.objnum = loc.s.objnum[1]
locObjNum = TRUE
}
else
locObjNum = FALSE
# if dataset contains column mid.in with trajectory filtering status,
......
......@@ -42,7 +42,7 @@ shinyUI(fluidPage(
uiOutput('uiButLoadTrajRem'),
tags$hr(),
checkboxInput('chBtrackUni', 'Track Label unique across entire dataset', FALSE),
checkboxInput('chBtrackUni', 'Track Label unique across entire dataset', TRUE),
helpPopup(
title = 'Create unique cell ID',
content = help.text[2],
......@@ -53,7 +53,7 @@ shinyUI(fluidPage(
uiOutput('varSelTrackLabel'),
tags$hr(),
checkboxInput('chBgroup', 'Dataset contains grouping column (e.g. treatment, condition)', TRUE),
checkboxInput('chBgroup', 'Dataset contains grouping column (e.g. treatment, condition)', FALSE),
uiOutput('varSelGroup'),
uiOutput('varSelTime'),
uiOutput('varSelMeas1'),
......
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