In order to mitigate against the brute force attacks against Gitlab accounts, we are moving to all edu-ID Logins. We would like to remind you to link your account with your edu-id. Login will be possible only by edu-ID after November 30, 2021. Here you can find the instructions for linking your account.

If you don't have a SWITCH edu-ID, you can create one with this guide here

kind regards

This Server has been upgraded to GitLab release 14.2.6

Commit 5a175891 authored by dmattek's avatar dmattek
Browse files

Moved several functions to tca package

parent e102708a
...@@ -23,6 +23,20 @@ Following packages need to be installed in order to run the app locally: ...@@ -23,6 +23,20 @@ Following packages need to be installed in order to run the app locally:
Install packages using `install.packages('name_of_the_package_from_the_list_above')` command in RStudio command line. Install packages using `install.packages('name_of_the_package_from_the_list_above')` command in RStudio command line.
**Additionally**, a time series analysis package need to be installed from [GitHub](https://github.com/dmattek/tca-package):
```
install_github("dmattek/tca-package")
```
The `install_github` function is available in *devtools* package:
```
install.packages("devtools")
library(devtools)
```
#### Input file #### Input file
The app recognizes CSV (comma-separated values) files: data columns separated by a comma, floating point numbers using a dot (full-stop). The app recognizes CSV (comma-separated values) files: data columns separated by a comma, floating point numbers using a dot (full-stop).
......
...@@ -95,7 +95,7 @@ help.text = c( ...@@ -95,7 +95,7 @@ help.text = c(
Say, the main data file contains columns Metadata_Site and TrackLabel. Say, the main data file contains columns Metadata_Site and TrackLabel.
These two columns should be then selected in UI to form a unique cell ID, e.g. 001_0001 where former part corresponds to Metadata_Site and the latter to TrackLabel.', These two columns should be then selected in UI to form a unique cell ID, e.g. 001_0001 where former part corresponds to Metadata_Site and the latter to TrackLabel.',
'Plotting and data processing requires a unique cell ID across entire dataset. A typical dataset from CellProfiler assigns unique cell ID (TrackLabel) within each field of view (Metadata_Site). 'Plotting and data processing requires a unique cell ID across entire dataset. A typical dataset from CellProfiler assigns unique cell ID (TrackLabel) within each field of view (Metadata_Site).
Therefore, a unique ID is created by concatenating these two columns. If the dataset already contains a unique ID, check this box and select a single column only.' Therefore, a unique ID is created by concatenating these two columns. If the dataset already contains a unique ID, UNcheck this box and select a single column only.'
) )
...@@ -317,41 +317,6 @@ myGgplotTraj = function(dt.arg, # data table ...@@ -317,41 +317,6 @@ myGgplotTraj = function(dt.arg, # data table
} }
userDataGen <- function() {
cat(file=stderr(), 'userDataGen: in\n')
locNtp = 60
locNtracks = 10
locNsites = 6
locNwells = 1
x.rand.1 = c(rnorm(locNtp * locNtracks * locNsites * 1/3, 0.5, 0.1), rnorm(locNtp * locNtracks * locNsites * 1/3, 1, 0.2), rnorm(locNtp * locNtracks * locNsites * 1/3, 2, 0.5))
x.rand.2 = c(rnorm(locNtp * locNtracks * locNsites * 1/3, 0.25, 0.1), rnorm(locNtp * locNtracks * locNsites * 1/3, 0.5, 0.2), rnorm(locNtp * locNtracks * locNsites * 1/3, 1, 0.2))
# 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)
x.arg = rep(seq(1, locNtp), locNtracks * locNsites)
dt.nuc = data.table(Metadata_Site = rep(1:locNsites, each = locNtp * locNtracks),
Metadata_Well = rep(1:locNwells, each = locNtp * locNsites * locNtracks / locNwells),
Metadata_RealTime = x.arg,
objCyto_Intensity_MeanIntensity_imErkCor = x.rand.1,
objNuc_Intensity_MeanIntensity_imErkCor = x.rand.2,
objNuc_Location_X = runif(locNtp * locNtracks * locNsites, min = 0, max = 1),
objNuc_Location_Y = runif(locNtp * locNtracks * locNsites, min = 0, max = 1),
# objCyto_Intensity_MeanIntensity_imErkCor = x.rand.3 + ifelse(x.arg < 4, 0, 1) / x.rand.3,
# objNuc_Intensity_MeanIntensity_imErkCor = c(rnorm(locNtp * locNtracks * locNsites * 0.5, .25, 0.1), rnorm(locNtp * locNtracks * locNsites * 0.5, .5, 0.2)),
TrackLabel = rep(1:(locNtracks*locNsites), each = locNtp))
return(dt.nuc)
}
# Fast DTW computation # Fast DTW computation
fastDTW <-function (x) fastDTW <-function (x)
{ {
...@@ -359,65 +324,6 @@ fastDTW <-function (x) ...@@ -359,65 +324,6 @@ fastDTW <-function (x)
} }
# Returns original dt with an additional column with normalized quantity.
# The column to be normalised is given by 'in.meas.col'.
# The name of additional column is the same as in.meas.col but with ".norm" suffix added.
# Normalisation is based on part of the trajectory;
# this is defined by in.rt.min and max, and the column with time in.rt.col.
# Additional parameters:
# in.by.cols - character vector with 'by' columns to calculate normalisation per group
# if NULL, no grouping is done
# in.robust - whether robust measures should be used (median instead of mean, mad instead of sd)
# in.type - type of normalization: z.score or mean (fi.e. old change w.r.t. mean)
myNorm = function(in.dt,
in.meas.col,
in.rt.col = 'RealTime',
in.rt.min = 10,
in.rt.max = 20,
in.by.cols = NULL,
in.robust = TRUE,
in.type = 'z.score') {
loc.dt <-
copy(in.dt) # copy so as not to alter original dt object w intermediate assignments
if (is.null(in.by.cols)) {
if (in.robust)
loc.dt.pre.aggr = loc.dt[get(in.rt.col) >= in.rt.min &
get(in.rt.col) <= in.rt.max, .(meas.md = median(get(in.meas.col), na.rm = TRUE),
meas.mad = mad(get(in.meas.col), na.rm = TRUE))]
else
loc.dt.pre.aggr = loc.dt[get(in.rt.col) >= in.rt.min &
get(in.rt.col) <= in.rt.max, .(meas.md = mean(get(in.meas.col), na.rm = TRUE),
meas.mad = sd(get(in.meas.col), na.rm = TRUE))]
loc.dt = cbind(loc.dt, loc.dt.pre.aggr)
} else {
if (in.robust)
loc.dt.pre.aggr = loc.dt[get(in.rt.col) >= in.rt.min &
get(in.rt.col) <= in.rt.max, .(meas.md = median(get(in.meas.col), na.rm = TRUE),
meas.mad = mad(get(in.meas.col), na.rm = TRUE)), by = in.by.cols]
else
loc.dt.pre.aggr = loc.dt[get(in.rt.col) >= in.rt.min &
get(in.rt.col) <= in.rt.max, .(meas.md = mean(get(in.meas.col), na.rm = TRUE),
meas.mad = sd(get(in.meas.col), na.rm = TRUE)), by = in.by.cols]
loc.dt = merge(loc.dt, loc.dt.pre.aggr, by = in.by.cols)
}
if (in.type == 'z.score') {
loc.dt[, meas.norm := (get(in.meas.col) - meas.md) / meas.mad]
} else {
loc.dt[, meas.norm := (get(in.meas.col) / meas.md)]
}
setnames(loc.dt, 'meas.norm', paste0(in.meas.col, '.norm'))
loc.dt[, c('meas.md', 'meas.mad') := NULL]
return(loc.dt)
}
# Plots a scatter plot with marginal histograms # Plots a scatter plot with marginal histograms
# Points are connected by a line (grouping by cellID) # Points are connected by a line (grouping by cellID)
# #
......
...@@ -6,6 +6,11 @@ modAUCplotUI = function(id, label = "Plot Area Under Curves") { ...@@ -6,6 +6,11 @@ modAUCplotUI = function(id, label = "Plot Area Under Curves") {
ns <- NS(id) ns <- NS(id)
tagList( tagList(
h4(
"Calculate area under curve and plot per group"
),
br(),
uiOutput(ns('uiSlTimeTrim')), uiOutput(ns('uiSlTimeTrim')),
modStatsUI(ns('dispStats')), modStatsUI(ns('dispStats')),
br(), br(),
......
...@@ -148,12 +148,12 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") { ...@@ -148,12 +148,12 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") {
plotOutput(ns('outPlotHier')) plotOutput(ns('outPlotHier'))
), ),
tabPanel('Time-courses',
modTrajPlotUI(ns('modPlotHierTraj'))),
tabPanel('Averages', tabPanel('Averages',
modTrajRibbonPlotUI(ns('modPlotHierTrajRibbon'))), modTrajRibbonPlotUI(ns('modPlotHierTrajRibbon'))),
tabPanel('Time-courses',
modTrajPlotUI(ns('modPlotHierTraj'))),
tabPanel('Cluster dist.', tabPanel('Cluster dist.',
modClDistPlotUI(ns('hierClDistPlot'), 'xxx')) modClDistPlotUI(ns('hierClDistPlot'), 'xxx'))
......
...@@ -159,8 +159,12 @@ clustHierSparUI <- function(id, label = "Sparse Hierarchical CLustering") { ...@@ -159,8 +159,12 @@ clustHierSparUI <- function(id, label = "Sparse Hierarchical CLustering") {
plotOutput(ns('outPlotHierSpar')) plotOutput(ns('outPlotHierSpar'))
), ),
tabPanel('Averages',
modTrajRibbonPlotUI(ns('modPlotHierSparTrajRibbon'))),
tabPanel('Time-courses', tabPanel('Time-courses',
modTrajPlotUI(ns('modPlotHierSparTraj'))), modTrajPlotUI(ns('modPlotHierSparTraj'))),
tabPanel('Cluster dist.', tabPanel('Cluster dist.',
modClDistPlotUI(ns('hierClSparDistPlot'))) modClDistPlotUI(ns('hierClSparDistPlot')))
) )
...@@ -222,9 +226,9 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -222,9 +226,9 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
return() return()
} }
#cat('rownames: ', rownames(dm.t), '\n')
#cat('=============\ndimensions:', dim(dm.t), '\n')
cat('rownames: ', rownames(dm.t), '\n')
cat('=============\ndimensions:', dim(dm.t), '\n')
perm.out <- HierarchicalSparseCluster.permute( perm.out <- HierarchicalSparseCluster.permute(
dm.t, dm.t,
wbounds = NULL, wbounds = NULL,
...@@ -240,8 +244,8 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -240,8 +244,8 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
dissimilarity = s.cl.spar.diss[as.numeric(input$selectPlotHierSparDiss)] dissimilarity = s.cl.spar.diss[as.numeric(input$selectPlotHierSparDiss)]
) )
cat('=============\nsparsehc:\n') #cat('=============\nsparsehc:\n')
print(sparsehc$hc) #print(sparsehc$hc)
return(sparsehc) return(sparsehc)
}) })
...@@ -257,7 +261,7 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -257,7 +261,7 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
dend <- as.dendrogram(sparsehc$hc) dend <- as.dendrogram(sparsehc$hc)
cat('=============\ncutree:\n', dendextend::cutree(dend, input$inPlotHierSparNclust, order_clusters_as_data = TRUE), '\n') #cat('=============\ncutree:\n', dendextend::cutree(dend, input$inPlotHierSparNclust, order_clusters_as_data = TRUE), '\n')
dend <- color_branches(dend, dend <- color_branches(dend,
col = rainbow_hcl, col = rainbow_hcl,
...@@ -322,7 +326,7 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo ...@@ -322,7 +326,7 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
cat(file = stderr(), 'data4trajPlotClSpar: dt not NULL\n') cat(file = stderr(), 'data4trajPlotClSpar: dt not NULL\n')
cat('rownames: ', rownames(in.data4clust()), '\n') #cat('rownames: ', rownames(in.data4clust()), '\n')
# get cellIDs with cluster assignments based on dendrogram cut # get cellIDs with cluster assignments based on dendrogram cut
loc.dt.cl = getDataClSpar(userFitDendHierSpar(), input$inPlotHierSparNclust, getDataTrackObjLabUni_afterTrim()) loc.dt.cl = getDataClSpar(userFitDendHierSpar(), input$inPlotHierSparNclust, getDataTrackObjLabUni_afterTrim())
......
...@@ -45,7 +45,11 @@ modTrajRibbonPlotUI = function(id, label = "Plot Individual Time Series") { ...@@ -45,7 +45,11 @@ modTrajRibbonPlotUI = function(id, label = "Plot Individual Time Series") {
} }
modTrajRibbonPlot = function(input, output, session, in.data, in.facet = 'group', in.facet.color = NULL, in.fname = 'tCourses.pdf') { modTrajRibbonPlot = function(input, output, session,
in.data,
in.facet = 'group',
in.facet.color = NULL,
in.fname = 'tCoursesMeans.pdf') {
ns <- session$ns ns <- session$ns
...@@ -166,7 +170,7 @@ modTrajRibbonPlot = function(input, output, session, in.data, in.facet = 'group' ...@@ -166,7 +170,7 @@ modTrajRibbonPlot = function(input, output, session, in.data, in.facet = 'group'
loc.facet.col = loc.facet.col[loc.groups] loc.facet.col = loc.facet.col[loc.groups]
} }
loc.dt.aggr = calcTrajCI(in.dt = loc.dt, loc.dt.aggr = tca::calcTrajCI(in.dt = loc.dt,
in.col.meas = 'y', in.col.meas = 'y',
in.col.by = c(in.facet, 'realtime'), in.col.by = c(in.facet, 'realtime'),
in.type = 'normal') in.type = 'normal')
...@@ -181,22 +185,6 @@ modTrajRibbonPlot = function(input, output, session, in.data, in.facet = 'group' ...@@ -181,22 +185,6 @@ modTrajRibbonPlot = function(input, output, session, in.data, in.facet = 'group'
xlab.arg = 'Time (min)', xlab.arg = 'Time (min)',
ylab.arg = '') ylab.arg = '')
# p.out = myGgplotTraj(
# dt.arg = loc.dt,
# x.arg = 'realtime',
# y.arg = 'y',
# group.arg = "id",
# facet.arg = in.facet,
# facet.ncol.arg = input$inPlotTrajFacetNcol,
# facet.color.arg = loc.facet.col,
# xlab.arg = 'Time (min)',
# line.col.arg = loc.line.col.arg,
# aux.label1 = if (locPos) 'pos.x' else NULL,
# aux.label2 = if (locPos) 'pos.y' else NULL,
# aux.label3 = if (locObjNum) 'obj.num' else NULL,
# stat.arg = input$chBPlotTrajStat
# )
return(p.out) return(p.out)
} }
} }
\ No newline at end of file
...@@ -21,6 +21,7 @@ library(sparcl) # sparse hierarchical and k-means ...@@ -21,6 +21,7 @@ library(sparcl) # sparse hierarchical and k-means
library(scales) # for percentages on y scale library(scales) # for percentages on y scale
library(dtw) # for dynamic time warping library(dtw) # for dynamic time warping
library(imputeTS) # for interpolating NAs library(imputeTS) # for interpolating NAs
library(tca) # for time series manipulatiom, e.g. normTraj, genTraj, plotTrajRibbon
# increase file upload limit # increase file upload limit
options(shiny.maxRequestSize = 200 * 1024 ^ 2) options(shiny.maxRequestSize = 200 * 1024 ^ 2)
...@@ -53,7 +54,7 @@ shinyServer(function(input, output, session) { ...@@ -53,7 +54,7 @@ shinyServer(function(input, output, session) {
dataGen1 <- eventReactive(input$inDataGen1, { dataGen1 <- eventReactive(input$inDataGen1, {
cat("dataGen1\n") cat("dataGen1\n")
return(userDataGen()) return(tca::genTraj(in.nwells = 3))
}) })
# load main data file # load main data file
...@@ -171,7 +172,7 @@ shinyServer(function(input, output, session) { ...@@ -171,7 +172,7 @@ shinyServer(function(input, output, session) {
output$varSelSite = renderUI({ output$varSelSite = renderUI({
cat(file = stderr(), 'UI varSelSite\n') cat(file = stderr(), 'UI varSelSite\n')
if (!input$chBtrackUni) { if (input$chBtrackUni) {
locCols = getDataNucCols() locCols = getDataNucCols()
locColSel = locCols[grep('(S|s)ite|(S|s)eries', locCols)[1]] # index 1 at the end in case more matches; select 1st locColSel = locCols[grep('(S|s)ite|(S|s)eries', locCols)[1]] # index 1 at the end in case more matches; select 1st
...@@ -339,13 +340,6 @@ shinyServer(function(input, output, session) { ...@@ -339,13 +340,6 @@ shinyServer(function(input, output, session) {
#### ####
## data processing ## data processing
# generate random dataset 1
dataGen1 <- eventReactive(input$inDataGen1, {
cat("dataGen1\n")
return(userDataGen())
})
dataInBoth <- reactive({ dataInBoth <- reactive({
# Without direct references to inDataGen1,2 and inFileLoad, inDataGen2 # Without direct references to inDataGen1,2 and inFileLoad, inDataGen2
# does not trigger running this reactive once inDataGen1 is used. # does not trigger running this reactive once inDataGen1 is used.
...@@ -412,7 +406,7 @@ shinyServer(function(input, output, session) { ...@@ -412,7 +406,7 @@ shinyServer(function(input, output, session) {
if (is.null(loc.dt)) if (is.null(loc.dt))
return(NULL) return(NULL)
if (!input$chBtrackUni) { if (input$chBtrackUni) {
loc.types = lapply(loc.dt, class) loc.types = lapply(loc.dt, class)
if(loc.types[[input$inSelTrackLabel]] %in% c('numeric', 'integer') & loc.types[[input$inSelSite]] %in% c('numeric', 'integer')) if(loc.types[[input$inSelTrackLabel]] %in% c('numeric', 'integer') & loc.types[[input$inSelSite]] %in% c('numeric', 'integer'))
{ {
...@@ -645,7 +639,7 @@ shinyServer(function(input, output, session) { ...@@ -645,7 +639,7 @@ shinyServer(function(input, output, session) {
## Normalization ## Normalization
# F-n myNorm adds additional column with .norm suffix # F-n myNorm adds additional column with .norm suffix
if (input$chBnorm) { if (input$chBnorm) {
loc.out = myNorm( loc.out = tca::normTraj(
in.dt = loc.out, in.dt = loc.out,
in.meas.col = 'y', in.meas.col = 'y',
in.rt.col = 'realtime', in.rt.col = 'realtime',
...@@ -730,9 +724,16 @@ shinyServer(function(input, output, session) { ...@@ -730,9 +724,16 @@ shinyServer(function(input, output, session) {
} }
) )
###### Trajectory plotting
callModule(modTrajRibbonPlot, 'modTrajRibbon', data4trajPlot)
callModule(modTrajRibbonPlot, 'modTrajRibbon',
in.data = data4trajPlot)
#### ###### Trajectory plotting
## UI for trajectory plot callModule(modTrajPlot, 'modTrajPlot', data4trajPlot)
## UI for selecting trajectories
# The output data table of data4trajPlot is modified based on inSelHighlight field
output$varSelHighlight = renderUI({ output$varSelHighlight = renderUI({
cat(file = stderr(), 'UI varSelHighlight\n') cat(file = stderr(), 'UI varSelHighlight\n')
...@@ -752,17 +753,12 @@ shinyServer(function(input, output, session) { ...@@ -752,17 +753,12 @@ shinyServer(function(input, output, session) {
} }
}) })
###### Trajectory plotting ###### AUC calculation and plotting
callModule(modTrajPlot, 'modTrajPlot', data4trajPlot)
###### AUC caluclation and plotting
callModule(modAUCplot, 'tabAUC', data4trajPlot) callModule(modAUCplot, 'tabAUC', data4trajPlot)
###### Box-plot ###### Box-plot
callModule(tabBoxPlot, 'tabBoxPlot', data4trajPlot) callModule(tabBoxPlot, 'tabBoxPlot', data4trajPlot)
###### Scatter plot ###### Scatter plot
callModule(tabScatterPlot, 'tabScatter', data4trajPlot) callModule(tabScatterPlot, 'tabScatter', data4trajPlot)
......
...@@ -42,7 +42,7 @@ shinyUI(fluidPage( ...@@ -42,7 +42,7 @@ shinyUI(fluidPage(
uiOutput('uiButLoadTrajRem'), uiOutput('uiButLoadTrajRem'),
tags$hr(), tags$hr(),
checkboxInput('chBtrackUni', 'Track Label unique across entire dataset', TRUE), checkboxInput('chBtrackUni', 'Create unique TrackLabel', T),
helpPopup( helpPopup(
title = 'Create unique cell ID', title = 'Create unique cell ID',
content = help.text[2], content = help.text[2],
...@@ -87,21 +87,32 @@ shinyUI(fluidPage( ...@@ -87,21 +87,32 @@ shinyUI(fluidPage(
downloadButton('downloadDataClean', 'Download mod\'d data') downloadButton('downloadDataClean', 'Download mod\'d data')
), ),
mainPanel(tabsetPanel( mainPanel(
tabsetPanel(
tabPanel( tabPanel(
"Time courses", "Time series",
h4( h4(
"Plot time series" "Plot time series: means per group or individual"
),
br(),
tabsetPanel(
tabPanel("Means",
br(),
modTrajRibbonPlotUI('modTrajRibbon')
), ),
tabPanel(
"Individual",
br(), br(),
checkboxInput('chBhighlightTraj', 'Highlight trajectories?', FALSE), checkboxInput('chBhighlightTraj', 'Highlight trajectories?', FALSE),
uiOutput('varSelHighlight'), uiOutput('varSelHighlight'),
br(), br(),
modTrajPlotUI('modTrajPlot') modTrajPlotUI('modTrajPlot')
)
)
), ),
tabPanel( tabPanel(
"AUC", "AUC",
modAUCplotUI('tabAUC') modAUCplotUI('tabAUC')
......
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