
%% Stangle("segVariance.Rnw"); source("segVariance.R")

\documentclass[11pt]{article}
\newcommand{\Robject}[1]{\texttt{#1}}
\newcommand{\Rpackage}[1]{\textit{#1}}
\newcommand{\Rfunction}[1]{\textit{#1}}
\newcommand{\Rclass}[1]{\textit{#1}}

\newcommand{\myincfig}[3]{%
  \begin{figure}[htbp]
    \begin{center}
      \includegraphics[width=#2]{#1}
      \caption{\label{#1}#3}
    \end{center}
  \end{figure}
}

\begin{document}

%------------------------------------------------------------
\title{Assessing the significance of segmentation}
%------------------------------------------------------------
\author{Wolfgang Huber}
\maketitle
% \tableofcontents

<<setup, echo=FALSE, results=hide>>=
options(error=recover, warn=2)
library("tilingArray")

calcStat = function(e, j, nrBasePerSeg = 1500) {
  dat = get(sub("rda", "dat", j), envir=e)
  seg = get(sub("rda", "seg", j), envir=e)
  if(is.vector(dat$y))
    dim(dat$y)=c(length(dat$y), 1)
  stopifnot(nrow(dat$y)==length(dat$x))
  cp = floor(max(dat$x)/nrBasePerSeg)
  th = c(1, seg$th[cp, 1:cp])
  ct = cut(1:nrow(dat$y), breaks=th-1)
  ## note: dat$y is a matrix with length(ct) rows. The recycling rule
  ## works in our favour here!
  sp = split(dat$y, ct)
  d  = ncol(dat$y)

  v    = sapply(sp, var)
  m    = sapply(sp, mean)
  n    = listLen(sp)
  ## residuals
  res  = sapply(sp, function(x) {rowMeans(matrix(x, ncol=d))-mean(x)}) 
    
  t = numeric(length(sp))
  for (z in 2:length(sp)) {
    sdev = sqrt(  ((n[z-1]-1)*v[z-1]+(n[z]-1)*v[z]) / (n[z]+n[z-1]-2) )
    t[z] = (m[z]-m[z-1]) / (sdev*sqrt(1/n[z]+1/n[z-1]))
  }
  z = sample(2:length(sp), 1)
  stopifnot(abs(t[z] - t.test(sp[[z]], sp[[z-1]], var.equal=TRUE)$statistic) < 1e-9)
  
  return(list(statistic=t, n=n, res=res))
}

indir = "seg-polyA-050418"

indir = "segmentation-3polyA"
## indir = "segmentation-050209v4"

nrchr = 16
js    = paste(rep(1:nrchr, each=2), rep(c("+", "-"), nrchr), "rda", sep=".")

if(!exists("s")) {
  s  = new.env()
  r  = new.env()
  cat("Loading: ")
  for(j in js) {
    cat(j, "")
    load(file.path(indir, j))
    assign(sub("rda", "seg", j), seg, envir=s)
    assign(sub("rda", "dat", j), dat, envir=s)
    load(file.path(indir, sub(".rda", "rand.rda", j)))
    assign(sub("rda", "seg", j), seg, envir=r)
    assign(sub("rda", "dat", j), dat, envir=r)
  }
  cat("\n")
}
@ 

%--------------------------------------------------
\section{Autocorrelation}
%--------------------------------------------------
First we have a look at the autocorrelation of the residuals.
%
<<acf, fig=TRUE, include=FALSE, eps=FALSE>>=
j  = "1.+.rda"
ts = calcStat(s, j)
acf(unlist(ts$res), lag.max=50, main="autocorrelation of residuals")
@
% 
\myincfig{segVariance-acf}{0.66\textwidth}{Autocorrelation of residuals. 
(Residuals are what remains of the data when within each segment the segment's
  mean is subtracted. A \textit{Lag} of 1 corresponds to the typical spacing
  between probe starts, i.e. 8 bases.)}
The result is shown in Fig.~\ref{segVariance-acf}. We can see that next
neighbours and second-next neighbours have pretty high correlation. The
correlation then decays and is gone after after 25 probes (200 bases).

However, we see that (neighbouring) probes are not independent, and we need to
be careful with methods that make the assumption of independence.

%--------------------------------------------------
\section{(Log-)Likelihood}
%--------------------------------------------------
The (log-)likelihood is a number that measures how well a certain model fits
data. In principle, the higher the likelihood, the better. However, the more
parameters a model has, the more likely it is susceptible to overfitting, that
is, to fitting the noise rather than the underlying signal. In our case, each
additional segment introduces two new parameters. We thus need to compare the
the gain in likelihood with the cost of having more
parameters. This is called \textit{penalized likelihood}
%
\[
PL(n) = L(n) - C(n)
\]  
%
where $L(n)$ is the optimal likelihood for a model with $n$ parameters, $C(n)$
is a cost function for having $n$ parameters, and $PL(n)$ is the penalized
likelihood. The hard part is finding a good cost function (there are several
plausible choices and the choice is not obvious).

Some explorations are made in the following code and plots.
The quantity \Robject{J} which is returned from the segmentation algorithm is
proportional\footnote{to do: fix this factor so it's actually the 
log-likelihood} to the log-likelihood. \Robject{J[n]} is the
log-likelihood of the best model with \Robject{n} segments.
%
<<likelihood, fig=TRUE, include=FALSE, eps=FALSE>>=
segs = get(sub("rda", "seg", j), envir=s)
segr = get(sub("rda", "seg", j), envir=r)
par(mfrow=c(2,2))
plot(segr$J, segs$J)
plot(2*seq(along=segs$J), segs$J, main="data")
plot(2*seq(along=segr$J), segr$J, main="random")
ddJ = diff(segs$J) ## diff(diff(segs$J))
plot(2*seq(along=ddJ), ddJ, 
ylim=quantile(ddJ, c(0.01, .99), na.rm=TRUE), main="data")
@ 
\myincfig{segVariance-likelihood}{\textwidth}{Top left: plot of 
log-likelihood of real data ($y$-axis) versus randomly permuted 
($x$x-axis). Top right: log-likelihood of real data versus number of 
segments. Bottom left: log-likelihood of randomly permuted data 
versus number of segments. Bottom right: local slope (``first 
derivative'') of the function $J(i)$.
}
The result is shown in Figure~\ref{segVariance-likelihood}. The major result
from these plots is that the likelihood of the model on randomized data is
approximately proportional to the number of segments. This is consistent with
a cost function $C$ that is simply proportional to $n$ - which is nice.

%--------------------------------------------------
\section{$t$-statistic}
%--------------------------------------------------
For each change point (= the jump points between the segments) we can
calculate a $t$-statistic between the segments on both of its sides.  The
distribution of these and the comparison with the situation for randomized
data is made in the following code and plots.
%
<<tstat, fig=TRUE, include=FALSE, eps=FALSE>>=
ts = calcStat(s, j)
tr = calcStat(r, j)
par(mfrow=c(3,2))
hist(ts$statistic, col="lightblue", breaks=50,
   main="t-statistic (data)")
hist(ts$n, col="lightblue", breaks=50,
   main="length of segments (data)")
hist(tr$statistic, col="orange", breaks=50,
   main="t-statistic (randomized)")
hist(tr$n, col="orange", breaks=50,
   main="length of segments (randomized)")
qqplot(ts$statistic, tr$statistic); abline(a=0, b=1, col="red")
@ 
%
\myincfig{segVariance-tstat}{\textwidth}{$t$-statistic.  Note how the
distribution of $t$-statistics has two peaks at positive and negative values,
and almost no weight at 0, even for randomized data (orange). This is due to
the segmentation algorithm, which finds apparent segments even in random
data. However, the $t$-values for the actual data (light blue) are much more
extreme. Comparison of the two distributions could be used to calculate a 
false discovery rate (FDR).}
The result is shown in Figure~\ref{segVariance-tstat}.

%--------------------------------------------------
\section{FDR}
%--------------------------------------------------
<<fdr, fig=TRUE, include=FALSE, eps=FALSE>>=
nrbps = seq(1000, 3000, by=200)
fdr   = matrix(NA, nrow=length(nrbps), ncol=length(js))
for(j in seq(along=js)) {
  for(i in seq(along=nrbps)) {
    ts = calcStat(s, js[j], nrBasePerSeg = nrbps[i]) 
    tr = calcStat(r, js[j], nrBasePerSeg = nrbps[i])
    fdr[i, j] =  mean(abs(ts$statistic) < max(abs(tr$statistic)))
  }
}
matplot(nrbps, fdr, xlab='average number of bases per segment',
  ylab='false discovery rate', type='b')

@ 
\myincfig{segVariance-fdr}{0.7\textwidth}{False discovery rates 
as a function of the parameter \Robject{nrBasePerSeg}, the 
average number of bases per segment.}


%--------------------------------------------------
\section{Next step}
%--------------------------------------------------
Use a criterion based on the penalized likelihood (with some choice of cost
function, for what we want to do here it may not matter that much). This will
produce a set of $n$ segments. Do the same for randomized data. This will
produce a set of $n'$ segments, with $n'\ll n$ and the false discovery rate
(FDR) may be estimated by $n'/n$.

<<eval=FALSE, echo=FALSE>>=
## see whether variance depends on position along chromosome
## (it doesn't seem to)
par(mfrow=c(4,4), mai=c(0.3, 0.4, 0.4, 0.01))
for(j in js) {
  dat = get(sub("rda", "dat", j), envir=s)
  dy  = diff(dat$y)
  dy  = dy[abs(dy)<=2]
  smoothScatter(seq(along=dy), dy, pch=".", main=j)
}
@


<<signs, fig=TRUE, include=FALSE, eps=FALSE>>=
nrbps = seq(1000, 3000, by=200)
sis   = matrix(NA, nrow=length(nrbps), ncol=length(js))
for(j in seq(along=js)) {
  dat = get(sub("rda", "dat", js[j]), envir=s)
  seg = get(sub("rda", "seg", js[j]), envir=s)
  n   = length(dat$x)
  for(i in seq(along=nrbps)) {
    cp = floor(max(dat$x)/nrbps[i])
    th = seg$th[cp[i], 1:cp[i]]
    theCut = cut(1:n, breaks=c(0, th-1))
    stopifnot(th[length(th)]==n+1)
    ms = tapply(rowMeans(dat$y), theCut, mean)
    ## sign(diff(ms)) are the signs of the jumps from one segment to another.
    ## if they are alternating, sg is +2/-2, if they are in the same direction,
    ## they are 0.
    sg = diff(sign(diff(ms)))
    sis[i, j] = sum(sg==0)
  }
}


matplot(nrbps, sis, xlab='average number of bases per segment',
  ylab='sign statistic', type='b')

\end{document}
