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
afea0ae1
Commit
afea0ae1
authored
Jun 11, 2019
by
majpark21
Browse files
Fix bug with AR periodogram, add rugs PSD plot, custom UI PSD
parent
09033ebd
Changes
2
Hide whitespace changes
Inline
Side-by-side
modules/auxfunc.R
View file @
afea0ae1
...
...
@@ -231,15 +231,28 @@ LOCcalcPSD <- function(in.dt,
in.return.period
=
TRUE
,
...
){
require
(
data.table
)
# Method "ar" returns $spec as matrix whereas "pgram" returns a vector, custom function to homogenze output format
mySpectrum
<-
function
(
x
,
...
){
args_spec
<-
list
(
x
=
x
,
plot
=
FALSE
)
inargs
<-
list
(
...
)
args_spec
[
names
(
inargs
)]
<-
inargs
out
<-
do.call
(
spectrum
,
args_spec
)
out
$
spec
<-
as.vector
(
out
$
spec
)
return
(
out
)
}
if
(
!
in.method
%in%
c
(
"pgram"
,
"ar"
)){
stop
(
'Method should be one of: c("pgram", "ar"'
)
}
dt_spec
<-
copy
(
in.dt
)
dt_spec
[,
c
(
"frequency"
,
"spec"
)
:=
(
spectrum
(
get
(
in.col.meas
),
plot
=
FALSE
,
method
=
in.method
,
...
)[
c
(
"freq"
,
"spec"
)]),
by
=
in.col.id
]
dt_agg
<-
dt_spec
[,
.
(
spec
=
mean
(
spec
)),
by
=
c
(
in.col.by
,
"frequency"
)]
dt_spec
<-
in.dt
[,
(
mySpectrum
(
get
(
in.col.meas
),
plot
=
FALSE
,
method
=
in.method
)[
c
(
"freq"
,
"spec"
)]),
by
=
in.col.id
]
dt_group
<-
in.dt
[,
.SD
[
1
,
get
(
in.col.by
)],
by
=
in.col.id
]
setnames
(
dt_group
,
"V1"
,
in.col.by
)
dt_spec
<-
merge
(
dt_spec
,
dt_group
,
by
=
in.col.id
)
dt_agg
<-
dt_spec
[,
.
(
spec
=
mean
(
spec
)),
by
=
c
(
in.col.by
,
"freq"
)]
if
(
in.return.period
){
dt_agg
[,
period
:=
1
/
freq
uency
]
dt_agg
[,
period
:=
1
/
freq
]
dt_agg
[,
frequency
:=
NULL
]
}
else
{
setnames
(
dt_agg
,
"freq"
,
"frequency"
)
}
return
(
dt_agg
)
}
...
...
@@ -689,15 +702,26 @@ LOCplotPSD <- function(dt.arg, # input data table
y.arg
,
# string with column name for y-axis
group.arg
=
NULL
,
# string with column name for grouping time series (here, it's a column corresponding to grouping by condition)
xlab.arg
=
x.arg
,
ylab.arg
=
y.arg
){
ylab.arg
=
y.arg
,
col.arg
=
NULL
){
require
(
ggplot2
)
if
(
length
(
setdiff
(
c
(
x.arg
,
y.arg
,
group.arg
),
colnames
(
dt.arg
)))
>
0
){
stop
(
paste
(
"Missing columns in dt.arg: "
,
setdiff
(
c
(
x.arg
,
y.arg
,
group.arg
),
colnames
(
dt.arg
))))
}
p.tmp
<-
ggplot
(
dt.arg
,
aes_string
(
x
=
x.arg
,
y
=
y.arg
))
+
geom_line
()
+
geom_rug
(
sides
=
"b"
,
alpha
=
1
,
color
=
"lightblue"
)
+
facet_wrap
(
group.arg
)
+
labs
(
x
=
xlab.arg
,
y
=
ylab.arg
)
if
(
is.null
(
col.arg
))
{
p.tmp
=
p.tmp
+
scale_color_discrete
(
name
=
''
)
}
else
{
p.tmp
=
p.tmp
+
scale_colour_manual
(
values
=
col.arg
,
name
=
''
)
}
return
(
p.tmp
)
}
...
...
modules/trajPsdPlot.R
View file @
afea0ae1
...
...
@@ -9,12 +9,16 @@ modPSDPlotUI = function(id, label = "Plot PSD of average trajectory.") {
column
(
3
,
checkboxInput
(
ns
(
'chBplotTrajInt'
),
'Interactive Plot'
),
radioButtons
(
ns
(
'rBlegendPos'
),
'Legend placement:'
,
list
(
'top'
=
'top'
,
'right'
=
'right'
)),
actionButton
(
ns
(
'butPlotTraj'
),
'Plot!'
)
),
column
(
3
,
sliderInput
(
ns
(
'sliPlotTrajSkip'
),
'Plot every n-th point:'
,
min
=
1
,
max
=
10
,
value
=
1
,
step
=
1
)
radioButtons
(
ns
(
'rBPSDmethod'
),
'Method for PSD estimation:'
,
list
(
'Smoothed Fourier'
=
'pgram'
,
'AR Fit'
=
'ar'
))
),
column
(
3
,
selectInput
(
ns
(
'inPSDlogtype'
),
'Log function:'
,
list
(
'log2'
=
'log2'
,
'log10'
=
'log10'
,
'ln'
=
'log'
)),
checkboxGroupInput
(
ns
(
'chBGPSDlogaxis'
),
'Log the axis:'
,
list
(
'x'
=
'x'
,
'y'
=
'y'
),
inline
=
TRUE
)
),
column
(
3
,
...
...
@@ -105,7 +109,7 @@ modPSDPlot = function(input, output, session,
# PSD plot - download pdf
callModule
(
downPlot
,
"downPlotTraj"
,
in.fname
=
in.fname
,
in.fname
=
in.fname
,
plotTraj
,
TRUE
)
plotTraj
<-
function
()
{
...
...
@@ -139,9 +143,9 @@ modPSDPlot = function(input, output, session,
else
loc.line.col.arg
=
NULL
# select every other point for plotting
loc.dt
=
loc.dt
[,
.SD
[
seq
(
1
,
.N
,
input
$
sliPlotTrajSkip
)],
by
=
id
]
# select every other point for plotting
(fixed for PSD because lead to false interpretation of PSD)
loc.dt
=
loc.dt
[,
.SD
[
seq
(
1
,
.N
,
1
)],
by
=
id
]
# check if columns with XY positions are present
if
(
sum
(
names
(
loc.dt
)
%like%
'pos'
)
==
2
)
locPos
=
TRUE
...
...
@@ -155,7 +159,6 @@ modPSDPlot = function(input, output, session,
locObjNum
=
FALSE
# If in.facet.color present,
# make sure to include the same number of colours in the palette,
# as the number of groups in dt.
...
...
@@ -182,25 +185,31 @@ modPSDPlot = function(input, output, session,
in.col.meas
=
'y'
,
in.col.id
=
'id'
,
in.col.by
=
in.facet
,
in.method
=
'pgram'
,
in.method
=
input
$
rBPSDmethod
,
in.return.period
=
TRUE
)
loc.dt.aggr
[,
(
in.facet
)
:=
as.factor
(
get
(
in.facet
))]
x_arg
<-
ifelse
(
'period'
%in%
colnames
(
loc.dt.aggr
),
'period'
,
'frequency'
)
x_arg_str
<-
paste0
(
toupper
(
substr
(
x_arg
,
1
,
1
)),
tolower
(
substring
(
x_arg
,
2
)))
# capitalized
p.out
<-
LOCplotPSD
(
dt.arg
=
loc.dt.aggr
,
x.arg
=
x_arg
,
y.arg
=
'spec'
,
group.arg
=
in.facet
,
xlab.arg
=
x_arg
,
col.arg
=
loc.facet.col
,
xlab.arg
=
x_arg_str
,
ylab.arg
=
''
)
+
LOCggplotTheme
(
in.font.base
=
PLOTFONTBASE
,
in.font.axis.text
=
PLOTFONTAXISTEXT
,
in.font.axis.title
=
PLOTFONTAXISTITLE
,
in.font.strip
=
PLOTFONTFACETSTRIP
,
in.font.legend
=
PLOTFONTLEGEND
)
+
theme
(
legend.position
=
input
$
rBlegendPos
)
in.font.legend
=
PLOTFONTLEGEND
)
if
(
"x"
%in%
input
$
chBGPSDlogaxis
){
p.out
<-
p.out
+
scale_x_continuous
(
trans
=
input
$
inPSDlogtype
)
+
xlab
(
paste0
(
input
$
inPSDlogtype
,
"("
,
x_arg_str
,
")"
))
}
if
(
"y"
%in%
input
$
chBGPSDlogaxis
){
p.out
<-
p.out
+
scale_y_continuous
(
trans
=
input
$
inPSDlogtype
)
}
return
(
p.out
)
}
}
\ No newline at end of file
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