From 2fa41eb1162ed54b6e08677839d7aea5a9fd0f82 Mon Sep 17 00:00:00 2001 From: dmattek Date: Thu, 1 Feb 2018 13:29:12 +0100 Subject: [PATCH] Improved recognition of input data column names --- modules/auxfunc.R | 18 ++++++++++++++++++ modules/tabClHier.R | 33 +++++++++++++++++++++------------ server.R | 37 +++++++++++++++++-------------------- ui.R | 4 ++-- 4 files changed, 58 insertions(+), 34 deletions(-) diff --git a/modules/auxfunc.R b/modules/auxfunc.R index 60cdf8b..92f00a6 100644 --- a/modules/auxfunc.R +++ b/modules/auxfunc.R @@ -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. diff --git a/modules/tabClHier.R b/modules/tabClHier.R index ab6878e..54eddfa 100644 --- a/modules/tabClHier.R +++ b/modules/tabClHier.R @@ -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) diff --git a/server.R b/server.R index 3d955fa..4b5e202 100644 --- a/server.R +++ b/server.R @@ -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, diff --git a/ui.R b/ui.R index 771095c..339466b 100644 --- a/ui.R +++ b/ui.R @@ -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'), -- GitLab