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
ef30c0f0
Commit
ef30c0f0
authored
Oct 08, 2019
by
dmattek
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Added debounce delay to sliders for time trimming and normalisation. Code rearrangements.
parent
1232aa7a
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
127 additions
and
101 deletions
+127
-101
server.R
server.R
+127
-101
No files found.
server.R
View file @
ef30c0f0
...
...
@@ -314,6 +314,7 @@ shinyServer(function(input, output, session) {
})
# UI-side-panel-trim x-axis (time) ----
output
$
uiSlTimeTrim
=
renderUI
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:uiSlTimeTrim\n'
)
...
...
@@ -337,7 +338,13 @@ shinyServer(function(input, output, session) {
)
}
})
})
# Return the value of slider for trimming time;
# output delayed by MILLIS
returnValSlTimeTrim
=
reactive
({
return
(
input
$
slTimeTrim
)
})
%>%
debounce
(
MILLIS
)
# UI-side-panel-normalization ----
...
...
@@ -389,6 +396,13 @@ shinyServer(function(input, output, session) {
}
})
# Return the value of slider for normalisation time;
# output delayed by MILLIS
returnValSlNormRtMinMax
=
reactive
({
return
(
input
$
slNormRtMinMax
)
})
%>%
debounce
(
MILLIS
)
# use robust stats (median instead of mean, mad instead of sd)
output
$
uiChBnormRobust
=
renderUI
({
if
(
DEB
)
...
...
@@ -432,6 +446,7 @@ shinyServer(function(input, output, session) {
# Processing-data ----
# Obtain data either from an upload or by generating a synthetic dataset
dataInBoth
<-
reactive
({
# Without direct references to inDataGen1,2 and inFileLoad, inDataGen2
# does not trigger running this reactive once inDataGen1 is used.
...
...
@@ -535,20 +550,9 @@ shinyServer(function(input, output, session) {
return
(
dm
)
})
# return column names of the main dt
getDataNucCols
<-
reactive
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:getDataNucCols: in\n'
)
loc.dt
=
dataInBoth
()
if
(
is.null
(
loc.dt
))
return
(
NULL
)
else
return
(
colnames
(
loc.dt
))
})
# return dt with an added column with unique track object label
# Return a dt with mods depending on UI options::
# - an added column with unique track object label created from the existing track id and prepended with columns chosen in the UI
# - removed track IDs based on a separate file uploaded; the file should contain a single column with a header and unique track IDs
dataMod
<-
reactive
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:dataMod\n'
)
...
...
@@ -562,11 +566,10 @@ shinyServer(function(input, output, session) {
# create unique track ID based on columns specified in input$inSelSite field and combine with input$inSelTrackLabel
loc.dt
[,
(
COLIDUNI
)
:=
do.call
(
paste
,
c
(
.SD
,
sep
=
"_"
)),
.SDcols
=
c
(
input
$
inSelSite
,
input
$
inSelTrackLabel
)
]
}
else
{
#
stay with
track ID provided in the loaded dataset; has to be unique
#
Leave
track ID provided in the loaded dataset; has to be unique
loc.dt
[,
(
COLIDUNI
)
:=
get
(
input
$
inSelTrackLabel
)]
}
# remove trajectories based on uploaded csv
if
(
input
$
chBtrajRem
)
{
if
(
DEB
)
...
...
@@ -576,44 +579,9 @@ shinyServer(function(input, output, session) {
loc.dt
=
loc.dt
[
!
(
trackObjectsLabelUni
%in%
loc.dt.rem
[[
1
]])]
}
# check if NAs present
return
(
loc.dt
)
})
# return all unique track object labels (created in dataMod)
# This will be used to display in UI for trajectory highlighting
getDataTrackObjLabUni
<-
reactive
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:getDataTrackObjLabUni\n'
)
loc.dt
=
dataMod
()
if
(
is.null
(
loc.dt
))
return
(
NULL
)
else
return
(
unique
(
loc.dt
$
trackObjectsLabelUni
))
})
# return all unique time points (real time)
# This will be used to display in UI for box-plot
# These timepoints are from the original dt and aren't affected by trimming of x-axis
getDataTpts
<-
reactive
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:getDataTpts\n'
)
loc.dt
=
dataMod
()
if
(
is.null
(
loc.dt
))
return
(
NULL
)
else
return
(
unique
(
loc.dt
[[
input
$
inSelTime
]]))
})
# prepare data for plotting time courses
# returns dt with these columns:
# realtime - selected from input
...
...
@@ -627,9 +595,9 @@ shinyServer(function(input, output, session) {
# (column created if mid.in present in uploaded data or tracks are selected in the UI)
# obj.num - created if ObjectNumber column present in the input data
# pos.x,y - created if columns with x and y positions present in the input data
data
4trajPlot
<-
reactive
({
data
Long
<-
reactive
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:data
4trajPlot
\n'
)
cat
(
file
=
stdout
(),
'server:data
Long
\n'
)
loc.dt
=
dataMod
()
if
(
is.null
(
loc.dt
))
...
...
@@ -672,7 +640,7 @@ shinyServer(function(input, output, session) {
loc.s.pos.y
=
names
(
loc.dt
)[
grep
(
'(L|l)ocation.*Y|(P|p)os.y|(P|p)osy'
,
names
(
loc.dt
))[
1
]]
if
(
DEB
)
cat
(
'server:data
4trajPlot
:\n Position columns: '
,
loc.s.pos.x
,
loc.s.pos.y
,
'\n'
)
cat
(
'server:data
Long
:\n Position columns: '
,
loc.s.pos.x
,
loc.s.pos.y
,
'\n'
)
if
(
!
is.na
(
loc.s.pos.x
)
&
!
is.na
(
loc.s.pos.y
))
locPos
=
TRUE
...
...
@@ -684,7 +652,7 @@ shinyServer(function(input, output, session) {
# 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
)[
grep
(
'(O|o)bject(N|n)umber'
,
names
(
loc.dt
))[
1
]]
#cat('data
4trajPlot
::loc.s.objnum ', loc.s.objnum, '\n')
#cat('data
Long
::loc.s.objnum ', loc.s.objnum, '\n')
if
(
is.na
(
loc.s.objnum
))
{
locObjNum
=
FALSE
}
...
...
@@ -756,7 +724,8 @@ shinyServer(function(input, output, session) {
# or the frame number metadata can be missing, as is the case for tCourseSelected files that already have realtime column.
# Therefore, we cannot rely on that info to get time frequency; user must provide this number!
# check if NA's present
# Check for explicit NA's in the measurement columns
# Has to be here (and not in dataMod()) because we need to know the name of the measurement column (COLY)
if
(
sum
(
is.na
(
loc.out
[[
COLY
]])))
createAlert
(
session
,
"alertAnchorSidePanelNAsPresent"
,
"alertNAsPresent"
,
title
=
"Warning"
,
content
=
helpText.server
[[
"alertNAsPresent"
]],
...
...
@@ -777,7 +746,7 @@ shinyServer(function(input, output, session) {
# x-check: print all rows with NA's
if
(
DEB
)
{
cat
(
file
=
stdout
(),
'server:data
4trajPlot
: Rows with NAs:\n'
)
cat
(
file
=
stdout
(),
'server:data
Long
: Rows with NAs:\n'
)
print
(
loc.out
[
rowSums
(
is.na
(
loc.out
))
>
0
,
])
}
...
...
@@ -817,7 +786,7 @@ shinyServer(function(input, output, session) {
## Trim x-axis (time)
if
(
input
$
chBtimeTrim
)
{
loc.out
=
loc.out
[
get
(
COLRT
)
>=
input
$
slTimeTrim
[[
1
]]
&
get
(
COLRT
)
<=
input
$
slTimeTrim
[[
2
]]
]
loc.out
=
loc.out
[
get
(
COLRT
)
>=
returnValSlTimeTrim
()[[
1
]]
&
get
(
COLRT
)
<=
returnValSlTimeTrim
()
[[
2
]]
]
}
## Normalization
...
...
@@ -827,15 +796,15 @@ shinyServer(function(input, output, session) {
in.dt
=
loc.out
,
in.meas.col
=
COLY
,
in.rt.col
=
COLRT
,
in.rt.min
=
input
$
slNormRtMinMax
[
1
],
in.rt.max
=
input
$
slNormRtMinMax
[
2
],
in.rt.min
=
returnValSlNormRtMinMax
()
[
1
],
in.rt.max
=
returnValSlNormRtMinMax
()
[
2
],
in.type
=
input
$
rBnormMeth
,
in.robust
=
input
$
chBnormRobust
,
in.by.cols
=
if
(
input
$
chBnormGroup
%in%
'none'
)
NULL
else
input
$
chBnormGroup
)
# Column with normalized data is renamed to the original name
# Further code assumes column name y produced by data
4trajPlot
# Further code assumes column name y produced by data
Long
loc.out
[,
c
(
COLY
)
:=
NULL
]
setnames
(
loc.out
,
'y.norm'
,
COLY
)
...
...
@@ -845,15 +814,15 @@ shinyServer(function(input, output, session) {
})
#
prepare data for
clustering
#
convert from long to wide; r
eturn a matrix with:
#
cells as column
s
#
time points as row
s
data
4clust
<-
reactive
({
#
Prepare data in wide format, ready for distance calculation in
clustering
#
R
eturn a matrix with:
#
- time series as row
s
#
- time points as column
s
data
Wide
<-
reactive
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:data
4clust
\n'
)
cat
(
file
=
stdout
(),
'server:data
Wide
\n'
)
loc.dt
=
data
4trajPlot
NoOut
()
loc.dt
=
data
Long
NoOut
()
if
(
is.null
(
loc.dt
))
return
(
NULL
)
...
...
@@ -871,53 +840,99 @@ shinyServer(function(input, output, session) {
# assign row names to the matrix
rownames
(
loc.m.out
)
=
loc.rownames
# Check for missing time points
# Missing rows in the long format give rise to NAs during dcast
# Here, we are not checking for explicit NAs in COLY column
if
((
sum
(
is.na
(
loc.dt
[[
COLY
]]))
==
0
)
&
(
sum
(
is.na
(
loc.dt.wide
))
>
0
))
{
createAlert
(
session
,
"alertAnchorSidePanelNAsPresent"
,
"alertNAsPresentLong2WideConv"
,
title
=
"Warning"
,
content
=
helpText.server
[[
"alertNAsPresentLong2WideConv"
]],
append
=
FALSE
,
style
=
"warning"
)
}
else
{
closeAlert
(
session
,
"alertNAsPresentLong2WideConv"
)
}
return
(
loc.m.out
)
})
#
p
repare data with stimulation pattern
#
t
his dataset is displayed underneath of trajectory plot (modules/trajPlot.R) as geom_segment
data
4stimPlot
<-
reactive
({
#
P
repare data with stimulation pattern
#
T
his dataset is displayed underneath of trajectory plot (modules/trajPlot.R) as geom_segment
data
Stim
<-
reactive
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:data
4stimPlot
\n'
)
cat
(
file
=
stdout
(),
'server:data
Stim
\n'
)
if
(
input
$
chBstim
)
{
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:data
4stimPlot
: stim not NULL\n'
)
cat
(
file
=
stdout
(),
'server:data
Stim
: stim not NULL\n'
)
loc.dt.stim
=
dataLoadStim
()
return
(
loc.dt.stim
)
}
else
{
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:data
4stimPlot
: stim is NULL\n'
)
cat
(
file
=
stdout
(),
'server:data
Stim
: stim is NULL\n'
)
return
(
NULL
)
}
})
# prepare y-axis label in time series plots, depending on UI setting
# Return all unique track object labels (created in dataMod)
# Used to display track IDs in UI for trajectory highlighting
getDataTrackObjLabUni
<-
reactive
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:getDataTrackObjLabUni\n'
)
loc.dt
=
dataMod
()
if
(
is.null
(
loc.dt
))
return
(
NULL
)
else
return
(
unique
(
loc.dt
[[
COLIDUNI
]]))
})
createYaxisLabel
=
reactive
({
locLabel
=
input
$
inSelMeas1
# Return all unique time points (real time)
# Used to set limits of sliders for trimming time and for normalisation
# These timepoints are from the original dt and aren't affected by trimming of x-axis
getDataTpts
<-
reactive
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:getDataTpts\n'
)
loc.dt
=
dataMod
()
if
(
is.null
(
loc.dt
))
return
(
NULL
)
else
return
(
unique
(
loc.dt
[[
input
$
inSelTime
]]))
})
# Return column names of the main dt
# Used to fill UI input fields with a choice of column names
getDataNucCols
<-
reactive
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:getDataNucCols: in\n'
)
return
(
locLabel
)
loc.dt
=
dataInBoth
()
if
(
is.null
(
loc.dt
))
return
(
NULL
)
else
return
(
colnames
(
loc.dt
))
})
# download data as prepared for plotting
# after all modification
output
$
downloadDataClean
<-
downloadHandler
(
filename
=
FCSVTCCLEAN
,
content
=
function
(
file
)
{
write.csv
(
data4trajPlotNoOut
(),
file
,
row.names
=
FALSE
)
}
)
# Unfinished f-n!
# prepare y-axis label in time series plots, depending on UI setting
createYaxisLabel
=
reactive
({
locLabel
=
input
$
inSelMeas1
return
(
locLabel
)
})
# Plotting-trajectories ----
# UI for selecting trajectories
# The output data table of data
4trajPlot
is modified based on inSelHighlight field
# The output data table of data
Long
is modified based on inSelHighlight field
output
$
varSelHighlight
=
renderUI
({
if
(
DEB
)
cat
(
file
=
stdout
(),
'server:varSelHighlight\n'
)
...
...
@@ -938,44 +953,55 @@ shinyServer(function(input, output, session) {
}
})
# Modules within main window ----
# download data as prepared for plotting
# after all modification
output
$
downloadDataClean
<-
downloadHandler
(
filename
=
FCSVTCCLEAN
,
content
=
function
(
file
)
{
write.csv
(
dataLongNoOut
(),
file
,
row.names
=
FALSE
)
}
)
# Taking out outliers
data
4trajPlotNoOut
=
callModule
(
modSelOutliers
,
'returnOutlierIDs'
,
data4trajPlot
)
data
LongNoOut
=
callModule
(
modSelOutliers
,
'returnOutlierIDs'
,
dataLong
)
# Trajectory plotting - ribbon
callModule
(
modTrajRibbonPlot
,
'modTrajRibbon'
,
in.data
=
data
4trajPlot
NoOut
,
in.data.stim
=
data
4stimPlot
,
in.data
=
data
Long
NoOut
,
in.data.stim
=
data
Stim
,
in.fname
=
function
()
return
(
FPDFTCMEAN
))
# Trajectory plotting - individual
callModule
(
modTrajPlot
,
'modTrajPlot'
,
in.data
=
data
4trajPlot
NoOut
,
in.data.stim
=
data
4stimPlot
,
in.data
=
data
Long
NoOut
,
in.data.stim
=
data
Stim
,
in.fname
=
function
()
{
return
(
FPDFTCSINGLE
)},
in.ylab
=
createYaxisLabel
)
# Trajectory plotting - PSD
callModule
(
modPSDPlot
,
'modPSDPlot'
,
in.data
=
data
4trajPlot
NoOut
,
in.data
=
data
Long
NoOut
,
in.fname
=
function
()
{
return
(
FPDFTCPSD
)})
# Tabs ----
###### AUC calculation and plotting
callModule
(
tabAUCplot
,
'tabAUC'
,
data
4trajPlot
NoOut
,
in.fname
=
function
()
return
(
FPDFBOXAUC
))
callModule
(
tabAUCplot
,
'tabAUC'
,
data
Long
NoOut
,
in.fname
=
function
()
return
(
FPDFBOXAUC
))
###### Box-plot
callModule
(
tabDistPlot
,
'tabDistPlot'
,
data
4trajPlot
NoOut
,
in.fname
=
function
()
return
(
FPDFBOXTP
))
callModule
(
tabDistPlot
,
'tabDistPlot'
,
data
Long
NoOut
,
in.fname
=
function
()
return
(
FPDFBOXTP
))
###### Scatter plot
callModule
(
tabScatterPlot
,
'tabScatter'
,
data
4trajPlot
NoOut
,
in.fname
=
function
()
return
(
FPDFSCATTER
))
callModule
(
tabScatterPlot
,
'tabScatter'
,
data
Long
NoOut
,
in.fname
=
function
()
return
(
FPDFSCATTER
))
##### Hierarchical
estim
ation
callModule
(
clustValid
,
'tabClValid'
,
data
4clust
)
##### Hierarchical
valid
ation
callModule
(
clustValid
,
'tabClValid'
,
data
Wide
)
##### Hierarchical clustering
callModule
(
clustHier
,
'tabClHier'
,
data
4clust
,
data4trajPlotNoOut
,
data4stimPlot
)
callModule
(
clustHier
,
'tabClHier'
,
data
Wide
,
dataLongNoOut
,
dataStim
)
##### Sparse hierarchical clustering using sparcl
callModule
(
clustHierSpar
,
'tabClHierSpar'
,
data
4clust
,
data4trajPlotNoOut
,
data4stimPlot
)
callModule
(
clustHierSpar
,
'tabClHierSpar'
,
data
Wide
,
dataLongNoOut
,
dataStim
)
})
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