Commit afea0ae1 authored by majpark21's avatar majpark21
Browse files

Fix bug with AR periodogram, add rugs PSD plot, custom UI PSD

parent 09033ebd
......@@ -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/frequency]
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)
}
......
......@@ -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
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