Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
pertz-lab
shiny-timecourse-inspector
Commits
3f2d3136
Commit
3f2d3136
authored
Sep 27, 2019
by
dmattek
Browse files
Bug fixes
parent
f78cdc1a
Changes
15
Hide whitespace changes
Inline
Side-by-side
example-data/test-datasets/
simplest_wMissing_w1OutlierM
iddle.csv
→
example-data/test-datasets/
2traj_2missing_m
iddle.csv
View file @
3f2d3136
File moved
example-data/test-datasets/wide.csv
→
example-data/test-datasets/
3traj_5tpts_
wide.csv
View file @
3f2d3136
File moved
modules/auxfunc.R
View file @
3f2d3136
...
...
@@ -45,7 +45,7 @@ PLOTWIDTH = 85 # in percent
PLOTNFACETDEFAULT
=
3
# internal column names
COLRT
=
'
real
time'
COLRT
=
'time'
COLY
=
'y'
COLID
=
'id'
COLIDUNI
=
'trackObjectsLabelUni'
...
...
@@ -96,13 +96,14 @@ md_cols <- c(
# list of palettes for the heatmap
l.col.pal
=
list
(
"White-Orange-Red"
=
'OrRd'
,
"Yellow-Orange-Red"
=
'YlOrRd'
,
"Spectral"
=
'Spectral'
,
"Red-Yellow-Green"
=
'RdYlGn'
,
"Red-Yellow-Blue"
=
'RdYlBu'
,
"Greys"
=
"Greys"
,
"Reds"
=
"Reds"
,
"Oranges"
=
"Oranges"
,
"Greens"
=
"Greens"
,
"Blues"
=
"Blues"
,
"Spectral"
=
'Spectral'
"Blues"
=
"Blues"
)
# list of palettes for the dendrogram
...
...
@@ -115,23 +116,40 @@ l.col.pal.dend = list(
"Diverge HSV"
=
'diverge_hsv'
)
# list of palettes for the dendrogram
l.col.pal.dend.2
=
list
(
"Colorblind 10"
=
'Color Blind'
,
"Tableau 10"
=
'Tableau 10'
,
"Tableau 20"
=
'Tableau 20'
,
"Classic 10"
=
"Classic 10"
,
"Classic 20"
=
"Classic 20"
,
"Traffic 9"
=
'Traffic'
,
"Seattle Grays 5"
=
'Seattle Grays'
)
# Clustering algorithms ----
s.cl.linkage
=
c
(
"ward.D"
,
"ward.D2"
,
"single"
,
s.cl.linkage
=
c
(
"average"
,
"complete"
,
"average"
,
"mcquitty"
,
"centroid"
)
"single"
,
"centroid"
,
"ward.D"
,
"ward.D2"
,
"mcquitty"
)
s.cl.spar.linkage
=
c
(
"average"
,
"complete"
,
"single"
,
"centroid"
)
s.cl.diss
=
c
(
"euclidean"
,
"maximum"
,
"manhattan"
,
"canberra"
,
"binary"
,
"minkowski"
,
"DTW"
)
s.cl.spar.diss
=
c
(
"squared.distance"
,
"absolute.value"
)
s.cl.diss
=
c
(
"euclidean"
,
"maximum"
,
"manhattan"
,
"canberra"
,
"DTW"
)
s.cl.spar.diss
=
c
(
"squared.distance"
,
"absolute.value"
)
# Help text ----
...
...
@@ -159,20 +177,24 @@ helpPopup <- function(title, content,
}
help.text.short
=
c
(
'Load CSV file with a column of track IDs for removal. IDs should correspond to those used for plotting.'
,
'If the track ID is unique only within a group, make it unique globally by combining with the grouping column.'
,
'Interpolate missing time points and pre-existing NAs. The interval of the time column must be provided!'
,
'Load CSV file with 5 columns: grouping, start and end tpts of stimulation, start and end of y-position, dummy column with ID.'
,
'Select columns to group data according to treatment, condition, etc.'
,
'Select math operation to perform on a single or two columns,'
,
'Select range of time for further processing.'
,
'Divide measurments by the mean/median or calculate z-score with respect to selected time span.'
,
'Download time series after modification in this section.'
,
'Long format: a row is a single data point. Wide format: a row is a time series with columns as time points.'
,
'Fold-change or z-score with respect to selected time span.'
,
'Normalise with respect to this time span.'
,
'Calculate fold-change and z-score using the median and Median Absolute Deviation, instead of the mean and sd.'
,
'Normalise to mean/median of selected time calculated globally, per group, or for individual time series.'
'Load CSV file with a column of track IDs for removal. IDs should correspond to those used for plotting.'
,
#1
'If the track ID is unique only within a group, make it unique globally by combining with the grouping column.'
,
#2
'Interpolate missing time points and pre-existing NAs. The interval of the time column must be provided!'
,
#3
'Load CSV file with 5 columns: grouping, start and end tpts of stimulation, start and end of y-position, dummy column with ID.'
,
#4
'Select columns to group data according to treatment, condition, etc.'
,
#5
'Select math operation to perform on a single or two columns,'
,
#6
'Select range of time for further processing.'
,
#7
'Divide measurments by the mean/median or calculate z-score with respect to selected time span.'
,
#8
'Download time series after modification in this section.'
,
#9
'Long format: a row is a single data point. Wide format: a row is a time series with columns as time points.'
,
#10
'Fold-change or z-score with respect to selected time span.'
,
#11
'Normalise with respect to this time span.'
,
#12
'Calculate fold-change and z-score using the median and Median Absolute Deviation, instead of the mean and sd.'
,
#13
'Normalise to mean/median of selected time calculated globally, per group, or for individual time series.'
,
#14
'Instead of the value at a selected time point, y-axis can display a difference between values at time points on y- and x-axis.'
,
#15
'Add a line with linear regression and regions of 95% confidence interval.'
,
#16
'A number of time points left & right of selected time points; use the mean/min/max of values from these time points for the scatterplot.'
,
#17
'Operations to perform on values at time points selected in the field above.'
#18
)
# Functions for data processing ----
...
...
@@ -765,60 +787,41 @@ LOCplotPSD <- function(dt.arg, # input data table
return
(
p.tmp
)
}
# Plots a scatter plot with marginal histograms
# Points are connected by a line (grouping by cellID)
#
# Assumes an input of data.table with
# x, y - columns with x and y coordinates
# id - a unique point identifier (here corresponds to cellID)
# mid - a (0,1) column by which points are coloured (here corresponds to whether cells are within bounds)
LOCggplotScat
=
function
(
dt.arg
,
band.arg
=
NULL
,
#' Plot a scatter plot with an optional linear regression
#'
#' @param dt.arg input of data.table with 2 columns with x and y coordinates
#' @param facet.arg
#' @param facet.ncol.arg
#' @param xlab.arg
#' @param ylab.arg
#' @param plotlab.arg
#' @param alpha.arg
#' @param trend.arg
#' @param ci.arg
LOCggplotScat
=
function
(
dt.arg
,
facet.arg
=
NULL
,
facet.ncol.arg
=
2
,
xlab.arg
=
NULL
,
ylab.arg
=
NULL
,
plotlab.arg
=
NULL
,
alpha.arg
=
1
,
group.col.arg
=
NULL
)
{
p.tmp
=
ggplot
(
dt.arg
,
aes
(
x
=
x
,
y
=
y
))
trend.arg
=
T
,
ci.arg
=
0.95
)
{
if
(
is.null
(
group.col.arg
))
{
p.tmp
=
p.tmp
+
geom_point
(
alpha
=
alpha.arg
,
aes
(
group
=
id
))
}
else
{
p.tmp
=
p.tmp
+
geom_point
(
aes
(
colour
=
as.factor
(
get
(
group.col.arg
)),
group
=
id
),
alpha
=
alpha.arg
)
+
geom_path
(
aes
(
colour
=
as.factor
(
get
(
group.col.arg
)),
group
=
id
),
alpha
=
alpha.arg
)
+
scale_color_manual
(
name
=
group.col.arg
,
values
=
c
(
"FALSE"
=
rhg_cols
[
7
],
"TRUE"
=
rhg_cols
[
3
],
"SELECTED"
=
'green'
))
}
if
(
is.null
(
band.arg
))
p.tmp
=
ggplot
(
dt.arg
,
aes
(
x
=
x
,
y
=
y
))
+
geom_point
(
alpha
=
alpha.arg
)
if
(
trend.arg
)
{
p.tmp
=
p.tmp
+
stat_smooth
(
# method = function(formula, data, weights = weight)
# rlm(formula, data, weights = weight, method = 'MM'),
method
=
"lm"
,
fullrange
=
FALSE
,
level
=
0.95
,
level
=
ci.arg
,
colour
=
'blue'
)
else
{
p.tmp
=
p.tmp
+
geom_abline
(
slope
=
band.arg
$
a
,
intercept
=
band.arg
$
b
)
+
geom_abline
(
slope
=
band.arg
$
a
,
intercept
=
band.arg
$
b
+
abs
(
band.arg
$
b
)
*
band.arg
$
width
,
linetype
=
'dashed'
)
+
geom_abline
(
slope
=
band.arg
$
a
,
intercept
=
band.arg
$
b
-
abs
(
band.arg
$
b
)
*
band.arg
$
width
,
linetype
=
'dashed'
)
}
if
(
!
is.null
(
facet.arg
))
{
p.tmp
=
p.tmp
+
facet_wrap
(
as.formula
(
paste
(
"~"
,
facet.arg
)),
...
...
@@ -826,7 +829,6 @@ LOCggplotScat = function(dt.arg,
}
if
(
!
is.null
(
xlab.arg
))
p.tmp
=
p.tmp
+
xlab
(
paste0
(
xlab.arg
,
"\n"
))
...
...
@@ -839,8 +841,6 @@ LOCggplotScat = function(dt.arg,
p.tmp
=
p.tmp
+
ggtitle
(
paste0
(
plotlab.arg
,
"\n"
))
p.tmp
=
p.tmp
+
LOCggplotTheme
(
in.font.base
=
PLOTFONTBASE
,
in.font.axis.text
=
PLOTFONTAXISTEXT
,
...
...
@@ -849,10 +849,6 @@ LOCggplotScat = function(dt.arg,
in.font.legend
=
PLOTFONTLEGEND
)
+
theme
(
legend.position
=
"none"
)
# Marginal distributions don;t work with plotly...
# if (is.null(facet.arg))
# ggExtra::ggMarginal(p.scat, type = "histogram", bins = 100)
# else
return
(
p.tmp
)
}
...
...
modules/boxPlot.R
View file @
3f2d3136
...
...
@@ -28,7 +28,7 @@ modBoxPlotUI = function(id, label = "Plot Box-plots") {
4
,
selectInput
(
ns
(
'selPlotBoxLegendPos'
),
label
=
'
Select l
egend position'
,
label
=
'
L
egend position'
,
choices
=
list
(
"Top"
=
'top'
,
"Right"
=
'right'
,
...
...
@@ -76,10 +76,10 @@ modBoxPlotUI = function(id, label = "Plot Box-plots") {
# SERVER ----
modBoxPlot
=
function
(
input
,
output
,
session
,
in.data
,
in.cols
=
list
(
meas.x
=
'realtime'
,
meas.y
=
'y'
,
group
=
'group'
,
id
=
'id'
),
in.cols
=
list
(
meas.x
=
COLRT
,
meas.y
=
COLY
,
group
=
COLGR
,
id
=
COLID
),
in.fname
)
{
ns
<-
session
$
ns
...
...
@@ -108,7 +108,7 @@ modBoxPlot = function(input, output, session,
ns
<-
session
$
ns
if
(
!
(
'line'
%in%
input
$
inPlotType
))
sliderInput
(
ns
(
'inPlotBoxDodge'
),
'
Dodge serie
s:'
,
min
=
0
,
max
=
1
,
value
=
.4
,
step
=
0.05
)
sliderInput
(
ns
(
'inPlotBoxDodge'
),
'
Space between group
s:'
,
min
=
0
,
max
=
1
,
value
=
.4
,
step
=
0.05
)
})
output
$
uiPlotBoxWidth
=
renderUI
({
...
...
@@ -135,7 +135,7 @@ modBoxPlot = function(input, output, session,
ns
<-
session
$
ns
if
(
'dot'
%in%
input
$
inPlotType
)
sliderInput
(
ns
(
'inPlotDotNbins'
),
'
Dot-plot bin size (10^x)
:'
,
min
=
-4
,
max
=
4
,
value
=
-1.5
,
step
=
0.
1
)
sliderInput
(
ns
(
'inPlotDotNbins'
),
'
#Bins for dot-plot
:'
,
min
=
2
,
max
=
50
,
value
=
30
,
step
=
1
)
})
# Boxplot - display
...
...
@@ -206,30 +206,30 @@ modBoxPlot = function(input, output, session,
cat
(
file
=
stderr
(),
'plotBox:dt not NULL\n'
)
loc.par.dodge
<-
position_dodge
(
width
=
input
$
inPlotBoxDodge
)
p.out
=
ggplot
(
loc.dt
,
aes_string
(
x
=
sprintf
(
"factor(%s)"
,
in.cols
[[
'
meas.x
'
]]
),
y
=
in.cols
[[
'
meas.y
'
]]
))
p.out
=
ggplot
(
loc.dt
,
aes_string
(
x
=
sprintf
(
"factor(%s)"
,
in.cols
$
meas.x
),
y
=
in.cols
$
meas.y
))
if
(
'dot'
%in%
input
$
inPlotType
)
p.out
=
p.out
+
geom_dotplot
(
aes_string
(
fill
=
in.cols
[[
'group'
]]),
p.out
=
p.out
+
geom_dotplot
(
aes_string
(
fill
=
in.cols
[[
COLGR
]]),
color
=
NA
,
binaxis
=
"y"
,
binaxis
=
in.cols
$
meas.y
,
stackdir
=
"center"
,
position
=
loc.par.dodge
,
binwidth
=
10
^
(
input
$
inPlotDotNbins
),
binwidth
=
abs
(
max
(
loc.dt
[[
in.cols
$
meas.y
]],
na.rm
=
T
)
-
min
(
loc.dt
[[
in.cols
$
meas.y
]],
na.rm
=
T
))
/
(
input
$
inPlotDotNbins
-
1
),
method
=
'histodot'
)
if
(
'viol'
%in%
input
$
inPlotType
)
p.out
=
p.out
+
geom_violin
(
aes_string
(
fill
=
in.cols
[[
'group'
]]),
p.out
=
p.out
+
geom_violin
(
aes_string
(
fill
=
in.cols
[[
COLGR
]]),
position
=
loc.par.dodge
,
width
=
0.2
)
if
(
'line'
%in%
input
$
inPlotType
)
p.out
=
p.out
+
geom_path
(
aes_string
(
color
=
in.cols
[[
'group'
]],
group
=
in.cols
[[
'id'
]]))
+
facet_wrap
(
as.formula
(
paste
(
"~"
,
in.cols
[[
'group'
]])))
geom_path
(
aes_string
(
color
=
in.cols
[[
COLGR
]],
group
=
in.cols
[[
COLID
]]))
+
facet_wrap
(
as.formula
(
paste
(
"~"
,
in.cols
[[
COLGR
]])))
if
(
'box'
%in%
input
$
inPlotType
)
p.out
=
p.out
+
geom_boxplot
(
aes_string
(
fill
=
in.cols
[[
'group'
]]),
aes_string
(
fill
=
in.cols
[[
COLGR
]]),
position
=
loc.par.dodge
,
#width = 0.2, #input$inPlotBoxWidth,
notch
=
input
$
inPlotBoxNotches
,
...
...
modules/clDistPlot.R
View file @
3f2d3136
...
...
@@ -6,14 +6,14 @@
#
# UI ----
modClDistPlotUI
=
function
(
id
,
label
=
"Plot
Fractions Within Clusters
"
)
{
modClDistPlotUI
=
function
(
id
,
label
=
"Plot
distribution of clusters per groupd
"
)
{
ns
<-
NS
(
id
)
tagList
(
radioButtons
(
ns
(
"rBAxisLabelsRotate"
),
"X-axis labels:"
,
c
(
"horizontal"
=
0
,
"45 deg"
=
45
,
"90 deg"
=
90
)),
"90 deg"
=
90
)
,
inline
=
T
),
actionButton
(
ns
(
'butPlotClDist'
),
'Plot!'
),
plotOutput
(
ns
(
'outPlotClDist'
),
height
=
PLOTBOXHEIGHT
,
width
=
'auto'
),
downPlotUI
(
ns
(
'downPlotClDist'
),
"Download PDF"
)
...
...
@@ -66,7 +66,7 @@ modClDistPlot = function(input, output, session, in.data, in.cols = NULL, in.fna
p.out
=
p.out
+
scale_y_continuous
(
labels
=
percent
)
+
ylab
(
"Percentage of time-series\n"
)
+
xlab
(
""
)
+
xlab
(
"
Groups
"
)
+
LOCggplotTheme
(
in.font.base
=
PLOTFONTBASE
,
in.font.axis.text
=
PLOTFONTAXISTEXT
,
in.font.axis.title
=
PLOTFONTAXISTITLE
,
...
...
modules/dispStats.R
View file @
3f2d3136
...
...
@@ -10,7 +10,7 @@ modStatsUI = function(id, label = "Comparing t-points") {
ns
<-
NS
(
id
)
tagList
(
checkboxInput
(
ns
(
'chbTabStats'
),
'Show stats'
,
FALSE
),
checkboxInput
(
ns
(
'chbTabStats'
),
'Show stat
istic
s'
,
FALSE
),
uiOutput
(
ns
(
'uiTabStats'
)),
uiOutput
(
ns
(
'uiDownSingleCellData'
))
)
...
...
@@ -25,6 +25,8 @@ modStats = function(input, output, session,
ns
<-
session
$
ns
output
$
uiTabStats
=
renderUI
({
cat
(
file
=
stderr
(),
'modStats:uiTabStats\n'
)
ns
<-
session
$
ns
...
...
@@ -34,12 +36,13 @@ modStats = function(input, output, session,
}
})
output
$
uiDownSingleCellData
=
renderUI
({
cat
(
file
=
stderr
(),
'modStats:uiDownSingleCellData\n'
)
ns
<-
session
$
ns
if
(
input
$
chbTabStats
)
{
downloadButton
(
ns
(
'downloadData4BoxPlot'
),
'Download s
ingle-cell data
'
)
downloadButton
(
ns
(
'downloadData4BoxPlot'
),
'Download s
tats for individual time series
'
)
}
})
...
...
@@ -56,10 +59,9 @@ modStats = function(input, output, session,
'Mean'
=
mean
(
x
),
'CV'
=
sd
(
x
)
/
mean
(
x
),
'Median'
=
median
(
x
),
'rCV (IQR)'
=
IQR
(
x
)
/
median
(
x
),
'rCV (MAD)'
=
mad
(
x
)
/
median
(
x
))),
.SDcols
=
in.meascol
,
by
=
in.bycols
]
'rCV'
=
IQR
(
x
)
/
median
(
x
))),
.SDcols
=
in.meascol
,
by
=
in.bycols
]
setnames
(
loc.dt.aggr
,
c
(
in.bycols
,
'
N
'
,
'Mean'
,
'CV'
,
'Median'
,
'rCV
IQR'
,
'rCV MAD
'
))
setnames
(
loc.dt.aggr
,
c
(
in.bycols
,
'
nPoints
'
,
'Mean'
,
'CV'
,
'Median'
,
'rCV'
))
return
(
loc.dt.aggr
)
})
...
...
modules/dispTrackStats.R
View file @
3f2d3136
...
...
@@ -74,7 +74,7 @@ modTrackStats = function(input, output, session,
'measMean'
=
mean
(
x
,
na.rm
=
T
),
'measSD'
=
sd
(
x
,
na.rm
=
T
),
'measCV'
=
sd
(
x
,
na.rm
=
T
)
/
mean
(
x
,
na.rm
=
T
),
'measMedian'
=
median
(
x
,
na.rm
=
T
),
'measMedian'
=
median
(
as.double
(
x
)
,
na.rm
=
T
),
'measIQR'
=
IQR
(
x
,
na.rm
=
T
),
'meas_rCV_IQR'
=
IQR
(
x
,
na.rm
=
T
)
/
median
(
x
,
na.rm
=
T
))),
.SDcols
=
COLY
,
by
=
c
(
in.bycols
)]
...
...
@@ -96,10 +96,10 @@ modTrackStats = function(input, output, session,
by
=
c
(
in.bycols
,
COLID
)][,
.
(
tracksN
=
.N
,
tracksLenMean
=
mean
(
nTpts
),
tracksLenSD
=
sd
(
nTpts
),
tracksLenMedian
=
median
(
nTpts
),
tracksLenMedian
=
median
(
as.double
(
nTpts
)
)
,
tracksLenIQR
=
IQR
(
nTpts
)),
by
=
c
(
in.bycols
)]
setnames
(
loc.dt.aggr
,
c
(
in.bycols
,
'
#
Tracks'
,
'Mean'
,
'SD'
,
'Median'
,
'IQR'
))
setnames
(
loc.dt.aggr
,
c
(
in.bycols
,
'
n
Tracks'
,
'Mean'
,
'SD'
,
'Median'
,
'IQR'
))
return
(
loc.dt.aggr
)
})
...
...
modules/tabAUC.R
View file @
3f2d3136
...
...
@@ -39,7 +39,7 @@ modAUCplot = function(input, output, session, in.data, in.fname) {
if
(
is.null
(
loc.dt
))
return
(
NULL
)
else
return
(
unique
(
loc.dt
[[
'realtime'
]]))
return
(
unique
(
loc.dt
[[
COLRT
]]))
})
# UI for trimming x-axis (time)
...
...
@@ -72,7 +72,7 @@ modAUCplot = function(input, output, session, in.data, in.fname) {
if
(
is.null
(
loc.dt
))
return
(
NULL
)
else
{
loc.res
=
loc.dt
[
realtime
>=
input
$
slTimeTrim
[
1
]
&
realtime
<=
input
$
slTimeTrim
[
2
],
.
(
AUC
=
trapz
(
realtime
,
y
)),
by
=
.
(
group
,
id
)]
loc.res
=
loc.dt
[
get
(
COLRT
)
>=
input
$
slTimeTrim
[
1
]
&
get
(
COLRT
)
<=
input
$
slTimeTrim
[
2
],
.
(
AUC
=
trapz
(
get
(
COLRT
),
get
(
COLY
))),
by
=
c
(
COLGR
,
COLID
)]
return
(
loc.res
)
}
})
...
...
@@ -80,15 +80,15 @@ modAUCplot = function(input, output, session, in.data, in.fname) {
callModule
(
modStats
,
'dispStats'
,
in.data
=
AUCcells
,
in.meascol
=
'AUC'
,
in.bycols
=
c
(
'group'
)
,
in.bycols
=
COLGR
,
in.fname
=
'data4boxplotAUC.csv'
)
callModule
(
modBoxPlot
,
'boxPlot'
,
in.data
=
AUCcells
,
in.cols
=
list
(
meas.x
=
'group'
,
in.cols
=
list
(
meas.x
=
COLGR
,
meas.y
=
'AUC'
,
group
=
'group'
,
id
=
'id'
),
group
=
COLGR
,
id
=
COLID
),
in.fname
=
in.fname
)
...
...
modules/tabBoxPlot.R
View file @
3f2d3136
...
...
@@ -6,19 +6,22 @@
#
# UI ----
tabBoxPlotUI
=
function
(
id
,
label
=
"
Comparing t-
points"
)
{
tabBoxPlotUI
=
function
(
id
,
label
=
"
Snapshots at time
points"
)
{
ns
<-
NS
(
id
)
tagList
(
h4
(
"Box-/dot-/violin plot at selected t
-
points"
"Box-/dot-/violin plot
s
at selected t
ime
points"
),
br
(),
uiOutput
(
ns
(
'varSelTpts'
)),
checkboxInput
(
ns
(
'chBfoldCh'
),
'Fold change w.r.t. t-point:'
),
uiOutput
(
ns
(
'uiSlFoldChTp'
)),
# This is an experimental feature to re-normalise data points with respect to a selected time point
# Current implementation is limited; in the future slider should be replaced by an input field or a choice list.
# currenlty, if the selected time point is larger than the smallest time point for snapshot plotting, error appears.
#checkboxInput(ns('chBfoldCh'), 'Fold change w.r.t. t-point:'),
#uiOutput(ns('uiSlFoldChTp')),
modStatsUI
(
ns
(
'dispStats'
)),
br
(),
...
...
@@ -33,14 +36,14 @@ tabBoxPlot = function(input, output, session, in.data, in.fname) {
callModule
(
modStats
,
'dispStats'
,
in.data
=
data4boxPlot
,
in.meascol
=
'y'
,
in.bycols
=
c
(
'realtime'
,
'group'
),
in.bycols
=
c
(
COLRT
,
COLGR
),
in.fname
=
'data4boxplotTP.csv'
)
callModule
(
modBoxPlot
,
'boxPlot'
,
in.data
=
data4boxPlot
,
in.cols
=
list
(
meas.x
=
'realtime'
,
meas.y
=
'y'
,
group
=
'group'
,
in.cols
=
list
(
meas.x
=
COLRT
,
meas.y
=
COLY
,
group
=
COLGR
,
id
=
'id'
),
in.fname
=
in.fname
)
...
...
@@ -54,7 +57,7 @@ tabBoxPlot = function(input, output, session, in.data, in.fname) {
if
(
is.null
(
loc.dt
))
return
(
NULL
)
else
return
(
unique
(
loc.dt
[
,
realtime
]))
# column name specified in data4trajPlot
return
(
unique
(
loc.dt
[
[
COLRT
]
]))
# column name specified in data4trajPlot
})
output
$
uiSlFoldChTp
=
renderUI
({
...
...
@@ -75,23 +78,21 @@ tabBoxPlot = function(input, output, session, in.data, in.fname) {
if
(
is.null
(
loc.dt
))
return
(
NULL
)
if
(
input
$
chBfoldCh
)
{
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
)]
print
(
out.dt
)
out.dt
[,
y.prev
:=
NULL
]
print
(
out.dt
)
}
else
out.dt
=
loc.dt
[
realtime
%in%
input
$
inSelTpts
]
# This is part of re-nromalisation with respect to a time point.
# Test version here; works but needs improvements; see UI section
# if(input$chBfoldCh) {
# out.dt = loc.dt[get(COLRT) %in% input$inSelTpts]
# loc.dt.aux = loc.dt[get(COLRT) %in% c(as.numeric(input$inSelTpts) - input$slFoldChTp)]
# loc.y.prev = loc.dt.aux[, y]
#
# out.dt[, y.prev := loc.y.prev]
#
# out.dt[, y := abs(y / y.prev)]
#
# out.dt[, y.prev := NULL]
#
# } else
out.dt
=
loc.dt
[
get
(
COLRT
)
%in%
input
$
inSelTpts
]
return
(
out.dt
)
...
...
@@ -103,13 +104,14 @@ tabBoxPlot = function(input, output, session, in.data, in.fname) {
ns
<-
session
$
ns
loc.v
=
getDataTpts
()
if
(
!
is.null
(
loc.v
))
{
selectInput
(
ns
(
'inSelTpts'
),
'Select one or more t-points:'
,
loc.v
,
width
=
'100%'
,
selected
=
0
,
selected
=
loc.v
[[
1
]]
,
multiple
=
TRUE
)
}
...
...
modules/tabClHier.R
View file @
3f2d3136
...
...
@@ -9,23 +9,10 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") {
ns
<-
NS
(
id
)
tagList
(
h4
(
'Hierarchical clustering'
),
br
(),
fluidRow
(
column
(
4
,
selectInput
(
ns
(
"selectPlotHierLinkage"
),
label
=
(
"Select linkage method:"
),
choices
=
list
(
"Ward"
=
1
,
"Ward D2"
=
2
,
"Single"
=
3
,
"Complete"
=
4
,
"Average"
=
5
,
"McQuitty"
=
6
,
"Centroid"
=
7
),
selected
=
2
),
selectInput
(
ns
(
"selectPlotHierDiss"
),
label
=
(
"Select type of dissimilarity measure:"
),
...
...
@@ -33,10 +20,22 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") {
"Maximum"
=
2
,
"Manhattan"
=
3
,
"Canberra"
=
4
,
"Binary"
=
5
,
"Minkowski"
=
6
,
"DTW"
=
7
),
"DTW"
=
5
),
selected
=
1
),
selectInput
(
ns
(
"selectPlotHierLinkage"
),
label
=
(
"Select linkage method:"
),
choices
=
list
(
"Average"
=
1
,
"Complete"
=
2
,
"Single"
=
3
,
"Centroid"
=
4
,
"Ward"
=
5
,
"Ward D2"
=
6
,
"McQuitty"
=
7
),
selected
=
5
)
),