Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
S
shiny-timecourse-inspector
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
2
Issues
2
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Packages & Registries
Packages & Registries
Container Registry
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
pertz-lab
shiny-timecourse-inspector
Commits
9bb17940
Commit
9bb17940
authored
Nov 22, 2017
by
dmattek
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Big changes
parent
c7c0bb8d
Changes
6
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
173 additions
and
57 deletions
+173
-57
modules/auxfunc.R
modules/auxfunc.R
+56
-8
modules/tabBoxPlot.R
modules/tabBoxPlot.R
+3
-1
modules/tabClHier.R
modules/tabClHier.R
+4
-5
modules/tabClHierSpar.R
modules/tabClHierSpar.R
+31
-10
server.R
server.R
+77
-33
ui.R
ui.R
+2
-0
No files found.
modules/auxfunc.R
View file @
9bb17940
...
...
@@ -89,16 +89,58 @@ help.text = c(
#####
## Function for clustering
## Function
s
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'
)
loc.dt.cl
=
data.table
(
id
=
in.ids
,
cl
=
cutree
(
as.dendrogram
(
in.dend
),
k
=
in.k
))
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
=
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
# the number of rows is determined by dendrogram cut
getClCol
<-
function
(
in.dend
,
in.k
)
{
...
...
@@ -266,13 +308,17 @@ userDataGen <- function() {
cat
(
file
=
stderr
(),
'userDataGen: in\n'
)
locNtp
=
40
locNtracks
=
10
0
locNtracks
=
10
locNsites
=
4
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.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.arg = rep(seq(0, locNtp-1) / locNtp * 4 * pi, locNtracks * locNsites)
...
...
@@ -526,7 +572,9 @@ myPlotHeatmap <- function(data.arg,
# rowsep = 1:nrow(loc.dm),
cexRow
=
font.row.arg
,
cexCol
=
font.col.arg
,
main
=
title.arg
main
=
title.arg
,
symbreaks
=
FALSE
,
symkey
=
FALSE
)
return
(
loc.p
)
...
...
modules/tabBoxPlot.R
View file @
9bb17940
...
...
@@ -75,7 +75,9 @@ tabBoxPlot = function(input, output, session, in.data, in.fname = 'boxplotTP.pdf
out.dt
=
loc.dt
[
realtime
%in%
input
$
inSelTpts
]
loc.dt.aux
=
loc.dt
[
realtime
%in%
c
(
as.numeric
(
input
$
inSelTpts
)
-
input
$
slFoldChTp
)]
loc.y.prev
=
loc.dt.aux
[,
y
]
print
(
nrow
(
loc.dt.aux
))
print
(
nrow
(
out.dt
))
out.dt
[,
y.prev
:=
loc.y.prev
]
print
(
out.dt
)
out.dt
[,
y
:=
abs
(
y
/
y.prev
)]
...
...
modules/tabClHier.R
View file @
9bb17940
...
...
@@ -257,7 +257,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) {
cat
(
file
=
stderr
(),
'data4trajPlotCl: dt not NULL\n'
)
# 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'
)
# display only selected clusters
...
...
@@ -277,7 +277,7 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) {
},
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) {
return
(
NULL
)
}
loc.dt.cl
=
data.table
(
id
=
getDataTrackObjLabUni_afterTrim
(),
cl
=
cutree
(
as.dendrogram
(
loc.dend
),
k
=
input
$
inPlotHierNclust
))
# get cell id's with associated cluster numbers
loc.dt.cl
=
getDataCl
(
loc.dend
,
input
$
inPlotHierNclust
)
# get cellIDs with condition name
loc.dt.gr
=
getDataCond
()
...
...
modules/tabClHierSpar.R
View file @
9bb17940
...
...
@@ -222,8 +222,9 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
return
()
}
#cat('rownames: ', rownames(dm.t), '\n')
cat
(
'rownames: '
,
rownames
(
dm.t
),
'\n'
)
cat
(
'=============\ndimensions:'
,
dim
(
dm.t
),
'\n'
)
perm.out
<-
HierarchicalSparseCluster.permute
(
dm.t
,
wbounds
=
NULL
,
...
...
@@ -238,10 +239,16 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
method
=
s.cl.spar.linkage
[
as.numeric
(
input
$
selectPlotHierSparLinkage
)],
dissimilarity
=
s.cl.spar.diss
[
as.numeric
(
input
$
selectPlotHierSparDiss
)]
)
cat
(
'=============\nsparsehc:\n'
)
print
(
sparsehc
$
hc
)
return
(
sparsehc
)
})
# return dendrogram colour coded according to the cut level of the dendrogram
userFitDendHierSpar
<-
reactive
({
sparsehc
=
userFitHierSpar
()
if
(
is.null
(
sparsehc
))
{
...
...
@@ -249,6 +256,9 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
}
dend
<-
as.dendrogram
(
sparsehc
$
hc
)
cat
(
'=============\ncutree:\n'
,
dendextend
::
cutree
(
dend
,
input
$
inPlotHierSparNclust
,
order_clusters_as_data
=
TRUE
),
'\n'
)
dend
<-
color_branches
(
dend
,
col
=
rainbow_hcl
,
k
=
input
$
inPlotHierSparNclust
)
...
...
@@ -265,7 +275,10 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
if
(
is.null
(
loc.dend
))
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
# This will be used to display in UI for trajectory highlighting
getDataTrackObjLabUni_afterTrim
<-
reactive
({
cat
(
file
=
stderr
(),
'getDataTrackObjLabUni_afterTrim\n'
)
loc.dt
=
in.data4
trajPlo
t
()
loc.dt
=
in.data4
clus
t
()
if
(
is.null
(
loc.dt
))
return
(
NULL
)
else
return
(
unique
(
loc.dt
$
id
))
return
(
rownames
(
loc.dt
))
})
# return dt with cell IDs and their corresponding condition name
...
...
@@ -309,8 +322,17 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
cat
(
file
=
stderr
(),
'data4trajPlotClSpar: dt not NULL\n'
)
cat
(
'rownames: '
,
rownames
(
in.data4clust
()),
'\n'
)
# 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'
)
# display only selected clusters
...
...
@@ -331,7 +353,7 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
},
content
=
function
(
file
)
{
write.csv
(
x
=
getDataCl
(
userFitDendHierSpar
(),
input
$
inPlotHierSparNclust
,
getDataTrackObjLabUni_afterTrim
()),
file
=
file
,
row.names
=
FALSE
)
write.csv
(
x
=
getDataCl
Spar
(
userFitDendHierSpar
(),
input
$
inPlotHierSparNclust
,
getDataTrackObjLabUni_afterTrim
()),
file
=
file
,
row.names
=
FALSE
)
}
)
...
...
@@ -340,15 +362,14 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
cat
(
file
=
stderr
(),
'data4clSparDistPlot: in\n'
)
# get cell IDs with cluster assignments depending on dendrogram cut
loc.dend
<-
userFitHierSpar
()
loc.dend
<-
userFit
Dend
HierSpar
()
if
(
is.null
(
loc.dend
))
{
cat
(
file
=
stderr
(),
'plotClSparDist: loc.dend is NULL\n'
)
return
(
NULL
)
}
loc.dt.cl
=
data.table
(
id
=
getDataTrackObjLabUni_afterTrim
(),
cl
=
cutree
(
as.dendrogram
(
loc.dend
$
hc
),
k
=
input
$
inPlotHierSparNclust
))
# get cell id's with associated cluster numbers
loc.dt.cl
=
getDataClSpar
(
loc.dend
,
input
$
inPlotHierSparNclust
,
getDataTrackObjLabUni_afterTrim
())
# get cellIDs with condition name
loc.dt.gr
=
getDataCond
()
...
...
server.R
View file @
9bb17940
...
...
@@ -147,26 +147,29 @@ shinyServer(function(input, output, session) {
# In Coralie's case it's a combination of 3 columns called Stimulation_...
output
$
varSelGroup
=
renderUI
({
cat
(
file
=
stderr
(),
'UI varSelGroup\n'
)
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
]
if
(
input
$
chBgroup
)
{
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')
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
({
...
...
@@ -445,7 +448,9 @@ shinyServer(function(input, output, session) {
cat
(
file
=
stderr
(),
'dataMod: trajRem not NULL\n'
)
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
)
...
...
@@ -506,11 +511,20 @@ shinyServer(function(input, output, session) {
# create expression for parsing
# creates a merged column based on other columns from input
# used for grouping of plot facets
if
(
length
(
input
$
inSelGroup
)
==
0
)
return
(
NULL
)
loc.s.gr
=
sprintf
(
"paste(%s, sep=';')"
,
paste
(
input
$
inSelGroup
,
sep
=
''
,
collapse
=
','
))
if
(
input
$
chBgroup
)
{
if
(
length
(
input
$
inSelGroup
)
==
0
)
return
(
NULL
)
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
# Assign tracks selected for highlighting in UI
...
...
@@ -548,9 +562,6 @@ shinyServer(function(input, output, session) {
mid.in
=
mid.in
)]
# add 3rd level with status of track selection
# to a column with trajectory filtering status
if
(
locBut
)
{
...
...
@@ -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;
# NA's are already removed in tCourseSelected.csv
# Such datapoints are missing, therefore they require interpolation.
# If a row of long-format dt is removed, an NA appears after casting anyway if that grid point is missing)
# Remove NAs in data4clust()
loc.out
=
loc.out
[
complete.cases
(
loc.out
)]
# !!! Current issue with interpolation:
# The column mid.in is not taken into account.
# If a trajectory is selected in the UI,
# the mid.in column is added (if it doesn't already exist in the dataset),
# and for the interpolated point, it will still be NA. Not really an issue.
#
# 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)
if
(
input
$
chBtimeTrim
)
{
...
...
ui.R
View file @
9bb17940
...
...
@@ -51,7 +51,9 @@ shinyUI(fluidPage(
),
uiOutput
(
'varSelSite'
),
uiOutput
(
'varSelTrackLabel'
),
tags
$
hr
(),
checkboxInput
(
'chBgroup'
,
'Dataset contains grouping column (e.g. treatment, condition)'
,
TRUE
),
uiOutput
(
'varSelGroup'
),
uiOutput
(
'varSelTime'
),
uiOutput
(
'varSelMeas1'
),
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment