Commit 9bb17940 authored by dmattek's avatar dmattek

Big changes

parent c7c0bb8d
...@@ -89,16 +89,58 @@ help.text = c( ...@@ -89,16 +89,58 @@ help.text = c(
##### #####
## Function for clustering ## Functions for clustering
# get cell IDs with cluster assignments depending on dendrogram cut
getDataCl = function(in.dend, in.k, in.ids) { # Return a dt with cell IDs and corresponding cluster assignments depending on dendrogram cut (in.k)
# This one works wth dist & hclust pair
# For sparse hierarchical clustering use getDataClSpar
# Arguments:
# in.dend - dendrogram; usually output from as.dendrogram(hclust(distance_matrix))
# in.k - level at which dendrogram should be cut
getDataCl = function(in.dend, in.k) {
cat(file = stderr(), 'getDataCl \n') cat(file = stderr(), 'getDataCl \n')
loc.dt.cl = data.table(id = in.ids, loc.m = dendextend::cutree(in.dend, in.k, order_clusters_as_data = TRUE)
cl = cutree(as.dendrogram(in.dend), k = in.k)) #print(loc.m)
# The result of cutree containes named vector with names being cell id's
# THIS WON'T WORK with sparse hierarchical clustering because there, the dendrogram doesn't have original id's
loc.dt.cl = data.table(id = names(loc.m),
cl = loc.m)
cat('===============\ndataCl:\n')
print(loc.dt.cl)
return(loc.dt.cl)
} }
# Return a dt with cell IDs and corresponding cluster assignments depending on dendrogram cut (in.k)
# This one works with sparse hierarchical clustering!
# Arguments:
# in.dend - dendrogram; usually output from as.dendrogram(hclust(distance_matrix))
# in.k - level at which dendrogram should be cut
# in.id - vector of cell id's
getDataClSpar = function(in.dend, in.k, in.id) {
cat(file = stderr(), 'getDataClSpar \n')
loc.m = dendextend::cutree(in.dend, in.k, order_clusters_as_data = TRUE)
#print(loc.m)
# The result of cutree containes named vector with names being cell id's
# THIS WON'T WORK with sparse hierarchical clustering because there, the dendrogram doesn't have original id's
loc.dt.cl = data.table(id = in.id,
cl = loc.m)
cat('===============\ndataCl:\n')
print(loc.dt.cl)
return(loc.dt.cl)
}
# prepares a table with cluster numbers in 1st column and colour assignments in 2nd column # prepares a table with cluster numbers in 1st column and colour assignments in 2nd column
# the number of rows is determined by dendrogram cut # the number of rows is determined by dendrogram cut
getClCol <- function(in.dend, in.k) { getClCol <- function(in.dend, in.k) {
...@@ -266,13 +308,17 @@ userDataGen <- function() { ...@@ -266,13 +308,17 @@ userDataGen <- function() {
cat(file=stderr(), 'userDataGen: in\n') cat(file=stderr(), 'userDataGen: in\n')
locNtp = 40 locNtp = 40
locNtracks = 100 locNtracks = 10
locNsites = 4 locNsites = 4
locNwells = 1 locNwells = 1
x.rand.1 = c(rnorm(locNtp * locNtracks * locNsites * 0.5, .5, 0.1), rnorm(locNtp * locNtracks * locNsites * 0.5, 1, 0.2)) x.rand.1 = c(rnorm(locNtp * locNtracks * locNsites * 0.5, .5, 0.1), rnorm(locNtp * locNtracks * locNsites * 0.5, 1, 0.2))
x.rand.2 = c(rnorm(locNtp * locNtracks * locNsites * 0.5, 0.25, 0.1), rnorm(locNtp * locNtracks * locNsites * 0.5, 0.5, 0.2)) x.rand.2 = c(rnorm(locNtp * locNtracks * locNsites * 0.5, 0.25, 0.1), rnorm(locNtp * locNtracks * locNsites * 0.5, 0.5, 0.2))
# x.rand.3 = rep(rnorm(locNtracks, 2, 0.5), 1, each = locNtp)
# add NA's for testing
x.rand.1[c(10,20,30)] = NA
# x.rand.3 = rep(rnorm(locNtracks, 2, 0.5), 1, each = locNtp)
# x.rand.4 = rep(rnorm(locNtracks, 1, 0.1), 1, each = locNtp) # x.rand.4 = rep(rnorm(locNtracks, 1, 0.1), 1, each = locNtp)
# x.arg = rep(seq(0, locNtp-1) / locNtp * 4 * pi, locNtracks * locNsites) # x.arg = rep(seq(0, locNtp-1) / locNtp * 4 * pi, locNtracks * locNsites)
...@@ -526,7 +572,9 @@ myPlotHeatmap <- function(data.arg, ...@@ -526,7 +572,9 @@ myPlotHeatmap <- function(data.arg,
# rowsep = 1:nrow(loc.dm), # rowsep = 1:nrow(loc.dm),
cexRow = font.row.arg, cexRow = font.row.arg,
cexCol = font.col.arg, cexCol = font.col.arg,
main = title.arg main = title.arg,
symbreaks = FALSE,
symkey = FALSE
) )
return(loc.p) return(loc.p)
......
...@@ -75,7 +75,9 @@ tabBoxPlot = function(input, output, session, in.data, in.fname = 'boxplotTP.pdf ...@@ -75,7 +75,9 @@ tabBoxPlot = function(input, output, session, in.data, in.fname = 'boxplotTP.pdf
out.dt = loc.dt[realtime %in% input$inSelTpts] out.dt = loc.dt[realtime %in% input$inSelTpts]
loc.dt.aux = loc.dt[realtime %in% c(as.numeric(input$inSelTpts) - input$slFoldChTp)] loc.dt.aux = loc.dt[realtime %in% c(as.numeric(input$inSelTpts) - input$slFoldChTp)]
loc.y.prev = loc.dt.aux[, y] loc.y.prev = loc.dt.aux[, y]
print(nrow(loc.dt.aux))
print(nrow(out.dt))
out.dt[, y.prev := loc.y.prev] out.dt[, y.prev := loc.y.prev]
print(out.dt) print(out.dt)
out.dt[, y := abs(y / y.prev)] out.dt[, y := abs(y / y.prev)]
......
...@@ -257,7 +257,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) { ...@@ -257,7 +257,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) {
cat(file = stderr(), 'data4trajPlotCl: dt not NULL\n') cat(file = stderr(), 'data4trajPlotCl: dt not NULL\n')
# get cellIDs with cluster assignments based on dendrogram cut # get cellIDs with cluster assignments based on dendrogram cut
loc.dt.cl = getDataCl(userFitDendHier(), input$inPlotHierNclust, getDataTrackObjLabUni_afterTrim()) loc.dt.cl = getDataCl(userFitDendHier(), input$inPlotHierNclust)
loc.dt = merge(loc.dt, loc.dt.cl, by = 'id') loc.dt = merge(loc.dt, loc.dt.cl, by = 'id')
# display only selected clusters # display only selected clusters
...@@ -277,7 +277,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) { ...@@ -277,7 +277,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) {
}, },
content = function(file) { content = function(file) {
write.csv(x = getDataCl(userFitDendHier(), input$inPlotHierNclust, getDataTrackObjLabUni_afterTrim()), file = file, row.names = FALSE) write.csv(x = getDataCl(userFitDendHier(), input$inPlotHierNclust), file = file, row.names = FALSE)
} }
) )
...@@ -292,9 +292,8 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) { ...@@ -292,9 +292,8 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) {
return(NULL) return(NULL)
} }
loc.dt.cl = data.table(id = getDataTrackObjLabUni_afterTrim(), # get cell id's with associated cluster numbers
cl = cutree(as.dendrogram(loc.dend), k = input$inPlotHierNclust)) loc.dt.cl = getDataCl(loc.dend, input$inPlotHierNclust)
# get cellIDs with condition name # get cellIDs with condition name
loc.dt.gr = getDataCond() loc.dt.gr = getDataCond()
......
...@@ -222,8 +222,9 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -222,8 +222,9 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
return() return()
} }
#cat('rownames: ', rownames(dm.t), '\n')
cat('rownames: ', rownames(dm.t), '\n')
cat('=============\ndimensions:', dim(dm.t), '\n')
perm.out <- HierarchicalSparseCluster.permute( perm.out <- HierarchicalSparseCluster.permute(
dm.t, dm.t,
wbounds = NULL, wbounds = NULL,
...@@ -238,10 +239,16 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -238,10 +239,16 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
method = s.cl.spar.linkage[as.numeric(input$selectPlotHierSparLinkage)], method = s.cl.spar.linkage[as.numeric(input$selectPlotHierSparLinkage)],
dissimilarity = s.cl.spar.diss[as.numeric(input$selectPlotHierSparDiss)] dissimilarity = s.cl.spar.diss[as.numeric(input$selectPlotHierSparDiss)]
) )
cat('=============\nsparsehc:\n')
print(sparsehc$hc)
return(sparsehc) return(sparsehc)
}) })
# return dendrogram colour coded according to the cut level of the dendrogram
userFitDendHierSpar <- reactive({ userFitDendHierSpar <- reactive({
sparsehc = userFitHierSpar() sparsehc = userFitHierSpar()
if (is.null(sparsehc)) { if (is.null(sparsehc)) {
...@@ -249,6 +256,9 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -249,6 +256,9 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
} }
dend <- as.dendrogram(sparsehc$hc) dend <- as.dendrogram(sparsehc$hc)
cat('=============\ncutree:\n', dendextend::cutree(dend, input$inPlotHierSparNclust, order_clusters_as_data = TRUE), '\n')
dend <- color_branches(dend, dend <- color_branches(dend,
col = rainbow_hcl, col = rainbow_hcl,
k = input$inPlotHierSparNclust) k = input$inPlotHierSparNclust)
...@@ -265,7 +275,10 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -265,7 +275,10 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
if (is.null(loc.dend)) if (is.null(loc.dend))
return(NULL) return(NULL)
return(getClCol(loc.dend, input$inPlotHierSparNclust)) loc.cut = getClCol(loc.dend, input$inPlotHierSparNclust)
return(loc.cut)
}) })
...@@ -273,12 +286,12 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -273,12 +286,12 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
# This will be used to display in UI for trajectory highlighting # This will be used to display in UI for trajectory highlighting
getDataTrackObjLabUni_afterTrim <- reactive({ getDataTrackObjLabUni_afterTrim <- reactive({
cat(file = stderr(), 'getDataTrackObjLabUni_afterTrim\n') cat(file = stderr(), 'getDataTrackObjLabUni_afterTrim\n')
loc.dt = in.data4trajPlot() loc.dt = in.data4clust()
if (is.null(loc.dt)) if (is.null(loc.dt))
return(NULL) return(NULL)
else else
return(unique(loc.dt$id)) return(rownames(loc.dt))
}) })
# return dt with cell IDs and their corresponding condition name # return dt with cell IDs and their corresponding condition name
...@@ -309,8 +322,17 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -309,8 +322,17 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
cat(file = stderr(), 'data4trajPlotClSpar: dt not NULL\n') cat(file = stderr(), 'data4trajPlotClSpar: dt not NULL\n')
cat('rownames: ', rownames(in.data4clust()), '\n')
# get cellIDs with cluster assignments based on dendrogram cut # get cellIDs with cluster assignments based on dendrogram cut
loc.dt.cl = getDataCl(userFitDendHierSpar(), input$inPlotHierSparNclust, getDataTrackObjLabUni_afterTrim()) loc.dt.cl = getDataClSpar(userFitDendHierSpar(), input$inPlotHierSparNclust, getDataTrackObjLabUni_afterTrim())
####
## PROBLEM!!!
## the dendrogram from sparse hier clust doesn't contain cellID's
## the following merge won't work...
## No idea how to solve it
loc.dt = merge(loc.dt, loc.dt.cl, by = 'id') loc.dt = merge(loc.dt, loc.dt.cl, by = 'id')
# display only selected clusters # display only selected clusters
...@@ -331,7 +353,7 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -331,7 +353,7 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
}, },
content = function(file) { content = function(file) {
write.csv(x = getDataCl(userFitDendHierSpar(), input$inPlotHierSparNclust, getDataTrackObjLabUni_afterTrim()), file = file, row.names = FALSE) write.csv(x = getDataClSpar(userFitDendHierSpar(), input$inPlotHierSparNclust, getDataTrackObjLabUni_afterTrim()), file = file, row.names = FALSE)
} }
) )
...@@ -340,15 +362,14 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -340,15 +362,14 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
cat(file = stderr(), 'data4clSparDistPlot: in\n') cat(file = stderr(), 'data4clSparDistPlot: in\n')
# get cell IDs with cluster assignments depending on dendrogram cut # get cell IDs with cluster assignments depending on dendrogram cut
loc.dend <- userFitHierSpar() loc.dend <- userFitDendHierSpar()
if (is.null(loc.dend)) { if (is.null(loc.dend)) {
cat(file = stderr(), 'plotClSparDist: loc.dend is NULL\n') cat(file = stderr(), 'plotClSparDist: loc.dend is NULL\n')
return(NULL) return(NULL)
} }
loc.dt.cl = data.table(id = getDataTrackObjLabUni_afterTrim(), # get cell id's with associated cluster numbers
cl = cutree(as.dendrogram(loc.dend$hc), k = input$inPlotHierSparNclust)) loc.dt.cl = getDataClSpar(loc.dend, input$inPlotHierSparNclust, getDataTrackObjLabUni_afterTrim())
# get cellIDs with condition name # get cellIDs with condition name
loc.dt.gr = getDataCond() loc.dt.gr = getDataCond()
......
...@@ -147,26 +147,29 @@ shinyServer(function(input, output, session) { ...@@ -147,26 +147,29 @@ shinyServer(function(input, output, session) {
# In Coralie's case it's a combination of 3 columns called Stimulation_... # In Coralie's case it's a combination of 3 columns called Stimulation_...
output$varSelGroup = renderUI({ output$varSelGroup = renderUI({
cat(file = stderr(), 'UI varSelGroup\n') cat(file = stderr(), 'UI varSelGroup\n')
locCols = getDataNucCols()
if (!is.null(locCols)) { if (input$chBgroup) {
locColSel = locCols[locCols %like% 'ite']
if (length(locColSel) == 0) locCols = getDataNucCols()
locColSel = locCols[locCols %like% 'eries'][1] # index 1 at the end in case more matches; select 1st
else if (length(locColSel) > 1) { if (!is.null(locCols)) {
locColSel = locColSel[1] 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')
selectInput(
'inSelGroup',
'Select one or more facet groupings (e.g. Site, Well, Channel):',
locCols,
width = '100%',
selected = locColSel,
multiple = TRUE
)
} }
# cat('UI varSelGroup::locColSel ', locColSel, '\n')
selectInput(
'inSelGroup',
'Select one or more facet groupings (e.g. Site, Well, Channel):',
locCols,
width = '100%',
selected = locColSel,
multiple = TRUE
)
} }
}) })
output$varSelSite = renderUI({ output$varSelSite = renderUI({
...@@ -445,7 +448,9 @@ shinyServer(function(input, output, session) { ...@@ -445,7 +448,9 @@ shinyServer(function(input, output, session) {
cat(file = stderr(), 'dataMod: trajRem not NULL\n') cat(file = stderr(), 'dataMod: trajRem not NULL\n')
loc.dt.rem = dataLoadTrajRem() loc.dt.rem = dataLoadTrajRem()
loc.dt = loc.dt[!(trackObjectsLabelUni %in% loc.dt.rem$id)]
loc.dt = loc.dt[!(trackObjectsLabelUni %in% loc.dt.rem[[1]])]
} }
return(loc.dt) return(loc.dt)
...@@ -506,11 +511,20 @@ shinyServer(function(input, output, session) { ...@@ -506,11 +511,20 @@ shinyServer(function(input, output, session) {
# create expression for parsing # create expression for parsing
# creates a merged column based on other columns from input # creates a merged column based on other columns from input
# used for grouping of plot facets # used for grouping of plot facets
if(length(input$inSelGroup) == 0) if (input$chBgroup) {
return(NULL) if(length(input$inSelGroup) == 0)
loc.s.gr = sprintf("paste(%s, sep=';')", return(NULL)
paste(input$inSelGroup, sep = '', collapse = ','))
loc.s.gr = sprintf("paste(%s, sep=';')",
paste(input$inSelGroup, sep = '', collapse = ','))
} else {
# if no grouping required, fill 'group' column with 0
# because all the plotting relies on the presence of the group column
loc.s.gr = "paste('0')"
}
# column name with time
loc.s.rt = input$inSelTime loc.s.rt = input$inSelTime
# Assign tracks selected for highlighting in UI # Assign tracks selected for highlighting in UI
...@@ -548,9 +562,6 @@ shinyServer(function(input, output, session) { ...@@ -548,9 +562,6 @@ shinyServer(function(input, output, session) {
mid.in = mid.in mid.in = mid.in
)] )]
# add 3rd level with status of track selection # add 3rd level with status of track selection
# to a column with trajectory filtering status # to a column with trajectory filtering status
if (locBut) { if (locBut) {
...@@ -581,15 +592,48 @@ shinyServer(function(input, output, session) { ...@@ -581,15 +592,48 @@ shinyServer(function(input, output, session) {
} }
} }
# add XY location if present in the dataset ## Interpolate NA's and data points not included
# dt with a full span of realtime for every group and cell id (here it's already unique across entire dataset) combination
loc.dt.IdRt = CJ(id = loc.out[['id']],
realtime = loc.out[['realtime']],
unique = TRUE, sorted = TRUE )
# dt with all cell id's and their associated group names
loc.dt.GrId = loc.out[, .(group = first(group)), by = id]
# merge the 2 above to have all id~rt combinations with associated group names
loc.dt.GrIdRt = merge(loc.dt.IdRt, loc.dt.GrId, by = 'id')
# join with the original to expand it and create NA's for non-existing group-id-rt combinations
loc.out = merge(loc.dt.GrIdRt, loc.out, all.x = TRUE, by = c('group', 'id', 'realtime'))
# x-check: print all rows with NA's
print('Rows with NAs:')
print(loc.out[rowSums(is.na(loc.out)) > 0, ])
# Merge will create NA's where a realtime is missing.
# Also, NA's may be already present in the dataset'.
# Interpolate (linear) them with na.interpolate
if(locPos) {
s.cols = c('y', 'pos.x', 'pos.y')
loc.out[, (s.cols) := lapply(.SD, na.interpolation), by = id, .SDcols = s.cols]
}
else {
s.cols = c('y')
loc.out[, (s.cols) := lapply(.SD, na.interpolation), by = id, .SDcols = s.cols]
}
# remove NAs
# (doesn't make sense to remove here anyway; # !!! Current issue with interpolation:
# NA's are already removed in tCourseSelected.csv # The column mid.in is not taken into account.
# Such datapoints are missing, therefore they require interpolation. # If a trajectory is selected in the UI,
# If a row of long-format dt is removed, an NA appears after casting anyway if that grid point is missing) # the mid.in column is added (if it doesn't already exist in the dataset),
# Remove NAs in data4clust() # and for the interpolated point, it will still be NA. Not really an issue.
loc.out = loc.out[complete.cases(loc.out)] #
# Also, think about the current option of having mid.in column in the uploaded dataset.
# Keep it? Expand it?
# Create a UI filed for selecting the column with mid.in data.
# What to do with that column during interpolation (see above)
# Trim x-axis (time) # Trim x-axis (time)
if(input$chBtimeTrim) { if(input$chBtimeTrim) {
......
...@@ -51,7 +51,9 @@ shinyUI(fluidPage( ...@@ -51,7 +51,9 @@ shinyUI(fluidPage(
), ),
uiOutput('varSelSite'), uiOutput('varSelSite'),
uiOutput('varSelTrackLabel'), uiOutput('varSelTrackLabel'),
tags$hr(), tags$hr(),
checkboxInput('chBgroup', 'Dataset contains grouping column (e.g. treatment, condition)', TRUE),
uiOutput('varSelGroup'), uiOutput('varSelGroup'),
uiOutput('varSelTime'), uiOutput('varSelTime'),
uiOutput('varSelMeas1'), 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